[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