[m-rev.] diff: IL back-end & --high-level-data: generator constructors
Fergus Henderson
fjh at cs.mu.OZ.AU
Wed Aug 15 04:40:25 AEST 2001
With this change, I was able to get a version of N-queens
running with --il --high-level-data.
Estimated hours taken: 5
Branches: main
compiler/ml_type_gen.m:
Generate constructor functions for all the types generated.
compiler/mlds_to_il.m:
- Use the right argument types when referring to the constructor,
rather than inconsistently assuming that constructors are always
nullary but passing arguments to them anyway.
- Don't pass the secondary tag to the constructor, since the
constructor will know what secondary tag to use.
- Fix a couple of bugs in my previous change where I had
put the "castclass" instructions in the wrong place.
- Change fixup_class_qualifier to make it a little more robust.
Don't assume that the pointer in a field instruction
will always point to the base class; allow it to point
to the derived class.
Workspace: /mnt/venus/home/venus/fjh/ws-venus4/mercury
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.74
diff -u -d -r1.74 mlds_to_il.m
--- compiler/mlds_to_il.m 2001/08/14 18:03:15 1.74
+++ compiler/mlds_to_il.m 2001/08/14 18:03:41
@@ -1438,7 +1438,7 @@
% throw
%
- { NewObjInstr = newobj_constructor(il_commit_class_name) },
+ { NewObjInstr = newobj_constructor(il_commit_class_name, []) },
{ Instrs = tree__list([
context_node(Context),
comment_node("do_commit/1"),
@@ -1652,7 +1652,7 @@
{ Instrs = tree__list([LoadInstrs, instr_node(ldnull), StoreInstrs]) }.
atomic_statement_to_il(new_object(Target, _MaybeTag, Type, Size, MaybeCtorName,
- Args, ArgTypes), Instrs) -->
+ Args0, ArgTypes), Instrs) -->
DataRep =^ il_data_rep,
(
{
@@ -1686,11 +1686,30 @@
;
{ ClassName = ClassName0 }
),
+ { Type = mlds__generic_env_ptr_type ->
+ ILArgTypes = [],
+ Args = Args0
+ ;
+ % It must be a user-defined type.
+ % Skip the secondary tag.
+ % We assume there is always a secondary tag,
+ % since ml_type_gen always generates one
+ % if we have --tags none, which the IL back-end
+ % requires.
+ ArgTypes = [_SecondaryTag | ArgTypes1],
+ Args0 = [_SecondaryTagVal | Args1]
+ ->
+ Args = Args1,
+ ILArgTypes = list__map(mlds_type_to_ilds_type(DataRep),
+ ArgTypes1)
+ ;
+ sorry(this_file, "newobj without secondary tag")
+ },
list__map_foldl(load, Args, ArgsLoadInstrsTrees),
{ ArgsLoadInstrs = tree__list(ArgsLoadInstrsTrees) },
get_load_store_lval_instrs(Target, LoadMemRefInstrs,
StoreLvalInstrs),
- { CallCtor = newobj_constructor(ClassName) },
+ { CallCtor = newobj_constructor(ClassName, ILArgTypes) },
{ Instrs = tree__list([
LoadMemRefInstrs,
comment_node("new object (call constructor)"),
@@ -1726,7 +1745,7 @@
{ Box = (pred(A - T::in, B::out) is det :-
B = unop(box(T), A)
) },
- { assoc_list__from_corresponding_lists(Args, ArgTypes,
+ { assoc_list__from_corresponding_lists(Args0, ArgTypes,
ArgsAndTypes) },
{ list__map(Box, ArgsAndTypes, BoxedArgs) },
@@ -1772,7 +1791,7 @@
ArgsLoadInstrs,
StoreLvalInstrs
]) }
- ).
+ ).
:- func inline_code_to_il_asm(list(target_code_component)) = instr_tree.
inline_code_to_il_asm([]) = empty.
@@ -3266,11 +3285,13 @@
% and which are namespace qualifiers... we first generate
% a name for the CtorClass as if it wasn't nested, and then
% we call fixup_class_qualifiers to make it correct.
+ % XXX This is a bit of a hack. It would be nicer for the
+ % MLDS to keep the information around.
CtorClassName = mlds_module_name_to_class_name(ModuleName),
- BaseClassName = mlds_type_to_ilds_class_name(DataRep, ClassType),
- ClassName = fixup_class_qualifiers(CtorClassName, BaseClassName),
+ PtrClassName = mlds_type_to_ilds_class_name(DataRep, ClassType),
+ ClassName = fixup_class_qualifiers(CtorClassName, PtrClassName),
(
- BaseClassName = CtorClassName
+ PtrClassName = CtorClassName
->
CastClassInstrs = empty
;
@@ -3280,29 +3301,51 @@
),
FieldRef = make_fieldref(FieldILType, ClassName, FieldId).
- % The CtorClass will be nested inside the BaseClass.
+ % The CtorClass will be nested inside the base class.
% But when we initially generate the name, we don't
% know that it is nested. This routine fixes up the
% CtorClassName by moving the nested parts into the
% third field of the structured_name.
:- func fixup_class_qualifiers(ilds__class_name, ilds__class_name) =
ilds__class_name.
-fixup_class_qualifiers(CtorClassName0, BaseClassName) = CtorClassName :-
- BaseClassName = structured_name(BaseAssembly, BaseClass, BaseNested),
+fixup_class_qualifiers(CtorClassName0, PtrClassName) = CtorClassName :-
+ PtrClassName = structured_name(PtrAssembly, PtrClass, PtrNested),
CtorClassName0 = structured_name(CtorAssembly, CtorClass, CtorNested),
(
- list__append(BaseClass, NestedClasses, CtorClass),
% some sanity checks
- BaseAssembly = CtorAssembly,
- BaseNested = [],
+ PtrAssembly = CtorAssembly,
+ PtrNested = [],
CtorNested = []
->
- CtorClassName = structured_name(CtorAssembly, BaseClass,
+ % The part of the prefix which CtorClass shares with PtrClass
+ % will be the outermost class name; the remainder of CtorClass,
+ % if any, will be a nested class within.
+ % (XXX This relies on the way that ml_type_gen.m generates
+ % the nested MLDS classes for discriminated unions.)
+ common_prefix(CtorClass, PtrClass, OuterClass, NestedClasses, _),
+ CtorClassName = structured_name(CtorAssembly, OuterClass,
NestedClasses)
;
unexpected(this_file, "fixup_class_qualifiers")
).
+ % common_prefix(List1, List2, Prefix, Tail1, Tail2):
+ % List1 = Prefix ++ Tail1,
+ % List2 = Prefix ++ Tail2.
+:- pred common_prefix(list(T), list(T), list(T), list(T), list(T)).
+:- mode common_prefix(in, in, out, out, out) is det.
+common_prefix([], Ys, [], [], Ys).
+common_prefix([X|Xs], [], [], [X|Xs], []).
+common_prefix([X|Xs], [Y|Ys], Prefix, TailXs, TailYs) :-
+ (if X = Y then
+ common_prefix(Xs, Ys, Prefix1, TailXs, TailYs),
+ Prefix = [X|Prefix1]
+ else
+ TailXs = [X|Xs],
+ TailYs = [Y|Ys],
+ Prefix = []
+ ).
+
%-----------------------------------------------------------------------------%
:- pred defn_to_local(mlds_module_name, mlds__defn,
@@ -3669,7 +3712,7 @@
:- func call_constructor(ilds__class_name) = instr.
call_constructor(CtorMemberName) =
- call(get_constructor_methoddef(CtorMemberName)).
+ call(get_constructor_methoddef(CtorMemberName, [])).
:- func throw_unimplemented(string) = instr_tree.
throw_unimplemented(String) =
@@ -3680,13 +3723,13 @@
throw]
).
-:- func newobj_constructor(ilds__class_name) = instr.
-newobj_constructor(CtorMemberName) =
- newobj(get_constructor_methoddef(CtorMemberName)).
+:- func newobj_constructor(ilds__class_name, list(ilds__type)) = instr.
+newobj_constructor(CtorMemberName, ArgTypes) =
+ newobj(get_constructor_methoddef(CtorMemberName, ArgTypes)).
-:- func get_constructor_methoddef(ilds__class_name) = methodref.
-get_constructor_methoddef(CtorMemberName) =
- get_instance_methodref(CtorMemberName, ctor, void, []).
+:- func get_constructor_methoddef(ilds__class_name, list(ilds__type)) = methodref.
+get_constructor_methoddef(CtorMemberName, ArgTypes) =
+ get_instance_methodref(CtorMemberName, ctor, void, ArgTypes).
:- func get_instance_methodref(ilds__class_name, member_name, ret_type,
list(ilds__type)) = methodref.
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.11
diff -u -d -r1.11 ml_type_gen.m
--- compiler/ml_type_gen.m 2001/08/12 23:01:16 1.11
+++ compiler/ml_type_gen.m 2001/08/14 18:20:45
@@ -66,7 +66,7 @@
:- implementation.
:- import_module hlds_pred, prog_data, prog_util, type_util, polymorphism.
-:- import_module ml_code_util.
+:- import_module ml_code_util, error_util.
:- import_module globals, options.
:- import_module bool, int, string, list, map, std_util, term, require.
@@ -207,6 +207,8 @@
%
% Discriminated union types.
%
+% XXX we ought to optimize the case where there is only one alternative.
+%
%
% For each discriminated union type, we generate an MLDS type of the
@@ -256,6 +258,14 @@
% MR_Word F1;
% MR_Word F2;
% ...
+ % /*
+ % ** A constructor to initialize the fields
+ % */
+ % <ctor1>(MR_Word F1, MR_Word F2, ...) {
+ % this->F1 = F1;
+ % this->F2 = F2;
+ % ...
+ % }
% };
% static class <ctor2> : public <ClassName>::tag_type {
% public:
@@ -331,8 +341,9 @@
),
% generate the nested derived classes for the constructors
- list__foldl(ml_gen_du_ctor_type(ModuleInfo, BaseClassId, TagClassId,
- TypeDefn, TagValues), Ctors, [], CtorMembers),
+ list__foldl(ml_gen_du_ctor_type(ModuleInfo, BaseClassId,
+ BaseClassQualifier, TagClassId, TypeDefn, TagValues),
+ Ctors, [], CtorMembers),
% the base class doesn't import or inherit anything
Imports = [],
@@ -439,13 +450,13 @@
% Generate a definition for the class corresponding to
% a constructor of a discriminated union type.
%
-:- pred ml_gen_du_ctor_type(module_info, mlds__class_id, mlds__class_id,
- hlds_type_defn, cons_tag_values, constructor,
+:- pred ml_gen_du_ctor_type(module_info, mlds__class_id, mlds_module_name,
+ mlds__class_id, hlds_type_defn, cons_tag_values, constructor,
mlds__defns, mlds__defns).
-:- mode ml_gen_du_ctor_type(in, in, in, in, in, in, in, out) is det.
+:- mode ml_gen_du_ctor_type(in, in, in, in, in, in, in, in, out) is det.
-ml_gen_du_ctor_type(ModuleInfo, BaseClassId, SecondaryTagClassId,
- TypeDefn, ConsTagValues, Ctor,
+ml_gen_du_ctor_type(ModuleInfo, BaseClassId, BaseClassQualifier,
+ SecondaryTagClassId, TypeDefn, ConsTagValues, Ctor,
MLDS_Defns0, MLDS_Defns) :-
Ctor = ctor(ExistQTVars, Constraints, CtorName, Args),
@@ -492,16 +503,28 @@
% we inherit either the base class for this type,
% or the secondary tag class, depending on whether
% we need a secondary tag
- ( ml_uses_secondary_tag(ConsTagValues, Ctor, _) ->
- ParentClassId = SecondaryTagClassId
+ ( ml_uses_secondary_tag(ConsTagValues, Ctor, TagVal) ->
+ ParentClassId = SecondaryTagClassId,
+ MaybeTagVal = yes(TagVal)
;
- ParentClassId = BaseClassId
+ ParentClassId = BaseClassId,
+ MaybeTagVal = no
),
Imports = [],
Inherits = [ParentClassId],
Implements = [],
- Ctors = [],
+ % generate a constructor function to initialize the fields
+ %
+ CtorClassType = mlds__class_type(qual(BaseClassQualifier, CtorClassName),
+ CtorArity, mlds__class),
+ CtorClassQualifier = mlds__append_class_qualifier(
+ BaseClassQualifier, CtorClassName, CtorArity),
+ CtorFunction = gen_constructor_function(BaseClassId, CtorClassType,
+ CtorClassQualifier, SecondaryTagClassId, MaybeTagVal, Members,
+ MLDS_Context),
+ Ctors = [CtorFunction],
+
% put it all together
MLDS_TypeName = type(CtorClassName, CtorArity),
MLDS_TypeFlags = ml_gen_type_decl_flags,
@@ -512,6 +535,97 @@
MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
+:- func gen_constructor_function(mlds__class_id, mlds__type, mlds_module_name,
+ mlds__class_id, maybe(int), mlds__defns, mlds__context) =
+ mlds__defn.
+gen_constructor_function(BaseClassId, ClassType, ClassQualifier,
+ SecondaryTagClassId, MaybeTag, Members, Context) = CtorDefn :-
+ Args = list__map(make_arg, Members),
+ ReturnValues = [],
+
+ InitMembers0 = list__map(gen_init_field(BaseClassId,
+ ClassType, ClassQualifier), Members),
+ (
+ MaybeTag = yes(TagVal)
+ ->
+ InitTag = gen_init_tag(ClassType, SecondaryTagClassId, TagVal,
+ Context),
+ InitMembers = [InitTag | InitMembers0]
+ ;
+ InitMembers = InitMembers0
+ ),
+
+ Stmt = mlds__statement(block([], InitMembers), Context),
+
+ Ctor = mlds__function(no, func_params(Args, ReturnValues),
+ defined_here(Stmt)),
+ CtorFlags = init_decl_flags(public, per_instance, non_virtual,
+ overridable, modifiable, concrete),
+
+ % Note that the name of constructor is
+ % determined by the backend convention.
+ CtorDefn = mlds__defn(export("<constructor>"), Context, CtorFlags, Ctor).
+
+ % Get the name and type from the field definition,
+ % for use as a constructor argument name and type.
+:- func make_arg(mlds__defn) = pair(mlds__entity_name, mlds__type) is det.
+make_arg(mlds__defn(Name, _Context, _Flags, Defn)) = Name - Type :-
+ ( Defn = data(Type0, _Init) ->
+ Type = Type0
+ ;
+ unexpected(this_file, "make_arg: non-data member")
+ ).
+
+ % Generate "this-><fieldname> = <fieldname>;".
+:- func gen_init_field(mlds__class_id, mlds__type, mlds_module_name, mlds__defn)
+ = mlds__statement is det.
+gen_init_field(BaseClassId, ClassType, ClassQualifier, Member) = Statement :-
+ Member = mlds__defn(EntityName, Context, _Flags, Defn),
+ ( Defn = data(Type0, _Init) ->
+ Type = Type0
+ ;
+ unexpected(this_file, "gen_init_field: non-data member")
+ ),
+ (
+ EntityName = data(var(VarName0)),
+ VarName0 = mlds__var_name(Name0, no)
+ ->
+ Name = Name0,
+ VarName = VarName0
+ ;
+ unexpected(this_file, "gen_init_field: non-var member")
+ ),
+ Param = mlds__lval(mlds__var(qual(ClassQualifier, VarName), Type)),
+ Field = mlds__field(yes(0), self(ClassType),
+ named_field(qual(ClassQualifier, Name),
+ mlds__ptr_type(ClassType)),
+ % XXX we should use ClassType rather than
+ % BaseClassId here. But doing so breaks the
+ % IL back-end, because then the hack in
+ % fixup_class_qualifiers doesn't work.
+ Type, BaseClassId),
+ Statement = mlds__statement(atomic(assign(Field, Param)), Context).
+
+ % Generate "this->data_tag = <TagVal>;".
+:- func gen_init_tag(mlds__type, mlds__class_id, int, mlds__context) =
+ mlds__statement is det.
+gen_init_tag(ClassType, SecondaryTagClassId, TagVal, Context) = Statement :-
+ ( SecondaryTagClassId = mlds__class_type(TagClass, TagArity, _) ->
+ TagClass = qual(BaseClassQualifier, TagClassName),
+ TagClassQualifier = mlds__append_class_qualifier(
+ BaseClassQualifier, TagClassName, TagArity)
+ ;
+ unexpected(this_file, "gen_init_tag: class_id should be a class")
+ ),
+ Name = "data_tag",
+ Type = mlds__native_int_type,
+ Val = const(int_const(TagVal)),
+ Field = mlds__field(yes(0), self(ClassType),
+ named_field(qual(TagClassQualifier, Name),
+ mlds__ptr_type(SecondaryTagClassId)),
+ Type, ClassType),
+ Statement = mlds__statement(atomic(assign(Field, Val)), Context).
+
:- pred ml_gen_typeclass_info_member(module_info, prog_context,
class_constraint, mlds__defn, int, int).
:- mode ml_gen_typeclass_info_member(in, in, in, out, in, out) is det.
@@ -519,8 +633,7 @@
ml_gen_typeclass_info_member(ModuleInfo, Context, Constraint, MLDS_Defn,
ArgNum0, ArgNum) :-
polymorphism__build_typeclass_info_type(Constraint, Type),
- ml_gen_field(ModuleInfo, Context, no, Type, MLDS_Defn,
- ArgNum0, ArgNum).
+ ml_gen_field(ModuleInfo, Context, no, Type, MLDS_Defn, ArgNum0, ArgNum).
:- pred ml_gen_type_info_member(module_info, prog_context, tvar, mlds__defn,
int, int).
@@ -635,5 +748,13 @@
Abstractness = concrete,
MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
Virtuality, Finality, Constness, Abstractness).
+
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "ml_type_gen.m".
+
+:- end_module ml_type_gen.
%-----------------------------------------------------------------------------%
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
The University of Melbourne | of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh> | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list