[m-dev.] for review: MLDS back-end: implement typeclasses

Fergus Henderson fjh at cs.mu.OZ.AU
Thu May 11 00:46:21 AEST 2000


With these changes, the MLDS back-end now passes all of the tests in
hard_coded/typeclasses, except for typeclass_exist_method.m (the bug
there is a bug with existential types, that is unrelated to the use of
type classes).

I will probably go ahead and commit this very soon,
unless anyone objects.

----------

Estimated hours taken: 12

Implement typeclasses for the MLDS back-end.

compiler/rtti.m:
	Add base_typeclass_info as a new alternative in the
	rtti_name and rtti_data types.

compiler/base_typeclass_info.m:
	Change it to define base_typeclass_infos as rtti_data
	rather than comp_gen_c_data.

compiler/mercury_compile.m:
	Modify to reflect the changes to base_typeclass_info.m's
	interface.
	Also change the order in which we run the MLDS passes: make
	sure to generate all the MLDS, including that generated by
	rtti_to_mlds.m, before running the MLDS transformation passes
	ml_tailcall.m and ml_elim_nested.m, since the wrapper
	functions that rtti_to_mlds.m generates for typeclass methods
	can contain code which those two MLDS transformation passes
	need to transform.

compiler/rtti_out.m:
compiler/rtti_to_mlds.m:
compiler/mlds_to_c.m:
compiler/opt_debug.m:
	Handle base_typeclass_infos.

compiler/mlds_to_c.m:
	Fix a bug where it was not properly mangling variable names.
	Note that polymorphism.m can introduce variable names
	that contain operators, e.g. `TypeClassInfo_for_+'.
	This bug broke tests/hard_coded/operator_classname.m.
	I also changed it to mangle label names.

compiler/rtti_to_mlds.m:
	Pass down the module_info, so that ml_gen_init_method
	can use it when generate wrapper functions for type
	class methods.

compiler/ml_unify_gen.m:
	Export the ml_gen_closure_wrapper procedure, for use by
	rtti_to_mlds for type class methods.

compiler/ml_code_util.m:
	Add a new predicate `ml_gen_info_bump_func_label',
	for use by rtti_to_mlds.m when generating wrapper 
	Add some functions defining magic numbers related to
	the representation of type_infos, base_typeclass_infos,
	and closures.

compiler/ml_call_gen.m:
	Handle type class method calls.

compiler/llds_out.m:
	Split the code for outputting a base_typeclass_info name
	into a separate subroutine, and export that subroutine,
	for use by rtti_out.m.

compiler/llds_out.m:
compiler/rtti_out.m:
	Move the code for handling dynamic initialization of
	method pointers from llds_out.m to rtti_out.m,
	at the same time changing it to handle their new definitions
	as rtti_data rather than comp_gen_c_data.

compiler/mlds.m:
	Delete the type `base_data', since it is no longer needed.

compiler/notes/type_class_transformation.html:
	Fix a documentation bug: the second field of
	base_typeclass_infos is the number of instance constraints,
	not the number of unconstrained type variables.

compiler/notes/compiler_design.html:
	Document the use of the rtti modules in the MLDS back-end,
	and improve the documentation of their use in the LLDS back-end.

Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/base_typeclass_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/base_typeclass_info.m,v
retrieving revision 1.18
diff -u -d -r1.18 base_typeclass_info.m
--- compiler/base_typeclass_info.m	2000/04/10 07:19:02	1.18
+++ compiler/base_typeclass_info.m	2000/05/10 09:21:38
@@ -4,9 +4,9 @@
 % Public License - see the file COPYING in the Mercury distribution.
 %---------------------------------------------------------------------------%
 %
-% This module generates the LLDS code that defines global variables
-% to hold the base_typeclass_info structures of the typeclass instances defined
-% by the current module.
+% This module generates the RTTI data for the global variables (or constants)
+% that hold the base_typeclass_info structures of the typeclass instances
+% defined by the current module.
 %
 % See notes/type_class_transformation.html for a description of the various 
 % ways to represent type information, including a description of the
@@ -20,10 +20,10 @@
 
 :- interface.
 
-:- import_module hlds_module, list, llds, prog_data.
+:- import_module hlds_module, list, rtti, prog_data.
 
-:- pred base_typeclass_info__generate_llds(module_info, list(comp_gen_c_data)).
-:- mode base_typeclass_info__generate_llds(in, out) is det.
+:- pred base_typeclass_info__generate_rtti(module_info, list(rtti_data)).
+:- mode base_typeclass_info__generate_rtti(in, out) is det.
 
 	% Given a list of types, mangle the names so into a string which
 	% identifies them. The types must all have their top level functor
@@ -41,40 +41,40 @@
 
 %---------------------------------------------------------------------------%
 
-base_typeclass_info__generate_llds(ModuleInfo, CModules) :-
+base_typeclass_info__generate_rtti(ModuleInfo, RttiDataList) :-
 	module_info_name(ModuleInfo, ModuleName),
 	module_info_instances(ModuleInfo, InstanceTable),
 	map__to_assoc_list(InstanceTable, AllInstances),
 	base_typeclass_info__gen_infos_for_classes(AllInstances, ModuleName,
-		ModuleInfo, CModules).
+		ModuleInfo, RttiDataList).
 
 :- pred base_typeclass_info__gen_infos_for_classes(assoc_list(class_id,
 	list(hlds_instance_defn)), module_name, module_info,
-	list(comp_gen_c_data)).
+	list(rtti_data)).
 :- mode base_typeclass_info__gen_infos_for_classes(in, in, in, out) is det.
 
 base_typeclass_info__gen_infos_for_classes([], _ModuleName, _ModuleInfo, []).
 base_typeclass_info__gen_infos_for_classes([C|Cs], ModuleName, ModuleInfo, 
-		CModules) :-
+		RttiDataList) :-
 	base_typeclass_info__gen_infos_for_instance_list(C, ModuleName,
-		ModuleInfo, CModules1),
+		ModuleInfo, RttiDataList1),
 	base_typeclass_info__gen_infos_for_classes(Cs, ModuleName,
-		ModuleInfo, CModules2),
+		ModuleInfo, RttiDataList2),
 	% XXX make it use an accumulator
-	list__append(CModules1, CModules2, CModules).
+	list__append(RttiDataList1, RttiDataList2, RttiDataList).
 
 	% XXX make it use an accumulator
 :- pred base_typeclass_info__gen_infos_for_instance_list(
 	pair(class_id, list(hlds_instance_defn)), module_name, module_info,
-	list(comp_gen_c_data)).
+	list(rtti_data)).
 :- mode base_typeclass_info__gen_infos_for_instance_list(in, in, in, out) 
 	is det.
 
 base_typeclass_info__gen_infos_for_instance_list(_ - [], _, _, []).
 base_typeclass_info__gen_infos_for_instance_list(ClassId - [InstanceDefn|Is], 
-		ModuleName, ModuleInfo, CModules) :-
+		ModuleName, ModuleInfo, RttiDataList) :-
 	base_typeclass_info__gen_infos_for_instance_list(ClassId - Is,
-		ModuleName, ModuleInfo, CModules1),
+		ModuleName, ModuleInfo, RttiDataList1),
 	InstanceDefn = hlds_instance_defn(ImportStatus, _TermContext,
 				InstanceConstraints, InstanceTypes, Body,
 				PredProcIds, _Varset, _SuperClassProofs),
@@ -84,128 +84,76 @@
 			% declaration originally came from _this_ module.
 		status_defined_in_this_module(ImportStatus, yes)
 	->
-
 		base_typeclass_info__make_instance_string(InstanceTypes, 
 			InstanceString),
-
-		DataName = base_typeclass_info(ClassId, InstanceString),
-
-		base_typeclass_info__gen_rvals_and_procs(PredProcIds,
+		base_typeclass_info__gen_body(PredProcIds,
 			InstanceTypes, InstanceConstraints, ModuleInfo, 
-			ClassId, Rvals, Procs),
-		
-			% XXX Need we always export it from the module?
-			% (Note that linkage/2 in llds_out.m assumes
-			% that we do.)
-		Status = yes,
-
-		CModule = comp_gen_c_data(ModuleName, DataName,
-			Status, Rvals, uniform(no), Procs),
-		CModules = [CModule | CModules1]
+			ClassId, BaseTypeClassInfo),
+		RttiData = base_typeclass_info(ClassId, InstanceString,
+			BaseTypeClassInfo),
+		RttiDataList = [RttiData | RttiDataList1]
 	;
 			% The instance decl is from another module,
 			% or is abstract, so we don't bother including it.
-		CModules = CModules1
+		RttiDataList = RttiDataList1
 	).
 
 %----------------------------------------------------------------------------%
 
-:- pred base_typeclass_info__gen_rvals_and_procs(maybe(list(hlds_class_proc)),
-	list(type), list(class_constraint), module_info, class_id,
-	list(maybe(rval)), list(pred_proc_id)).
-:- mode base_typeclass_info__gen_rvals_and_procs(in, in, in, in, in, 
-	out, out) is det.
+:- pred base_typeclass_info__gen_body(maybe(list(hlds_class_proc)),
+		list(type), list(class_constraint), module_info, class_id,
+		base_typeclass_info).
+:- mode base_typeclass_info__gen_body(in, in, in, in, in, out) is det.
 
-base_typeclass_info__gen_rvals_and_procs(no, _, _, _, _, [], []) :-
+base_typeclass_info__gen_body(no, _, _, _, _, _) :-
 	error("pred_proc_ids should have been filled in by check_typeclass.m").
-base_typeclass_info__gen_rvals_and_procs(yes(PredProcIds0), Types, Constraints,
-		ModuleInfo, ClassId, Rvals, PredProcIds) :-
-
-
+base_typeclass_info__gen_body(yes(PredProcIds0), Types, Constraints,
+		ModuleInfo, ClassId, BaseTypeClassInfo) :-
 	term__vars_list(Types, TypeVars),
 	get_unconstrained_tvars(TypeVars, Constraints, Unconstrained),
 	list__length(Constraints, NumConstraints),
 	list__length(Unconstrained, NumUnconstrained),
-	NumExtraArg = yes(const(int_const(NumConstraints+NumUnconstrained))),
-	NumConstraintsArg = yes(const(int_const(NumConstraints))),
+	NumExtra = NumConstraints + NumUnconstrained,
 	ExtractPredProcId = lambda([HldsPredProc::in, PredProc::out] is det,
 		(
 			HldsPredProc = hlds_class_proc(PredId, ProcId),
 			PredProc = proc(PredId, ProcId)
 		)),
 	list__map(ExtractPredProcId, PredProcIds0, PredProcIds),
-	base_typeclass_info__construct_pred_addrs(PredProcIds, ModuleInfo,
-		PredAddrArgs),
+	base_typeclass_info__construct_proc_labels(PredProcIds, ModuleInfo,
+		ProcLabels),
 	base_typeclass_info__gen_superclass_count(ClassId, ModuleInfo,
 			SuperClassCount, ClassArity),
-	list__length(PredAddrArgs, NumMethods),
-	NumMethodsArg = yes(const(int_const(NumMethods))),
-	Rvals = [ NumExtraArg, NumConstraintsArg, SuperClassCount, 
-			ClassArity, NumMethodsArg | PredAddrArgs ].
+	list__length(ProcLabels, NumMethods),
+	BaseTypeClassInfo = base_typeclass_info(NumExtra, NumConstraints,
+		SuperClassCount, ClassArity, NumMethods, ProcLabels).
 
-:- pred base_typeclass_info__construct_pred_addrs(list(pred_proc_id),
-	module_info, list(maybe(rval))).
-:- mode base_typeclass_info__construct_pred_addrs(in, in, out) is det.
+:- pred base_typeclass_info__construct_proc_labels(list(pred_proc_id),
+	module_info, list(rtti_proc_label)).
+:- mode base_typeclass_info__construct_proc_labels(in, in, out) is det.
 
-base_typeclass_info__construct_pred_addrs([], _, []).
-base_typeclass_info__construct_pred_addrs([proc(PredId, ProcId) | Procs],
-		ModuleInfo, [PredAddrArg | PredAddrArgs]) :-
-	code_util__make_entry_label(ModuleInfo, PredId, ProcId, no, PredAddr),
-	PredAddrArg = yes(const(code_addr_const(PredAddr))),
-	base_typeclass_info__construct_pred_addrs(Procs, ModuleInfo,
-		PredAddrArgs).
+base_typeclass_info__construct_proc_labels([], _, []).
+base_typeclass_info__construct_proc_labels([proc(PredId, ProcId) | Procs],
+		ModuleInfo, [ProcLabel | ProcLabels]) :-
+	ProcLabel = rtti__make_proc_label(ModuleInfo, PredId, ProcId),
+	base_typeclass_info__construct_proc_labels(Procs, ModuleInfo,
+		ProcLabels).
 
 %----------------------------------------------------------------------------%
 
 :- pred base_typeclass_info__gen_superclass_count(class_id, module_info, 
-		maybe(rval), maybe(rval)).
+		int, int).
 :- mode base_typeclass_info__gen_superclass_count(in, in, out, out) is det.
 
 base_typeclass_info__gen_superclass_count(ClassId, ModuleInfo, 
-		SuperArg, ArityArg) :-
-	module_info_classes(ModuleInfo, ClassTable),
-	map__lookup(ClassTable, ClassId, ClassDefn),
-	ClassDefn = hlds_class_defn(_, SuperClassConstraints, ClassVars,
-			_, _, _, _),
-	list__length(SuperClassConstraints, NumSuper),
-	list__length(ClassVars, NumVars),
-	SuperArg = yes(const(int_const(NumSuper))),
-	ArityArg = yes(const(int_const(NumVars))).
-
-%----------------------------------------------------------------------------%
-
-:- pred base_typeclass_info__gen_superclass_rvals(class_id, module_info, 
-		list(type), list(maybe(rval))).
-:- mode base_typeclass_info__gen_superclass_rvals(in, in, in, out) is det.
-
-base_typeclass_info__gen_superclass_rvals(ClassId, ModuleInfo, InstanceTypes,
-		SuperClassRvals) :-
+		NumSuperClasses, ClassArity) :-
 	module_info_classes(ModuleInfo, ClassTable),
 	map__lookup(ClassTable, ClassId, ClassDefn),
 	ClassDefn = hlds_class_defn(_, SuperClassConstraints, ClassVars,
 			_, _, _, _),
-	map__from_corresponding_lists(ClassVars, InstanceTypes, VarToType),
-	GetRval = lambda([Constraint::in, Rval::out] is det,
-		(
-			Constraint = constraint(ClassName, ClassTypes),
-			list__length(ClassTypes, Arity),
-			SuperClassId = class_id(ClassName, Arity),
-			term__vars_list(ClassTypes, SuperClassVars), 
-			map__apply_to_list(SuperClassVars, VarToType,
-				UsedInstanceTypes),
-			base_typeclass_info__make_instance_string(
-				UsedInstanceTypes, InstanceString),
+	list__length(SuperClassConstraints, NumSuperClasses),
+	list__length(ClassVars, ClassArity).
 
-			DataName = base_typeclass_info(SuperClassId,
-					InstanceString),
-				% it doesn't matter which module the instance
-				% decl comes from
-			Module = unqualified("<unknown>"),
-			DataAddr = data_addr(Module, DataName),
-			Rval =  yes(const(data_addr_const(DataAddr)))
-		)),
-	list__map(GetRval, SuperClassConstraints, SuperClassRvals).
-	
 %----------------------------------------------------------------------------%
 
 	% Note that for historical reasons, builtin types
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.142
diff -u -d -r1.142 llds_out.m
--- compiler/llds_out.m	2000/04/26 05:40:20	1.142
+++ compiler/llds_out.m	2000/05/10 09:12:54
@@ -182,6 +182,12 @@
 :- pred llds_out__make_base_typeclass_info_name(class_id, string, string).
 :- mode llds_out__make_base_typeclass_info_name(in, in, out) is det.
 
+	% output the name for base_typeclass_info,
+	% with the appropriate "mercury_data_" prefix.
+
+:- pred output_base_typeclass_info_name(class_id, string, io__state, io__state).
+:- mode output_base_typeclass_info_name(in, in, di, uo) is det.
+
 	% Convert a label to a string description of the stack layout
 	% structure of that label.
 
@@ -656,14 +662,6 @@
 	->
 		rtti_out__init_rtti_data_if_nec(RttiData)
 	;
-		{ Data = comp_gen_c_data(ModuleName, DataName, _, ArgRvals,
-			_, _) },
-		{ DataName = base_typeclass_info(_ClassName, _ClassArity) }
-	->
-		io__write_string("#ifndef MR_STATIC_CODE_ADDRESSES\n"),
-		output_init_method_pointers(1, ArgRvals, DataName, ModuleName),
-		io__write_string("#endif /* MR_STATIC_CODE_ADDRESSES */\n")
-	;
 		{ Data = comp_gen_c_data(ModuleName, DataName, _, _, _, _) },
 		{ DataName = module_layout }
 	->
@@ -677,23 +675,6 @@
 	),
 	output_c_data_init_list(Datas).
 
-:- pred output_init_method_pointers(int, list(maybe(rval)), data_name, module_name,
-	io__state, io__state).
-:- mode output_init_method_pointers(in, in, in, in, di, uo) is det.
-
-output_init_method_pointers(_, [], _, _) --> [].
-output_init_method_pointers(ArgNum, [Arg|Args], DataName, ModuleName) -->
-	( { Arg = yes(const(code_addr_const(CodeAddr))) } ->
-		io__write_string("\t\t"),
-		output_data_addr(ModuleName, DataName),
-		io__format(".f%d =\n\t\t\t", [i(ArgNum)]),
-		output_code_addr(CodeAddr),
-		io__write_string(";\n")
-	;
-		[]
-	),
-	output_init_method_pointers(ArgNum + 1, Args, DataName, ModuleName).
-
 	% Output a comment to tell mkinit what functions to
 	% call from <module>_init.c.
 :- pred output_init_comment(module_name, io__state, io__state).
@@ -3265,11 +3246,7 @@
 			% instance decls, even if they are in a different
 			% module
 		{ VarName = base_typeclass_info(ClassId, TypeNames) },
-		{ llds_out__make_base_typeclass_info_name(ClassId, TypeNames,
-			Str) },
-		io__write_string(mercury_data_prefix),
-		io__write_string("__"),
-		io__write_string(Str)
+		output_base_typeclass_info_name(ClassId, TypeNames)
 	;
 		{ VarName = module_layout },
 		io__write_string(mercury_data_prefix),
@@ -4230,6 +4207,12 @@
 	llds_out__name_mangle(TypeNames, MangledTypeNames),
 	string__append_list(["base_typeclass_info_", MangledClassString,
 		"__arity", ArityString, "__", MangledTypeNames], Str).
+
+output_base_typeclass_info_name(ClassId, TypeNames) -->
+	{ llds_out__make_base_typeclass_info_name(ClassId, TypeNames, Str) },
+	io__write_string(mercury_data_prefix),
+	io__write_string("__"),
+	io__write_string(Str).
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.159
diff -u -d -r1.159 mercury_compile.m
--- compiler/mercury_compile.m	2000/05/09 14:24:04	1.159
+++ compiler/mercury_compile.m	2000/05/10 13:23:45
@@ -2056,8 +2056,10 @@
 	% rather than output_pass.
 	%
 	{ type_ctor_info__generate_rtti(HLDS0, TypeCtorRttiData) },
+	{ base_typeclass_info__generate_rtti(HLDS0, TypeClassInfoRttiData) },
 	{ list__map(llds__wrap_rtti_data, TypeCtorRttiData, TypeCtorTables) },
-	{ base_typeclass_info__generate_llds(HLDS0, TypeClassInfos) },
+	{ list__map(llds__wrap_rtti_data, TypeClassInfoRttiData,
+		TypeClassInfos) },
 	{ stack_layout__generate_llds(HLDS0, HLDS, GlobalData,
 		PossiblyDynamicLayouts, StaticLayouts, LayoutLabels) },
 	%
@@ -2239,6 +2241,7 @@
 	mercury_compile__maybe_dump_hlds(HLDS53, "53", "simplify2"),
 
 	{ HLDS = HLDS53 },
+	mercury_compile__maybe_dump_hlds(HLDS, "99", "final"),
 
 	maybe_write_string(Verbose, "% Converting HLDS to MLDS...\n"),
 	ml_code_gen(HLDS, MLDS0),
@@ -2246,40 +2249,45 @@
 	maybe_report_stats(Stats),
 	mercury_compile__maybe_dump_mlds(MLDS0, "0", "initial"),
 
+	maybe_write_string(Verbose, "% Generating RTTI data...\n"),
+	{ mercury_compile__mlds_gen_rtti_data(HLDS, MLDS0, MLDS10) },
+	maybe_write_string(Verbose, "% done.\n"),
+	maybe_report_stats(Stats),
+	mercury_compile__maybe_dump_mlds(MLDS10, "10", "rtti"),
+
 	% XXX this pass should be conditional on a compilation option
 
 	maybe_write_string(Verbose, "% Detecting tail calls...\n"),
-	ml_mark_tailcalls(MLDS0, MLDS1),
+	ml_mark_tailcalls(MLDS10, MLDS20),
 	maybe_write_string(Verbose, "% done.\n"),
 	maybe_report_stats(Stats),
-	mercury_compile__maybe_dump_mlds(MLDS1, "1", "tailcalls"),
+	mercury_compile__maybe_dump_mlds(MLDS20, "20", "tailcalls"),
 
 	globals__io_lookup_bool_option(gcc_nested_functions, NestedFuncs),
 	( { NestedFuncs = no } ->
 		maybe_write_string(Verbose,
 			"% Flattening nested functions...\n"),
-		ml_elim_nested(MLDS1, MLDS2)
+		ml_elim_nested(MLDS20, MLDS30)
 	;
-		{ MLDS2 = MLDS1 }
+		{ MLDS30 = MLDS20 }
 	),
 	maybe_write_string(Verbose, "% done.\n"),
 	maybe_report_stats(Stats),
-	mercury_compile__maybe_dump_mlds(MLDS2, "2", "nested_funcs"),
+	mercury_compile__maybe_dump_mlds(MLDS30, "30", "nested_funcs"),
 
-	maybe_write_string(Verbose, "% Generating RTTI data...\n"),
-	{ mercury_compile__mlds_gen_rtti_data(HLDS, MLDS2, MLDS) },
-	maybe_write_string(Verbose, "% done.\n"),
-	maybe_report_stats(Stats),
-	mercury_compile__maybe_dump_mlds(MLDS, "3", "rtti").
+	{ MLDS = MLDS30 },
+	mercury_compile__maybe_dump_mlds(MLDS, "99", "final").
 
 :- pred mercury_compile__mlds_gen_rtti_data(module_info, mlds, mlds).
 :- mode mercury_compile__mlds_gen_rtti_data(in, in, out) is det.
 
 mercury_compile__mlds_gen_rtti_data(HLDS, MLDS0, MLDS) :-
 	type_ctor_info__generate_rtti(HLDS, TypeCtorRtti),
+	base_typeclass_info__generate_rtti(HLDS, TypeClassInfoRtti),
+	list__append(TypeCtorRtti, TypeClassInfoRtti, RttiData),
+	RttiDefns = rtti_data_list_to_mlds(HLDS, RttiData),
 	MLDS0 = mlds(ModuleName, ForeignCode, Imports, Defns0),
-	TypeCtorDefns = rtti_data_list_to_mlds(ModuleName, TypeCtorRtti),
-	list__append(TypeCtorDefns, Defns0, Defns),
+	list__append(RttiDefns, Defns0, Defns),
 	MLDS = mlds(ModuleName, ForeignCode, Imports, Defns).
 
 % The `--high-level-C' MLDS output pass
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.7
diff -u -d -r1.7 ml_call_gen.m
--- compiler/ml_call_gen.m	2000/05/05 05:29:53	1.7
+++ compiler/ml_call_gen.m	2000/05/10 13:50:57
@@ -69,7 +69,7 @@
 :- import_module builtin_ops.
 :- import_module type_util, mode_util.
 
-:- import_module bool, string, std_util, term, varset, require, map.
+:- import_module bool, int, string, std_util, term, varset, require, map.
 
 %-----------------------------------------------------------------------------%
 %
@@ -80,6 +80,9 @@
 	% Generate MLDS code for an HLDS generic_call goal.
 	% This includes boxing/unboxing the arguments if necessary.
 	%
+	% XXX For typeclass method calls, we do some unnecessary
+	% boxing/unboxing of the arguments.
+	%
 ml_gen_generic_call(GenericCall, ArgVars, ArgModes, CodeModel, Context,
 		MLDS_Decls, MLDS_Statements) -->
 	%
@@ -125,8 +128,33 @@
 		{ FuncType = mlds__func_type(Params) },
 		{ FuncRval = unop(unbox(FuncType), lval(FuncLval)) }
 	;
-		{ GenericCall = class_method(_, _, _, _) },
-		{ sorry("type class methods") }
+		{ GenericCall = class_method(TypeClassInfoVar, MethodNum,
+			_ClassId, _PredName) },
+		%
+		% create the lval for the typeclass_info,
+		% which is also the closure in this case
+		%
+		ml_gen_var(TypeClassInfoVar, TypeClassInfoLval),
+		{ ClosureLval = TypeClassInfoLval },
+		%
+		% extract the base_typeclass_info from the typeclass_info
+		%
+		{ BaseTypeclassInfoFieldId =
+			offset(const(int_const(0))) },
+		{ BaseTypeclassInfoLval = field(yes(0),
+			lval(TypeClassInfoLval), BaseTypeclassInfoFieldId,
+			mlds__generic_type, ClosureArgType) },
+		%
+		% extract the method address from the base_typeclass_info
+		%
+		{ Offset = ml_base_typeclass_info_method_offset },
+		{ MethodFieldNum = MethodNum + Offset },
+		{ MethodFieldId = offset(const(int_const(MethodFieldNum))) },
+		{ FuncLval = field(yes(0), lval(BaseTypeclassInfoLval),
+			MethodFieldId,
+			mlds__generic_type, mlds__generic_type) },
+		{ FuncType = mlds__func_type(Params) },
+		{ FuncRval = unop(unbox(FuncType), lval(FuncLval)) }
 	;
 		{ GenericCall = aditi_builtin(_, _) },
 		{ sorry("Aditi builtins") }
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.9
diff -u -d -r1.9 ml_code_util.m
--- compiler/ml_code_util.m	2000/05/09 18:47:30	1.9
+++ compiler/ml_code_util.m	2000/05/10 12:14:41
@@ -315,7 +315,25 @@
 :- mode ml_declare_env_ptr_arg(out, in, out) is det.
 
 %-----------------------------------------------------------------------------%
+%
+% Magic numbers relating to the representation of
+% typeclass_infos, base_typeclass_infos, and closures.
+%
+	% This function returns the offset to add to the argument
+	% number of a closure arg to get its field number.
+:- func ml_closure_arg_offset = int.
+
+	% This function returns the offset to add to the argument
+	% number of a typeclass_info arg to get its field number.
+:- func ml_typeclass_info_arg_offset = int.
+
+	% This function returns the offset to add to the method number
+	% for a type class method to get its field number within the
+	% base_typeclass_info.
+:- func ml_base_typeclass_info_method_offset = int.
+
 %-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
 %
 % The `ml_gen_info' ADT.
 %
@@ -367,6 +385,16 @@
 :- pred ml_gen_info_new_func_label(ml_label_func, ml_gen_info, ml_gen_info).
 :- mode ml_gen_info_new_func_label(out, in, out) is det.
 
+	% Increase the function label counter by some
+	% amount which is presumed to be sufficient
+	% to ensure that if we start again with a fresh
+	% ml_gen_info and then call this function,
+	% we won't encounter any already-used function labels.
+	% (This is used when generating wrapper functions
+	% for type class methods.)
+:- pred ml_gen_info_bump_func_label(ml_gen_info, ml_gen_info).
+:- mode ml_gen_info_bump_func_label(in, out) is det.
+
 	% Generate a new commit label number.
 	% This is used to give unique names to the labels
 	% used when generating code for commits.
@@ -1271,6 +1299,9 @@
 ml_gen_info_new_func_label(Label, Info, Info^func_label := Label) :-
 	Label = Info^func_label + 1.
 
+ml_gen_info_bump_func_label(Info,
+	Info^func_label := Info^func_label + 10000).
+
 ml_gen_info_new_commit_label(CommitLabel, Info,
 		Info^commit_label := CommitLabel) :-
 	CommitLabel = Info^commit_label + 1.
@@ -1320,6 +1351,43 @@
 	;
 		error("select_output_vars: length mismatch")
 	).
+
+%-----------------------------------------------------------------------------%
+
+	% This function returns the offset to add to the argument
+	% number of a closure arg to get its field number.
+	%	field 0 is the closure layout
+	%	field 1 is the closure address
+	%	field 2 is the number of arguments
+	%	field 3 is the 1st argument field
+	%	field 4 is the 2nd argument field,
+	%	etc.
+	% Hence the offset to add to the argument number
+	% to get the field number is 2.
+ml_closure_arg_offset = 2.
+
+	% This function returns the offset to add to the argument
+	% number of a typeclass_info arg to get its field number.
+	% The Nth extra argument to pass to the method is
+	% in field N of the typeclass_info, so the offset is zero.
+ml_typeclass_info_arg_offset = 0.
+
+	% This function returns the offset to add to the method number
+	% for a type class method to get its field number within the
+	% base_typeclass_info. 
+	%	field 0 is num_extra
+	%	field 1 is num_constraints
+	%	field 2 is num_superclasses
+	%	field 3 is class_arity
+	%	field 4 is num_methods
+	%	field 5 is the 1st method
+	%	field 6 is the 2nd method
+	%	etc.
+	%	(See the base_typeclass_info type in rtti.m or the
+	%	description in notes/type_class_transformation.html for
+	%	more information about the layout of base_typeclass_infos.)
+	% Hence the offset is 4.
+ml_base_typeclass_info_method_offset = 4.
 
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.22
diff -u -d -r1.22 mlds.m
--- compiler/mlds.m	2000/05/01 17:42:20	1.22
+++ compiler/mlds.m	2000/05/10 06:24:11
@@ -1063,10 +1063,10 @@
 %-----------------------------------------------------------------------------%
 
 %
-% Note: the types `tag', `base_data', and `reset_trail_reason' here are all
+% Note: the types `tag' and `reset_trail_reason' here are all
 % defined exactly the same as the ones in llds.m.  The definitions are
 % duplicated here because we don't want mlds.m to depend on llds.m.
-% (Alternatively, we could move all these definitions into a new module
+% (Alternatively, we could move both these definitions into a new module
 % imported by both mlds.m and llds.m, but these definitions are small enough
 % and simple enough that I don't think it is worth creating a new module
 % just for them.)
@@ -1074,18 +1074,6 @@
 
 	% A tag should be a small non-negative integer.
 :- type tag == int.
-
-	% See the definition in llds.m for comments about the meaning
-	% of the `base_data' type.
-	% For some targets, the target language and runtime system might
-	% provide all the necessary information about type layouts,
-	% in which case we won't need to define the type_functors and
-	% type_layout stuff, and we may also be able to use the language's
-	% RTTI rather than defining the type_infos ourselves.
-:- type base_data
-	--->	info
-	;	functors
-	;	layout.
 
 	% see runtime/mercury_trail.h
 :- type reset_trail_reason
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.29
diff -u -d -r1.29 mlds_to_c.m
--- compiler/mlds_to_c.m	2000/05/08 16:41:52	1.29
+++ compiler/mlds_to_c.m	2000/05/10 14:15:31
@@ -8,9 +8,7 @@
 % Main author: fjh.
 
 % TODO:
-%	- RTTI (base_type_layout, base_type_functors,
-%		module_layout, proc_layout)
-%	- type classes (base_typeclass_info)
+%	- RTTI for debugging (module_layout, proc_layout, internal_layout)
 %	- trail ops
 %	- foreign language interfacing and inline target code
 %	- packages, classes and inheritance
@@ -33,7 +31,9 @@
 :- implementation.
 
 :- import_module llds.		% XXX needed for C interface types
-:- import_module llds_out.	% XXX needed for llds_out__name_mangle.
+:- import_module llds_out.	% XXX needed for llds_out__name_mangle,
+				% llds_out__sym_name_mangle, and
+				% llds_out__make_base_typeclass_info_name.
 :- import_module rtti.		% for rtti__addr_to_string.
 :- import_module rtti_to_mlds.	% for mlds_rtti_type_name.
 :- import_module hlds_pred.	% for `pred_proc_id'.
@@ -663,13 +663,26 @@
 :- mode mlds_output_fully_qualified_name(in, di, uo) is det.
 
 mlds_output_fully_qualified_name(QualifiedName) -->
+	{ QualifiedName = qual(_ModuleName, Name) },
 	(
-		%
-		% don't module-qualify main/2
-		%
-		{ QualifiedName = qual(_ModuleName, Name) },
-		{ Name = function(PredLabel, _, _, _) },
-		{ PredLabel = pred(predicate, no, "main", 2) }
+		(
+			%
+			% don't module-qualify main/2
+			%
+			{ Name = function(PredLabel, _, _, _) },
+			{ PredLabel = pred(predicate, no, "main", 2) }
+		;
+			%
+			% don't module-qualify base_typeclass_infos
+			%
+			% We don't want to include the module name as part
+			% of the name if it is a base_typeclass_info, since
+			% we _want_ to cause a link error for overlapping
+			% instance decls, even if they are in a different
+			% module
+			%
+			{ Name = data(base_typeclass_info(_, _)) }
+		)
 	->
 		mlds_output_name(Name)
 	;
@@ -770,16 +783,17 @@
 :- mode mlds_output_data_name(in, di, uo) is det.
 
 mlds_output_data_name(var(Name)) -->
-	{ llds_out__name_mangle(Name, MangledName) },
-	io__write_string(MangledName).
+	mlds_output_mangled_name(Name).
 mlds_output_data_name(common(Num)) -->
 	io__write_string("common_"),
 	io__write_int(Num).
 mlds_output_data_name(rtti(RttiTypeId, RttiName)) -->
 	{ rtti__addr_to_string(RttiTypeId, RttiName, RttiAddrName) },
 	io__write_string(RttiAddrName).
-mlds_output_data_name(base_typeclass_info(_ClassId, _InstanceId)) -->
-	{ error("mlds_to_c.m: NYI: basetypeclass_info") }.
+mlds_output_data_name(base_typeclass_info(ClassId, InstanceStr)) -->
+        { llds_out__make_base_typeclass_info_name(ClassId, InstanceStr,
+		Name) },
+	io__write_string(Name).
 mlds_output_data_name(module_layout) -->
 	{ error("mlds_to_c.m: NYI: module_layout") }.
 mlds_output_data_name(proc_layout(_ProcLabel)) -->
@@ -1372,7 +1386,7 @@
 :- mode mlds_output_label_name(in, di, uo) is det.
 
 mlds_output_label_name(LabelName) -->
-	io__write_string(LabelName).
+	mlds_output_mangled_name(LabelName).
 
 :- pred mlds_output_atomic_stmt(indent, mlds__atomic_statement, mlds__context,
 				io__state, io__state).
@@ -1572,8 +1586,15 @@
 :- mode mlds_output_var(in, di, uo) is det.
 
 mlds_output_var(VarName) -->
-	mlds_output_fully_qualified(VarName, io__write_string).
+	mlds_output_fully_qualified(VarName, mlds_output_mangled_name).
 
+:- pred mlds_output_mangled_name(string, io__state, io__state).
+:- mode mlds_output_mangled_name(in, di, uo) is det.
+
+mlds_output_mangled_name(Name) -->
+	{ llds_out__name_mangle(Name, MangledName) },
+	io__write_string(MangledName).
+
 :- pred mlds_output_bracketed_lval(mlds__lval, io__state, io__state).
 :- mode mlds_output_bracketed_lval(in, di, uo) is det.
 
@@ -1900,8 +1921,24 @@
 :- mode mlds_output_data_var_name(in, in, di, uo) is det.
 
 mlds_output_data_var_name(ModuleName, DataName) -->
-	mlds_output_module_name(mlds_module_name_to_sym_name(ModuleName)),
-	io__write_string("__"),
+	(
+		%
+		% don't module-qualify base_typeclass_infos
+		%
+		% We don't want to include the module name as part
+		% of the name if it is a base_typeclass_info, since
+		% we _want_ to cause a link error for overlapping
+		% instance decls, even if they are in a different
+		% module
+		%
+		{ DataName = base_typeclass_info(_, _) }
+	->
+		[]
+	;
+		mlds_output_module_name(
+			mlds_module_name_to_sym_name(ModuleName)),
+		io__write_string("__")
+	),
 	mlds_output_data_name(DataName).
 
 %-----------------------------------------------------------------------------%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.6
diff -u -d -r1.6 ml_unify_gen.m
--- compiler/ml_unify_gen.m	2000/05/01 17:42:24	1.6
+++ compiler/ml_unify_gen.m	2000/05/10 12:46:50
@@ -16,7 +16,7 @@
 :- interface.
 
 :- import_module prog_data.
-:- import_module hlds_data, hlds_goal.
+:- import_module hlds_pred, hlds_data, hlds_goal.
 :- import_module mlds, ml_code_util.
 :- import_module llds. % XXX for `code_model'
 
@@ -47,12 +47,34 @@
 		mlds__rval, ml_gen_info, ml_gen_info).
 :- mode ml_gen_tag_test(in, in, out, out, out, in, out) is det.
 
+	%
+	% ml_gen_closure_wrapper(PredId, ProcId, Offset, NumClosureArgs,
+	%	Context, WrapperFuncRval, WrapperFuncType):
+	%
+	% Generates a wrapper function which unboxes the input arguments,
+	% calls the specified procedure, passing it some extra arguments
+	% from the closure, and then boxes the output arguments.
+	% It adds the definition of this wrapper function to the extra_defns
+	% field in the ml_gen_info, and return the wrapper function's
+	% rval and type.
+	%
+	% The NumClosuresArgs parameter specifies how many arguments
+	% to extract from the closure.  The Offset parameter specifies
+	% the offset to add to the argument number to get the field
+	% number within the closure.  (Argument numbers start from 1,
+	% and field numbers start from 0.)
+	%
+:- pred ml_gen_closure_wrapper(pred_id, proc_id, int, int, prog_context,
+		mlds__rval, mlds__type, ml_gen_info, ml_gen_info).
+:- mode ml_gen_closure_wrapper(in, in, in, in, in, out, out,
+		in, out) is det.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
 :- implementation.
 
-:- import_module hlds_pred, hlds_module, hlds_out, builtin_ops.
+:- import_module hlds_module, hlds_out, builtin_ops.
 :- import_module ml_call_gen, prog_util, type_util, mode_util.
 :- import_module rtti.
 :- import_module code_util. % XXX needed for `code_util__cons_id_to_tag'.
@@ -267,8 +289,11 @@
 	{ MLDS_Module = mercury_module_name_to_mlds(ModuleName) },
 	{ DataAddr = data_addr(MLDS_Module,
 		base_typeclass_info(ClassId, Instance)) },
+	ml_variable_type(Var, VarType),
 	{ MLDS_Statement = ml_gen_assign(VarLval, 
-		const(data_addr_const(DataAddr)), Context) }.
+		unop(cast(mercury_type(VarType)),
+			const(data_addr_const(DataAddr))),
+		Context) }.
 
 ml_gen_construct_rep(tabling_pointer_constant(PredId, ProcId), _ConsId,
 		Var, Args, _ArgModes, Context, [], [MLDS_Statement]) -->
@@ -344,14 +369,15 @@
 	% arguments and then calls the specified procedure,
 	% and put the address of the wrapper function in the closure.
 	%
-	% We insert the wrapper function in the extra_defns field
-	% in the ml_gen_info; ml_gen_proc will extract it and will
-	% insert it before the mlds__defn for the current procedure.
+	% ml_gen_closure_wrapper will insert the wrapper function in the
+	% extra_defns field in the ml_gen_info; ml_gen_proc will extract
+	% it and will insert it before the mlds__defn for the current
+	% procedure.
 	%
+	{ Offset = ml_closure_arg_offset },
 	{ list__length(ArgVars, NumArgs) },
-	ml_gen_closure_wrapper(PredId, ProcId, NumArgs, Type,
-		Context, WrapperFunc, WrapperFuncRval, WrapperFuncType),
-	ml_gen_info_add_extra_defn(WrapperFunc),
+	ml_gen_closure_wrapper(PredId, ProcId, Offset, NumArgs,
+		Context, WrapperFuncRval, WrapperFuncType),
 
 	%
 	% Generate rvals for the arguments
@@ -405,10 +431,13 @@
 	{ MLDS_Statements = [MLDS_Statement] }.
 
 %-----------------------------------------------------------------------------%
+
 	%
 	% ml_gen_closure_wrapper:
-	% Generate a wrapper function which unboxes the input arguments,
-	% calls the specified procedure, and then boxes the output arguments.
+	% 	see comment in interface section for details.
+	% 
+	% This is used to create wrappers both for ordinary closures and
+	% also for type class methods.
 	%
 	% The generated function will be of the following form:
 	%
@@ -420,7 +449,9 @@
 	%		/* declarations needed for converting output args */
 	%		Arg2Type conv_arg2;
 	%		...
+	% #if MODEL_SEMI
 	%		bool succeeded;
+	% #endif
 	%		
 	%		closure = closure_arg; 	/* XXX should add cast */
 	%
@@ -473,14 +504,8 @@
 	%			foo_1);
 	% #endif
 	%
-:- pred ml_gen_closure_wrapper(pred_id, proc_id, int, prog_type, prog_context,
-		mlds__defn, mlds__rval, mlds__type,
-		ml_gen_info, ml_gen_info).
-:- mode ml_gen_closure_wrapper(in, in, in, in, in, out, out, out,
-		in, out) is det.
-
-ml_gen_closure_wrapper(PredId, ProcId, NumClosureArgs, _ClosureType,
-		Context, WrapperFunc, WrapperFuncRval, WrapperFuncType) -->
+ml_gen_closure_wrapper(PredId, ProcId, Offset, NumClosureArgs,
+		Context, WrapperFuncRval, WrapperFuncType) -->
 	%
 	% grab the relevant information about the called procedure
 	%
@@ -585,11 +610,6 @@
 	%		unbox(arg1), &unboxed_arg2, arg3, ...
 	%	);
 	%
-	% field 0 is the closure layout
-	% field 1 is the closure address
-	% field 2 is the number of arguments
-	% field 3 is the first argument field
-	{ Offset = 2 },
 	ml_gen_closure_field_lvals(ClosureLval, Offset, 1, NumClosureArgs,
 		ClosureArgLvals),
 	ml_gen_wrapper_arg_lvals(WrapperHeadVarNames, WrapperBoxedArgTypes,
@@ -635,8 +655,8 @@
 	ml_gen_new_func_label(WrapperFuncName, WrapperFuncRval),
 	ml_gen_label_func(WrapperFuncName, WrapperParams, Context,
 		WrapperFuncBody, WrapperFunc),
-	{ WrapperFuncType = mlds__func_type(WrapperParams) }.
-
+	{ WrapperFuncType = mlds__func_type(WrapperParams) },
+	ml_gen_info_add_extra_defn(WrapperFunc).
 
 :- func ml_gen_wrapper_head_var_names(int, int) = list(string).
 ml_gen_wrapper_head_var_names(Num, Max) = Names :-
@@ -845,7 +865,7 @@
 :- mode ml_gen_det_deconstruct(in, in, in, in, in, out, out, in, out) is det.
 
 %	det (cannot_fail) deconstruction:
-%		<succeeded = (X => f(A1, A2, ...))>
+%		<do (X => f(A1, A2, ...))>
 % 	===>
 %		A1 = arg(X, f, 1);		% extract arguments
 %		A2 = arg(X, f, 2);
@@ -1093,7 +1113,7 @@
 :- mode ml_gen_semi_deconstruct(in, in, in, in, in, out, out, in, out) is det.
 
 %	semidet (can_fail) deconstruction:
-%		<X => f(A1, A2, ...)>
+%		<succeeded = (X => f(A1, A2, ...))>
 % 	===>
 %		<succeeded = (X => f(_, _, _, _))>	% tag test
 %		if (succeeded) {
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.103
diff -u -d -r1.103 opt_debug.m
--- compiler/opt_debug.m	2000/04/26 05:40:29	1.103
+++ compiler/opt_debug.m	2000/05/10 14:38:14
@@ -785,6 +785,8 @@
 	Str = "du_ptag_ordered_table".
 opt_debug__dump_rtti_name(type_ctor_info, Str) :-
 	Str = "type_ctor_info".
+opt_debug__dump_rtti_name(base_typeclass_info(ClassId, InstanceStr), Str) :-
+	llds_out__make_base_typeclass_info_name(ClassId, InstanceStr, Str).
 opt_debug__dump_rtti_name(pseudo_type_info(_Pseudo), Str) :-
 	% XXX should give more info than this
 	Str = "pseudo_type_info".
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.7
diff -u -d -r1.7 rtti.m
--- compiler/rtti.m	2000/04/25 11:32:04	1.7
+++ compiler/rtti.m	2000/05/10 07:29:21
@@ -25,7 +25,7 @@
 :- interface.
 
 :- import_module llds.	% XXX for code_model
-:- import_module hlds_module, hlds_pred.
+:- import_module hlds_module, hlds_pred, hlds_data.
 :- import_module prog_data, pseudo_type_info.
 
 :- import_module bool, list, std_util.
@@ -299,6 +299,13 @@
 			maybe(rtti_proc_label)	% prettyprinter
 		)
 	;	pseudo_type_info(pseudo_type_info)
+	;	base_typeclass_info(
+			class_id,	% specifies class name & class arity
+			string,		% encodes the names and arities of the
+					% types in the instance declaration
+
+			base_typeclass_info
+		)
 	.
 
 :- type rtti_name
@@ -316,8 +323,40 @@
 	;	du_ptag_ordered_table
 	;	type_ctor_info
 	;	pseudo_type_info(pseudo_type_info)
+	;	base_typeclass_info(
+			class_id,	% specifies class name & class arity
+			string		% encodes the names and arities of the
+					% types in the instance declaration
+		)
 	;	type_hashcons_pointer.
 
+	% A base_typeclass_info holds information about a typeclass instance.
+	% See notes/type_class_transformation.html for details.
+:- type base_typeclass_info --->
+	base_typeclass_info(
+			% num_extra = num_unconstrained + num_constraints,
+			% where num_unconstrained is the number of
+			% unconstrained type variables from the head
+			% of the instance declaration.
+		num_extra :: int,
+			% num_constraints is the number of constraints
+			% on the instance declaration
+		num_constraints :: int,
+			% num_superclasses is the number of constraints
+			% on the typeclass declaration.
+		num_superclasses :: int,
+			% class_arity is the number of type variables
+			% in the head of the class declaration
+		class_arity :: int,
+			% num_methods is the number of procedures
+			% in the typeclass declaration
+		num_methods :: int,
+			% methods is a list of length num_methods
+			% containing the addresses of the methods
+			% for this instance declaration.
+		methods :: list(rtti_proc_label)
+	).
+
 	% convert a rtti_data to an rtti_type_id and an rtti_name.
 	% This calls error/1 if the argument is a type_var/1 rtti_data,
 	% since there is no rtti_type_id to return in that case.
@@ -422,6 +461,9 @@
 	RttiTypeId, du_ptag_ordered_table).
 rtti_data_to_name(type_ctor_info(RttiTypeId, _,_,_,_,_,_,_,_,_,_,_,_),
 	RttiTypeId, type_ctor_info).
+rtti_data_to_name(base_typeclass_info(_, _, _), _, _) :-
+	% there's no rtti_type_id associated with a base_typeclass_info
+	error("rtti_data_to_name: base_typeclass_info").
 rtti_data_to_name(pseudo_type_info(PseudoTypeInfo), RttiTypeId,
 		pseudo_type_info(PseudoTypeInfo)) :-
 	RttiTypeId = pti_get_rtti_type_id(PseudoTypeInfo).
@@ -431,6 +473,7 @@
 pti_get_rtti_type_id(type_info(RttiTypeId, _)) = RttiTypeId.
 pti_get_rtti_type_id(higher_order_type_info(RttiTypeId, _, _)) = RttiTypeId.
 pti_get_rtti_type_id(type_var(_)) = _ :-
+	% there's no rtti_type_id associated with a type_var
 	error("rtti_data_to_name: type_var").
 
 rtti_name_has_array_type(exist_locns(_))		= yes.
@@ -447,6 +490,7 @@
 rtti_name_has_array_type(du_ptag_ordered_table)		= yes.
 rtti_name_has_array_type(type_ctor_info)		= no.
 rtti_name_has_array_type(pseudo_type_info(_))		= no.
+rtti_name_has_array_type(base_typeclass_info(_, _))	= yes.
 rtti_name_has_array_type(type_hashcons_pointer)		= no.
 
 rtti_name_is_exported(exist_locns(_))		= no.
@@ -464,6 +508,7 @@
 rtti_name_is_exported(type_ctor_info)           = yes.
 rtti_name_is_exported(pseudo_type_info(Pseudo)) =
 	pseudo_type_info_is_exported(Pseudo).
+rtti_name_is_exported(base_typeclass_info(_, _)) = yes.
 rtti_name_is_exported(type_hashcons_pointer)    = no.
 
 :- func pseudo_type_info_is_exported(pseudo_type_info) = bool.
@@ -560,6 +605,15 @@
 	;
 		RttiName = pseudo_type_info(PseudoTypeInfo),
 		rtti__pseudo_type_info_to_string(PseudoTypeInfo, Str)
+	;
+		RttiName = base_typeclass_info(ClassId, InstanceStr),
+		ClassId = class_id(ClassSym, ClassArity),
+		llds_out__sym_name_mangle(ClassSym, MangledClassString),
+		string__int_to_string(ClassArity, ArityString),
+		llds_out__name_mangle(InstanceStr, MangledTypeNames),
+		string__append_list(["base_typeclass_info_",
+			MangledClassString, "__arity", ArityString, "__",
+			MangledTypeNames], Str)
 	;
 		RttiName = type_hashcons_pointer,
 		string__append_list([ModuleName, "__hashcons_ptr_",
Index: compiler/rtti_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_out.m,v
retrieving revision 1.10
diff -u -d -r1.10 rtti_out.m
--- compiler/rtti_out.m	2000/04/25 11:32:04	1.10
+++ compiler/rtti_out.m	2000/05/10 14:12:14
@@ -72,9 +72,10 @@
 
 :- implementation.
 
+:- import_module hlds_data.
 :- import_module pseudo_type_info, code_util, llds, prog_out, c_util.
 :- import_module options, globals.
-:- import_module string, list, require, std_util.
+:- import_module int, string, list, require, std_util.
 
 %-----------------------------------------------------------------------------%
 
@@ -341,12 +342,37 @@
 %	io__write_string(",\n\t"),
 %	output_maybe_static_code_addr(Prettyprinter),
 	io__write_string("\n};\n").
+output_rtti_data_defn(base_typeclass_info(ClassId, InstanceString,
+		BaseTypeClassInfo), DeclSet0, DeclSet) -->
+	output_base_typeclass_info_defn(ClassId, InstanceString,
+		BaseTypeClassInfo, DeclSet0, DeclSet).
 output_rtti_data_defn(pseudo_type_info(Pseudo), DeclSet0, DeclSet) -->
 	output_pseudo_type_info_defn(Pseudo, DeclSet0, DeclSet).
 
+:- pred output_base_typeclass_info_defn(class_id, string, base_typeclass_info,
+		decl_set, decl_set, io__state, io__state).
+:- mode output_base_typeclass_info_defn(in, in, in, in, out, di, uo) is det.
+
+output_base_typeclass_info_defn(ClassId, InstanceString,
+		base_typeclass_info(N1, N2, N3, N4, N5, Methods),
+		DeclSet0, DeclSet) -->
+	{ CodeAddrs = list__map(make_code_addr, Methods) },
+	output_code_addrs_decls(CodeAddrs, "", "", 0, _, DeclSet0, DeclSet1),
+	io__write_string("\n"),
+	output_base_typeclass_info_decl(ClassId, InstanceString, yes,
+		DeclSet1, DeclSet),
+	io__write_string(" = {\n\t(Code *) "),
+	io__write_list([N1, N2, N3, N4, N5], ",\n\t(Code *) ", io__write_int),
+	io__write_string(",\n\t"),
+	io__write_list(CodeAddrs, ",\n\t", output_static_code_addr),
+	io__write_string("\n};\n").
+
 :- func make_maybe_code_addr(maybe(rtti_proc_label)) = maybe(code_addr).
 make_maybe_code_addr(no) = no.
-make_maybe_code_addr(yes(ProcLabel)) = yes(CodeAddr) :-
+make_maybe_code_addr(yes(ProcLabel)) = yes(make_code_addr(ProcLabel)).
+
+:- func make_code_addr(rtti_proc_label) = code_addr.
+make_code_addr(ProcLabel) = CodeAddr :-
 	code_util__make_entry_label_from_rtti(ProcLabel, no, CodeAddr).
 
 :- pred output_pseudo_type_info_defn(pseudo_type_info, decl_set, decl_set,
@@ -461,12 +487,30 @@
 		% so we don't need to declare them.
 		% Also rtti_data_to_name/3 does not handle this case.
 		{ DeclSet = DeclSet0 }
+	; { RttiData = base_typeclass_info(ClassId, InstanceStr, _) } ->
+		% rtti_data_to_name/3 does not handle this case
+		output_base_typeclass_info_decl(ClassId,
+			InstanceStr, no, DeclSet0, DeclSet),
+		io__write_string(";\n")
 	;
 		{ rtti_data_to_name(RttiData, RttiTypeId, RttiName) },
 		output_generic_rtti_data_decl(RttiTypeId, RttiName,
 			DeclSet0, DeclSet)
 	).
 
+:- pred output_base_typeclass_info_decl(class_id::in, string::in,
+		bool::in, decl_set::in, decl_set::out,
+		io__state::di, io__state::uo) is det.
+
+output_base_typeclass_info_decl(ClassId, InstanceStr,
+		BeingDefined, DeclSet0, DeclSet) -->
+	output_rtti_name_storage_type_name(
+		output_base_typeclass_info_name(ClassId, InstanceStr),
+		base_typeclass_info(ClassId, InstanceStr), BeingDefined),
+	% XXX It would be nice to avoid generating multiple declarations
+	% of base_typeclass_infos, but currently we don't.
+	{ DeclSet = DeclSet0 }.
+
 %-----------------------------------------------------------------------------%
 
 :- pred output_generic_rtti_data_decl(rtti_type_id::in, rtti_name::in,
@@ -488,6 +532,15 @@
 	{ decl_set_insert(DeclSet0, data_addr(DataAddr), DeclSet) }.
 
 output_rtti_addr_storage_type_name(RttiTypeId, RttiName, BeingDefined) -->
+	output_rtti_name_storage_type_name(
+		output_rtti_addr(RttiTypeId, RttiName),
+		RttiName, BeingDefined).
+
+:- pred output_rtti_name_storage_type_name(
+	pred(io__state, io__state)::pred(di, uo) is det,
+	rtti_name::in, bool::in, io__state::di, io__state::uo) is det.
+
+output_rtti_name_storage_type_name(OutputName, RttiName, BeingDefined) -->
 	output_rtti_type_decl(RttiName),
 	{ rtti_name_linkage(RttiName, Linkage) },
 	globals__io_get_globals(Globals),
@@ -501,7 +554,7 @@
 	{ rtti_name_c_type(RttiName, CType, Suffix) },
 	c_util__output_quoted_string(CType),
 	io__write_string(" "),
-	output_rtti_addr(RttiTypeId, RttiName),
+	OutputName,
 	io__write_string(Suffix).
 
 :- pred output_rtti_type_decl(rtti_name::in, io__state::di, io__state::uo)
@@ -568,9 +621,37 @@
 		io__write_int(Arity),
 		io__write_string("_0);\n")
 	;
+		{ Data = base_typeclass_info(ClassName, ClassArity,
+			base_typeclass_info(_N1, _N2, _N3, _N4, _N5,
+				Methods)) }
+	->
+		io__write_string("#ifndef MR_STATIC_CODE_ADDRESSES\n"),
+			% the field number for the first method is 5,
+			% since the methods are stored after N1 .. N5,
+			% and fields are numbered from 0.
+		{ FirstFieldNum = 5 },
+		{ CodeAddrs = list__map(make_code_addr, Methods) },
+		output_init_method_pointers(FirstFieldNum, CodeAddrs,
+			ClassName, ClassArity),
+		io__write_string("#endif /* MR_STATIC_CODE_ADDRESSES */\n")
+	;
 		[]
 	).
 
+:- pred output_init_method_pointers(int, list(code_addr), class_id, string,
+		io__state, io__state).
+:- mode output_init_method_pointers(in, in, in, in, di, uo) is det.
+
+output_init_method_pointers(_, [], _, _) --> [].
+output_init_method_pointers(FieldNum, [Arg|Args], ClassId, InstanceStr) -->
+	io__write_string("\t\t"),
+	io__write_string("MR_field(MR_mktag(0), "),
+	output_base_typeclass_info_name(ClassId, InstanceStr),
+	io__format(", %d) =\n\t\t\t", [i(FieldNum)]),
+	output_code_addr(Arg),
+	io__write_string(";\n"),
+	output_init_method_pointers(FieldNum + 1, Args, ClassId, InstanceStr).
+
 %-----------------------------------------------------------------------------%
 
 :- pred output_maybe_rtti_addrs_decls(rtti_type_id::in,
@@ -628,6 +709,12 @@
 		% Also rtti_data_to_name/3 does not handle this case.
 		{ DeclSet = DeclSet0 },
 		{ N = N0 }
+	; { RttiData = base_typeclass_info(ClassId, InstanceStr, _) } ->
+		% rtti_data_to_name/3 does not handle this case,
+		% so we need to handle it here
+		output_base_typeclass_info_decl(ClassId, InstanceStr,
+				no, DeclSet0, DeclSet),
+		{ N = N0 }
 	;
 		{ rtti_data_to_name(RttiData, RttiTypeId, RttiName) },
 		output_rtti_addr_decls(RttiTypeId, RttiName,
@@ -691,6 +778,9 @@
 		% rtti_data_to_name/3 does not handle this case
 		io__write_string("(MR_PseudoTypeInfo) "),
 		io__write_int(VarNum)
+	; { RttiData = base_typeclass_info(ClassId, InstanceStr, _) } ->
+		% rtti_data_to_name/3 does not handle this case
+		output_base_typeclass_info_name(ClassId, InstanceStr)
 	;
 		{ rtti_data_to_name(RttiData, RttiTypeId, RttiName) },
 		output_addr_of_rtti_addr(RttiTypeId, RttiName)
@@ -788,11 +878,16 @@
 	io__state::di, io__state::uo) is det.
 
 output_maybe_static_code_addr(yes(CodeAddr)) -->
+	output_static_code_addr(CodeAddr).
+output_maybe_static_code_addr(no) -->
+	io__write_string("NULL").
+
+:- pred output_static_code_addr(code_addr::in, io__state::di, io__state::uo)
+	is det.
+output_static_code_addr(CodeAddr) -->
 	io__write_string("MR_MAYBE_STATIC_CODE("),
 	output_code_addr(CodeAddr),
 	io__write_string(")").
-output_maybe_static_code_addr(no) -->
-	io__write_string("NULL").
 
 %-----------------------------------------------------------------------------%
 
@@ -809,6 +904,7 @@
 rtti_name_would_include_code_addr(du_stag_ordered_table(_),  no).
 rtti_name_would_include_code_addr(du_ptag_ordered_table,     no).
 rtti_name_would_include_code_addr(type_ctor_info,            yes).
+rtti_name_would_include_code_addr(base_typeclass_info(_, _), yes).
 rtti_name_would_include_code_addr(pseudo_type_info(Pseudo),
 		pseudo_type_info_would_incl_code_addr(Pseudo)).
 rtti_name_would_include_code_addr(type_hashcons_pointer,     no).
@@ -839,6 +935,7 @@
 rtti_name_c_type(du_ptag_ordered_table,    "MR_DuPtagLayout", "[]").
 rtti_name_c_type(type_ctor_info,           "struct MR_TypeCtorInfo_Struct",
 						"").
+rtti_name_c_type(base_typeclass_info(_, _), "Code *", "[]").
 rtti_name_c_type(pseudo_type_info(Pseudo), TypePrefix, TypeSuffix) :-
 	pseudo_type_info_name_c_type(Pseudo, TypePrefix, TypeSuffix).
 rtti_name_c_type(type_hashcons_pointer,    "union MR_TableNode_Union **", "").
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.3
diff -u -d -r1.3 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m	2000/04/25 13:18:49	1.3
+++ compiler/rtti_to_mlds.m	2000/05/10 12:46:32
@@ -16,11 +16,11 @@
 
 :- module rtti_to_mlds.
 :- interface.
-:- import_module rtti, mlds, prog_data.
+:- import_module hlds_module, rtti, mlds.
 :- import_module list.
 
 	% return a list of MLDS definitions for the given rtti_data list.
-:- func rtti_data_list_to_mlds(module_name, list(rtti_data)) = mlds__defns.
+:- func rtti_data_list_to_mlds(module_info, list(rtti_data)) = mlds__defns.
 
 	% return a name, consisting only of alphabetic characters,
 	% that would be suitable for the type name for the type
@@ -28,15 +28,17 @@
 :- func mlds_rtti_type_name(rtti_name) = string.
 
 :- implementation.
-:- import_module pseudo_type_info, ml_code_util, prog_util, prog_out.
+:- import_module prog_data.
+:- import_module pseudo_type_info, prog_util, prog_out.
+:- import_module ml_code_util, ml_unify_gen.
 :- import_module bool, list, std_util, string, term, require.
 
-rtti_data_list_to_mlds(ModuleName, RttiDatas) =
-	list__condense(list__map(rtti_data_to_mlds(ModuleName), RttiDatas)).
+rtti_data_list_to_mlds(ModuleInfo, RttiDatas) =
+	list__condense(list__map(rtti_data_to_mlds(ModuleInfo), RttiDatas)).
 
 	% return a list of MLDS definitions for the given rtti_data.
-:- func rtti_data_to_mlds(module_name, rtti_data) = mlds__defns.
-rtti_data_to_mlds(ModuleName, RttiData) = MLDS_Defns :-
+:- func rtti_data_to_mlds(module_info, rtti_data) = mlds__defns.
+rtti_data_to_mlds(ModuleInfo, RttiData) = MLDS_Defns :-
 	( RttiData = pseudo_type_info(type_var(_)) ->
 		% These just get represented as integers,
 		% so we don't need to define them.
@@ -46,14 +48,20 @@
 		%
 		% Generate the name
 		%
-		rtti_data_to_name(RttiData, RttiTypeId, RttiName),
-		Name = data(rtti(RttiTypeId, RttiName)),
+		( RttiData = base_typeclass_info(ClassId, InstanceStr, _) ->
+			RttiName = base_typeclass_info(ClassId, InstanceStr),
+			Name = data(base_typeclass_info(ClassId, InstanceStr))
+		;
+			rtti_data_to_name(RttiData, RttiTypeId, RttiName),
+			Name = data(rtti(RttiTypeId, RttiName))
+		),
 
 		%
 		% Generate the context
 		%
 		% XXX the rtti_data ought to include a prog_context
-		% (the context of the corresponding type definition).
+		% (the context of the corresponding type or instance
+		% definition)
 		term__context_init(Context),
 		MLDS_Context = mlds__make_context(Context),
 
@@ -68,14 +76,16 @@
 		% i.e. the type and the initializer
 		%
 		MLDS_Type = rtti_type(RttiName),
-		Initializer = gen_init_rtti_data_defn(RttiData, ModuleName),
+		module_info_name(ModuleInfo, ModuleName),
+		gen_init_rtti_data_defn(RttiData, ModuleName, ModuleInfo,
+			Initializer, ExtraDefns),
 		DefnBody = mlds__data(MLDS_Type, Initializer),
 
 		%
 		% put it all together
 		%
 		MLDS_Defn = mlds__defn(Name, MLDS_Context, Flags, DefnBody),
-		MLDS_Defns = [MLDS_Defn]
+		MLDS_Defns = [MLDS_Defn | ExtraDefns]
 	).
 
 
@@ -100,41 +110,46 @@
 
 	% Return an MLDS initializer for the given RTTI definition
 	% occurring in the given module.
-:- func gen_init_rtti_data_defn(rtti_data, module_name) = mlds__initializer.
+:- pred gen_init_rtti_data_defn(rtti_data, module_name, module_info,
+		mlds__initializer, list(mlds__defn)).
+:- mode gen_init_rtti_data_defn(in, in, in, out, out) is det.
 
-gen_init_rtti_data_defn(exist_locns(_RttiTypeId, _Ordinal, Locns), _) =
-	gen_init_array(gen_init_exist_locn, Locns).
+gen_init_rtti_data_defn(exist_locns(_RttiTypeId, _Ordinal, Locns), _, _,
+		Init, []) :-
+	Init = gen_init_array(gen_init_exist_locn, Locns).
 gen_init_rtti_data_defn(exist_info(RttiTypeId, _Ordinal, Plain, InTci, Tci,
-		Locns), ModuleName) =
-	init_struct([
+		Locns), ModuleName, _, Init, []) :-
+	Init = init_struct([
 		gen_init_int(Plain),
 		gen_init_int(InTci),
 		gen_init_int(Tci),
 		gen_init_rtti_name(ModuleName, RttiTypeId, Locns)
 	]).
-gen_init_rtti_data_defn(field_names(_RttiTypeId, _Ordinal, MaybeNames), _) =
-	gen_init_array(gen_init_maybe(gen_init_string), MaybeNames).
+gen_init_rtti_data_defn(field_names(_RttiTypeId, _Ordinal, MaybeNames), _, _,
+		Init, []) :-
+	Init = gen_init_array(gen_init_maybe(gen_init_string), MaybeNames).
 gen_init_rtti_data_defn(field_types(_RttiTypeId, _Ordinal, Types),
-		ModuleName) =
-	gen_init_array(gen_init_cast_rtti_data(mlds__pseudo_type_info_type,
+		ModuleName, _, Init, []) :-
+	Init = gen_init_array(
+		gen_init_cast_rtti_data(mlds__pseudo_type_info_type,
 		ModuleName), Types).
 gen_init_rtti_data_defn(enum_functor_desc(_RttiTypeId, FunctorName, Ordinal),
-		_ModuleName) =
-	init_struct([
+		_, _, Init, []) :-
+	Init = init_struct([
 		gen_init_string(FunctorName),
 		gen_init_int(Ordinal)
 	]).
 gen_init_rtti_data_defn(notag_functor_desc(_RttiTypeId, FunctorName, ArgType),
-		ModuleName) =
-	init_struct([
+		ModuleName, _, Init, []) :-
+	Init = init_struct([
 		gen_init_string(FunctorName),
 		gen_init_cast_rtti_data(mlds__pseudo_type_info_type,
 			ModuleName, ArgType)
 	]).
 gen_init_rtti_data_defn(du_functor_desc(RttiTypeId, FunctorName, Ptag, Stag,
 		Locn, Ordinal, Arity, ContainsVarBitVector, ArgTypes,
-		MaybeNames, MaybeExist), ModuleName) =
-	init_struct([
+		MaybeNames, MaybeExist), ModuleName, _, Init, []) :-
+	Init = init_struct([
 		gen_init_string(FunctorName),
 		gen_init_int(Arity),
 		gen_init_int(ContainsVarBitVector),
@@ -149,28 +164,28 @@
 			MaybeExist)
 	]).
 gen_init_rtti_data_defn(enum_name_ordered_table(RttiTypeId, Functors),
-		ModuleName) =
-	gen_init_rtti_names_array(ModuleName, RttiTypeId, Functors).
+		ModuleName, _, Init, []) :-
+	Init = gen_init_rtti_names_array(ModuleName, RttiTypeId, Functors).
 gen_init_rtti_data_defn(enum_value_ordered_table(RttiTypeId, Functors),
-		ModuleName) =
-	gen_init_rtti_names_array(ModuleName, RttiTypeId, Functors).
+		ModuleName, _, Init, []) :-
+	Init = gen_init_rtti_names_array(ModuleName, RttiTypeId, Functors).
 gen_init_rtti_data_defn(du_name_ordered_table(RttiTypeId, Functors),
-		ModuleName) =
-	gen_init_rtti_names_array(ModuleName, RttiTypeId, Functors).
+		ModuleName, _, Init, []) :-
+	Init = gen_init_rtti_names_array(ModuleName, RttiTypeId, Functors).
 gen_init_rtti_data_defn(du_stag_ordered_table(RttiTypeId, _Ptag, Sharers),
-		ModuleName) =
-	gen_init_rtti_names_array(ModuleName, RttiTypeId, Sharers).
+		ModuleName, _, Init, []) :-
+	Init = gen_init_rtti_names_array(ModuleName, RttiTypeId, Sharers).
 gen_init_rtti_data_defn(du_ptag_ordered_table(RttiTypeId, PtagLayouts),
-		ModuleName) =
-	gen_init_array(gen_init_ptag_layout_defn(ModuleName, RttiTypeId),
+		ModuleName, _, Init, []) :-
+	Init = gen_init_array(gen_init_ptag_layout_defn(ModuleName, RttiTypeId),
 		PtagLayouts).
 gen_init_rtti_data_defn(type_ctor_info(RttiTypeId, UnifyProc, CompareProc,
 		CtorRep, SolverProc, InitProc, Version, NumPtags, NumFunctors,
 		FunctorsInfo, LayoutInfo, _MaybeHashCons,
-		_PrettyprinterProc), ModuleName) = Initializer :-
+		_PrettyprinterProc), ModuleName, _, Init, []) :-
 	RttiTypeId = rtti_type_id(TypeModule, Type, TypeArity),
 	prog_out__sym_name_to_string(TypeModule, TypeModuleName),
-	Initializer = init_struct([
+	Init = init_struct([
 		gen_init_int(TypeArity),
 		gen_init_maybe_proc_id(UnifyProc),
 		gen_init_maybe_proc_id(UnifyProc),
@@ -185,7 +200,8 @@
 		% We need to use `init_struct' here so that the initializers
 		% get enclosed in curly braces.
 		init_struct([
-			gen_init_functors_info(FunctorsInfo, ModuleName, RttiTypeId)
+			gen_init_functors_info(FunctorsInfo, ModuleName,
+				RttiTypeId)
 		]),
 		init_struct([
 			gen_init_layout_info(LayoutInfo, ModuleName, RttiTypeId)
@@ -199,8 +215,24 @@
 		%	MaybeHashCons),
 		% gen_init_maybe_proc_id(PrettyprinterProc)
 	]).
-gen_init_rtti_data_defn(pseudo_type_info(Pseudo), ModuleName) =
-	gen_init_pseudo_type_info_defn(Pseudo, ModuleName).
+gen_init_rtti_data_defn(base_typeclass_info(_ClassId, _InstanceStr,
+		BaseTypeClassInfo), _ModuleName, ModuleInfo,
+		Init, ExtraDefns) :-
+	BaseTypeClassInfo = base_typeclass_info(N1, N2, N3, N4, N5,
+		Methods),
+	NumExtra = BaseTypeClassInfo^num_extra,
+	list__map_foldl(gen_init_method(ModuleInfo, NumExtra),
+		Methods, MethodInitializers, [], ExtraDefns),
+	Init = init_array([
+		gen_init_boxed_int(N1),
+		gen_init_boxed_int(N2),
+		gen_init_boxed_int(N3),
+		gen_init_boxed_int(N4),
+		gen_init_boxed_int(N5)
+		| MethodInitializers
+	]).
+gen_init_rtti_data_defn(pseudo_type_info(Pseudo), ModuleName, _, Init, []) :-
+	Init = gen_init_pseudo_type_info_defn(Pseudo, ModuleName).
 
 :- func gen_init_functors_info(type_ctor_functors_info, module_name,
 		rtti_type_id) = mlds__initializer.
@@ -306,6 +338,16 @@
 		SrcType = mlds__native_int_type,
 		Initializer = init_obj(unop(gen_cast(SrcType, DestType),
 			const(int_const(VarNum))))
+	; RttiData = base_typeclass_info(ClassId, InstanceString, _) ->
+		% rtti_data_to_name/3 does not handle this case
+		SrcType = rtti_type(base_typeclass_info(ClassId,
+			InstanceString)),
+		MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+		MLDS_DataName = base_typeclass_info(ClassId, InstanceString),
+		DataAddr = data_addr(MLDS_ModuleName, MLDS_DataName),
+		Rval = const(data_addr_const(DataAddr)),
+		Initializer = init_obj(unop(gen_cast(SrcType, DestType),
+			Rval))
 	;
 		rtti_data_to_name(RttiData, RttiTypeId, RttiName),
 		Initializer = gen_init_cast_rtti_name(DestType,
@@ -338,8 +380,9 @@
 	rtti_name) = mlds__initializer.
 
 gen_init_cast_rtti_name(DestType, ModuleName, RttiTypeId, RttiName) =
-	% SrcType = rtti_type(RttiName), 
-	init_obj(unop(cast(DestType),
+		Initializer :-
+	SrcType = rtti_type(RttiName), 
+	Initializer = init_obj(unop(gen_cast(SrcType, DestType),
 		gen_rtti_name(ModuleName, RttiTypeId, RttiName))).
 
 	% Generate the MLDS rval for an rtti_name.
@@ -363,10 +406,10 @@
 		RttiTypeId0 = rtti_type_id(RttiModuleName,
 			RttiTypeName, RttiTypeArity),
 		%
-		% Although the builtin types `int', `float', etc. are treated as part
-		% of the `builtin' module, for historical reasons they don't have
-		% any qualifiers at this point, so we need to add the `builtin'
-		% qualifier now.
+		% Although the builtin types `int', `float', etc. are treated
+		% as part of the `builtin' module, for historical reasons they
+		% don't have any qualifiers at this point, so we need to add
+		% the `builtin' qualifier now.
 		%
 		( RttiModuleName = unqualified("") ->
 			mercury_public_builtin_module(ModuleName),
@@ -397,6 +440,59 @@
 
 %-----------------------------------------------------------------------------%
 
+:- pred gen_init_method(module_info, int, rtti_proc_label, mlds__initializer,
+		list(mlds__defn), list(mlds__defn)).
+:- mode gen_init_method(in, in, in, out, in, out) is det.
+
+gen_init_method(ModuleInfo, NumExtra, RttiProcId, Init,
+		ExtraDefns0, ExtraDefns) :-
+	%
+	% we can't store the address of the typeclass method directly in
+	% the base_typeclass_info; instead, we need to generate
+	% a wrapper function that extracts the NumExtra parameters
+	% it needs from the typeclass_info, and store the address
+	% of that wrapper function in the typeclass_info.
+	%
+	% Note that this means there are two levels of wrappers:
+	% the wrapper that we generate here calls the
+	% procedure introduced by check_typeclass.m,
+	% and that in turn calls the user's procedure.
+	% Hopefully the Mercury HLDS->HLDS inlining and/or
+	% the target code compiler will be able to optimize this...
+	%
+
+	%
+	% We start off by creating a fresh MLGenInfo here,
+	% using the pred_id and proc_id of the wrapped procedure.
+	% This requires considerable care.  We need to call
+	% ml_gen_info_bump_func_label to ensure that the
+	% function label allocated for the wrapper func
+	% does not overlap with any function labels used
+	% when generating code for the wrapped procedure.
+	%
+	PredId = RttiProcId^pred_id,
+	ProcId = RttiProcId^proc_id,
+	MLGenInfo0 = ml_gen_info_init(ModuleInfo, PredId, ProcId),
+	ml_gen_info_bump_func_label(MLGenInfo0, MLGenInfo1),
+
+	%
+	% Now we can safely go ahead and generate the wrapper function
+	%
+	Offset = ml_typeclass_info_arg_offset,
+	term__context_init(Context),
+	ml_gen_closure_wrapper(PredId, ProcId, Offset, NumExtra,
+		Context, WrapperFuncRval, WrapperFuncType,
+		MLGenInfo1, MLGenInfo),
+	ml_gen_info_get_extra_defns(MLGenInfo, ExtraDefns1),
+	ExtraDefns = list__append(ExtraDefns1, ExtraDefns0),
+	
+	%
+	% The initializer for the method field of the base_typeclass_info
+	% is just the wrapper function's address, converted to
+	% mlds__generic_type (by boxing).
+	%
+	Init = init_obj(unop(box(WrapperFuncType), WrapperFuncRval)).
+
 :- func gen_init_proc_id(rtti_proc_label) = mlds__initializer.
 gen_init_proc_id(RttiProcId) = Init :-
 	%
@@ -474,6 +570,11 @@
 
 gen_init_int(Int) = init_obj(const(int_const(Int))).
 
+:- func gen_init_boxed_int(int) = mlds__initializer.
+
+gen_init_boxed_int(Int) =
+	init_obj(unop(box(mlds__native_int_type), const(int_const(Int)))).
+
 %-----------------------------------------------------------------------------%
 
 mlds_rtti_type_name(exist_locns(_)) =		"DuExistLocnArray".
@@ -489,6 +590,7 @@
 mlds_rtti_type_name(du_stag_ordered_table(_)) =	"DuFunctorDescPtrArray".
 mlds_rtti_type_name(du_ptag_ordered_table) =	"DuPtagLayoutArray".
 mlds_rtti_type_name(type_ctor_info) =		"TypeCtorInfo_Struct".
+mlds_rtti_type_name(base_typeclass_info(_, _)) = "BaseTypeclassInfo".
 mlds_rtti_type_name(pseudo_type_info(Pseudo)) =
 	mlds_pseudo_type_info_type_name(Pseudo).
 mlds_rtti_type_name(type_hashcons_pointer) =	"TableNodePtrPtr".
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.45
diff -u -d -r1.45 compiler_design.html
--- compiler/notes/compiler_design.html	2000/03/10 13:38:06	1.45
+++ compiler/notes/compiler_design.html	2000/05/10 13:18:39
@@ -729,6 +729,11 @@
      and `export__get_pragma_exported_procs' to produce C code fragments
      which declare/define the C functions which are the interface stubs
      for procedures exported to C.
+
+<dt> generation of constants for RTTI data structures
+<dd> This could also be considered a part of code generation,
+     but for the LLDS back-end this is currently done as part
+     of the output phase (see below).
 </dl>
 
 <p>
@@ -852,11 +857,12 @@
   associated with each declared type constructor that go into the static
   type_ctor_info data structure. If the type_ctor_gen_info structure is not
   eliminated as inaccessible, this module adds the corresponding type_ctor_info
-  structure to the LLDS.
+  structure to the RTTI data structures defined in rtti.m,
+  which are part of the LLDS.
 
 <li> base_typeclass_info.m generates the base_typeclass_info structures that 
   list the methods of a class for each instance declaration. These are added to
-  the LLDS.
+  the RTTI data structures, which are part of the LLDS.
 
 <li> stack_layout.m generates the stack_layout structures for
   accurate garbage collection. Tables are created from the data
@@ -895,12 +901,15 @@
 <h4> 4b. MLDS code generation </h4>
 <ul>
 <li> ml_code_gen.m converts HLDS code to MLDS.
-<li> ml_base_type_info.m generates MLDS declarations for the
-     base_type_info structures used for polymorphism.
+<li> type_ctor_info.m and base_typeclass_info.m generate
+     the RTTI data structures defined in rtti.m and pseudo_type_info.m
+     (those four modules are shared with the LLDS back-end)
+     and then mlds_to_rtti.m converts these to MLDS.
 </ul>
 
 <h4> 5b. MLDS transformations </h4>
 <ul>
+<li> ml_tailcall.m annotates the MLDS with information about tailcalls.
 <li> ml_elim_nested.m transforms the MLDS to eliminate nested functions.
 </ul>
 
Index: compiler/notes/type_class_transformation.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/type_class_transformation.html,v
retrieving revision 1.1
diff -u -d -r1.1 type_class_transformation.html
--- compiler/notes/type_class_transformation.html	2000/04/10 07:20:25	1.1
+++ compiler/notes/type_class_transformation.html	2000/05/10 04:52:49
@@ -39,8 +39,7 @@
 	  <LI> the sum of the number of constraints on the instance decl. 
 	  and the number of unconstrained type variables 
 	  from the head of the instance decl. (`n1')
-	  <LI> the number of unconstrained type variables 
-	  from the head of the instance decl. (`n2')
+	  <LI> the number of constraints on the instance decl. (`n2')
 	  <LI> the number of constraints on the typeclass decl. (`n3')
 	  <LI> the number of parameters (type variables) from 
 	         the typeclass decl. (`n4')

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh>  |  of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3        |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------



More information about the developers mailing list