[m-rev.] high level data: optimize single-functor case
Fergus Henderson
fjh at cs.mu.OZ.AU
Sun Nov 4 23:13:50 AEDT 2001
Branches: main
Estimated hours taken: 8
Another optimization of the high-level data representation for the .NET
and Java back-ends: optimize the single-functor case.
compiler/ml_type_gen.m:
When there is only a single functor (perhaps with some constants
represented as reserved addresses), generate a single class, rather
than generating a base class and a derived class.
compiler/ml_unify_gen.m:
Pass down the cons_tag to ml_gen_field_id, so that it can check
for the single_functor case and in that case generate references
to the base class rather than to the (non-existant) derived class.
compiler/hlds_data.m:
Add get_primary_tag, for use by ml_unify_gen.m.
Workspace: /home/earth/fjh/ws-earth3/mercury
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.60
diff -u -d -r1.60 hlds_data.m
--- compiler/hlds_data.m 31 Oct 2001 16:58:08 -0000 1.60
+++ compiler/hlds_data.m 4 Nov 2001 08:31:37 -0000
@@ -444,10 +444,38 @@
:- type no_tag_type_table == map(type_id, no_tag_type).
+ % Return the primary tag, if any, for a cons_tag.
+ % A return value of `no' means the primary tag is unknown.
+ % A return value of `yes(0)' means the primary tag is always zero.
+:- func get_primary_tag(cons_tag) = maybe(int).
+
% Return the secondary tag, if any, for a cons_tag.
+ % A return value of `no' means there is no secondary tag.
:- func get_secondary_tag(cons_tag) = maybe(int).
:- implementation.
+
+% In some of the cases where we return `no' here,
+% it would probably be OK to return `yes(0)'.
+% But it's safe to be conservative...
+get_primary_tag(string_constant(_)) = no.
+get_primary_tag(float_constant(_)) = no.
+get_primary_tag(int_constant(_)) = no.
+get_primary_tag(pred_closure_tag(_, _, _)) = no.
+get_primary_tag(code_addr_constant(_, _)) = no.
+get_primary_tag(type_ctor_info_constant(_, _, _)) = no.
+get_primary_tag(base_typeclass_info_constant(_, _, _)) = no.
+get_primary_tag(tabling_pointer_constant(_, _)) = no.
+get_primary_tag(deep_profiling_proc_static_tag(_)) = no.
+get_primary_tag(single_functor) = yes(0).
+get_primary_tag(unshared_tag(PrimaryTag)) = yes(PrimaryTag).
+get_primary_tag(shared_remote_tag(PrimaryTag, _SecondaryTag)) =
+ yes(PrimaryTag).
+get_primary_tag(shared_local_tag(PrimaryTag, _)) = yes(PrimaryTag).
+get_primary_tag(no_tag) = no.
+get_primary_tag(reserved_address(_)) = no.
+get_primary_tag(shared_with_reserved_addresses(_ReservedAddresses, TagValue))
+ = get_primary_tag(TagValue).
get_secondary_tag(string_constant(_)) = no.
get_secondary_tag(float_constant(_)) = no.
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.18
diff -u -d -r1.18 ml_type_gen.m
--- compiler/ml_type_gen.m 31 Oct 2001 16:48:21 -0000 1.18
+++ compiler/ml_type_gen.m 4 Nov 2001 12:10:35 -0000
@@ -65,6 +65,11 @@
:- pred ml_uses_secondary_tag(cons_tag_values, constructor, int).
:- mode ml_uses_secondary_tag(in, in, out) is semidet.
+% A constructor is represented using the base class rather than a derived
+% class if there is only a single functor, or if there is a single
+% functor and some constants represented using reserved addresses.
+:- pred ml_tag_uses_base_class(cons_tag::in) is semidet.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -214,8 +219,6 @@
%
% 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
@@ -295,6 +298,11 @@
%
% };
%
+ % If there is only one constructor which is not represented
+ % as a reserved_object, then we don't generate a nested derived
+ % class for that constructor, instead we just allocate the fields
+ % in the base class.
+ %
:- pred ml_gen_du_parent_type(module_info, type_id, hlds_type_defn,
list(constructor), cons_tag_values, mlds__defns,
mlds__defns, mlds__defns).
@@ -363,10 +371,11 @@
% generate the nested derived classes for the constructors,
% or static (one_copy) member objects for constructors with
- % reserved_object representations.
- list__foldl(ml_gen_du_ctor_member(ModuleInfo, BaseClassId,
+ % reserved_object representations,
+ % or fields and a constructor method for the single_functor case.
+ list__foldl2(ml_gen_du_ctor_member(ModuleInfo, BaseClassId,
BaseClassQualifier, TagClassId, TypeDefn, TagValues),
- Ctors, [], CtorMembers),
+ Ctors, [], CtorMembers, [], BaseClassCtorMethods),
% the base class doesn't import or inherit anything
Imports = [],
@@ -379,7 +388,7 @@
MLDS_TypeName = type(BaseClassName, BaseClassArity),
MLDS_TypeFlags = ml_gen_type_decl_flags,
MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
- Imports, Inherits, Implements, [], Members)),
+ Imports, Inherits, Implements, BaseClassCtorMethods, Members)),
MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
MLDS_TypeDefnBody),
@@ -516,19 +525,24 @@
MLDS_TypeDefnBody).
%
- % Generate a definition corresponding to
+ % Generate definitions corresponding to
% a constructor of a discriminated union type.
- % This will be either a class definition
- % or (for reserved_object) a one_copy (static) member object.
+ % This will be one of the following:
+ % - (in the usual case) a nested derived class definition
+ % - (for reserved_object) a one_copy (static) member object
+ % - (for the single_functor case) a bunch of fields and
+ % a constructor method.
%
:- pred ml_gen_du_ctor_member(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_member(in, in, in, in, in, in, in, in, out) is det.
+ mlds__defns, mlds__defns, mlds__defns, mlds__defns).
+:- mode ml_gen_du_ctor_member(in, in, in, in, in, in, in, in, out, in, out)
+ is det.
ml_gen_du_ctor_member(ModuleInfo, BaseClassId, BaseClassQualifier,
SecondaryTagClassId, TypeDefn, ConsTagValues, Ctor,
- MLDS_Defns0, MLDS_Defns) :-
+ MLDS_Members0, MLDS_Members,
+ MLDS_CtorMethods0, MLDS_CtorMethods) :-
Ctor = ctor(ExistQTVars, Constraints, CtorName, Args),
% XXX we should keep a context for the constructor,
@@ -558,15 +572,16 @@
MLDS_ReservedObjDefn = ml_gen_static_const_defn(
MLDS_ReservedObjName, SecondaryTagClassId,
public, no_initializer, Context),
- MLDS_Defns = [MLDS_ReservedObjDefn | MLDS_Defns0]
+ MLDS_Members = [MLDS_ReservedObjDefn | MLDS_Members0]
;
% for reserved numeric addresses, we don't need
% to generate any objects or types
- MLDS_Defns = MLDS_Defns0
- )
+ MLDS_Members = MLDS_Members0
+ ),
+ MLDS_CtorMethods = MLDS_CtorMethods0
;
%
- % Generate a type for this constructor
+ % Generate the members for this constructor
%
% number any unnamed fields starting from 1
@@ -602,49 +617,98 @@
list__append(ExtraMembers, OrdinaryMembers, Members),
- % we inherit either the base class for this type,
- % or the secondary tag class, depending on whether
- % we need a secondary tag
- ( get_secondary_tag(TagVal) = yes(SecondaryTag) ->
- ParentClassId = SecondaryTagClassId,
- MaybeSecTagVal = yes(SecondaryTag)
- ;
- ParentClassId = BaseClassId,
- MaybeSecTagVal = no
- ),
- Imports = [],
- Inherits = [ParentClassId],
- Implements = [],
-
- % generate a constructor function to initialize the fields,
- % if needed (not all back-ends use constructor functions)
- %
+ % generate a constructor function to initialize the
+ % fields, if needed (not all back-ends use constructor
+ % functions)
+ MaybeSecTagVal = get_secondary_tag(TagVal),
module_info_globals(ModuleInfo, Globals),
globals__get_target(Globals, Target),
( target_uses_constructors(Target) = yes ->
- CtorClassType = mlds__class_type(
- qual(BaseClassQualifier, UnqualCtorName),
- CtorArity, mlds__class),
- CtorClassQualifier = mlds__append_class_qualifier(
- BaseClassQualifier, UnqualCtorName, CtorArity),
- CtorFunction = gen_constructor_function(BaseClassId,
- CtorClassType, CtorClassQualifier,
+ ( ml_tag_uses_base_class(TagVal) ->
+ CtorClassType = BaseClassId,
+ CtorClassQualifier = BaseClassQualifier
+ ;
+ CtorClassType = mlds__class_type(qual(
+ BaseClassQualifier, UnqualCtorName),
+ CtorArity, mlds__class),
+ CtorClassQualifier =
+ mlds__append_class_qualifier(
+ BaseClassQualifier, UnqualCtorName,
+ CtorArity)
+ ),
+ CtorFunction = gen_constructor_function(
+ BaseClassId, CtorClassType, CtorClassQualifier,
SecondaryTagClassId, MaybeSecTagVal, Members,
MLDS_Context),
- Ctors = [CtorFunction]
+ % If this constructor is going to go in the base class,
+ % then we may also need to generate an additional
+ % zero-argument constructor, which is used to
+ % construct the class that is used for reserved_objects
+ (
+ TagVal = shared_with_reserved_addresses(RAs,
+ single_functor),
+ some [RA] (
+ list__member(RA, RAs),
+ RA = reserved_object(_, _, _)
+ ),
+ Members \= []
+ ->
+ ZeroArgCtor = gen_constructor_function(
+ BaseClassId, CtorClassType,
+ CtorClassQualifier,
+ SecondaryTagClassId, no, [],
+ MLDS_Context),
+ Ctors = [ZeroArgCtor, CtorFunction]
+ ;
+ Ctors = [CtorFunction]
+ )
;
Ctors = []
),
- % put it all together
- MLDS_TypeName = type(UnqualCtorName, CtorArity),
- MLDS_TypeFlags = ml_gen_type_decl_flags,
- MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
- Imports, Inherits, Implements, Ctors, Members)),
- MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context,
- MLDS_TypeFlags, MLDS_TypeDefnBody),
- MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0]
+ ( ml_tag_uses_base_class(TagVal) ->
+ % put the members for this constructor directly
+ % in the base class
+ MLDS_Members = Members ++ MLDS_Members0,
+ MLDS_CtorMethods = Ctors ++ MLDS_CtorMethods0
+ ;
+ %
+ % Generate a nested derived class for this constructor,
+ % and put the members for this constructor in that
+ % class
+ %
+
+ % we inherit either the base class for this type,
+ % or the secondary tag class, depending on whether
+ % we need a secondary tag
+ ( MaybeSecTagVal = yes(_) ->
+ ParentClassId = SecondaryTagClassId
+ ;
+ ParentClassId = BaseClassId
+ ),
+ Imports = [],
+ Inherits = [ParentClassId],
+ Implements = [],
+
+ % put it all together
+ MLDS_TypeName = type(UnqualCtorName, CtorArity),
+ MLDS_TypeFlags = ml_gen_type_decl_flags,
+ MLDS_TypeDefnBody = mlds__class(mlds__class_defn(
+ mlds__class, Imports, Inherits, Implements,
+ Ctors, Members)),
+ MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context,
+ MLDS_TypeFlags, MLDS_TypeDefnBody),
+ MLDS_Members = [MLDS_TypeDefn | MLDS_Members0],
+ MLDS_CtorMethods = MLDS_CtorMethods0
+ )
).
+
+% A constructor is represented using the base class rather than a derived
+% class if there is only a single functor, or if there is a single
+% functor and some constants represented using reserved addresses.
+ml_tag_uses_base_class(single_functor).
+ml_tag_uses_base_class(shared_with_reserved_addresses(_RAs, Tag)) :-
+ ml_tag_uses_base_class(Tag).
:- func target_uses_constructors(compilation_target) = bool.
target_uses_constructors(c) = no.
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.46
diff -u -d -r1.46 ml_unify_gen.m
--- compiler/ml_unify_gen.m 31 Oct 2001 17:58:58 -0000 1.46
+++ compiler/ml_unify_gen.m 4 Nov 2001 12:11:05 -0000
@@ -261,15 +261,12 @@
%
% ordinary compound terms
%
- { Tag = single_functor, TagVal = 0,
- MaybeSecondaryTag = no
- ; Tag = unshared_tag(TagVal),
- MaybeSecondaryTag = no
- ; Tag = shared_remote_tag(TagVal, SecondaryTag),
- MaybeSecondaryTag = yes(SecondaryTag)
+ { Tag = single_functor
+ ; Tag = unshared_tag(_TagVal)
+ ; Tag = shared_remote_tag(_PrimaryTag, _SecondaryTag)
}
->
- ml_gen_compound(TagVal, MaybeSecondaryTag, ConsId, Var, Args,
+ ml_gen_compound(Tag, ConsId, Var, Args,
ArgModes, HowToConstruct, Context,
MLDS_Decls, MLDS_Statements)
;
@@ -590,9 +587,10 @@
%
% the pointer will not be tagged (i.e. the tag will be zero)
%
- { Tag = 0 },
- { CtorDefn = ctor_id("<closure>", 0) },
- { QualifiedCtorId = qual(MLDS_PrivateBuiltinModule, CtorDefn) },
+ { MaybeConsId = no },
+ { MaybeConsName = no },
+ { PrimaryTag = 0 },
+ { MaybeSecondaryTag = no },
%
% put all the extra arguments of the closure together
@@ -604,8 +602,9 @@
% generate a `new_object' statement (or static constant)
% for the closure
%
- ml_gen_new_object(no, Tag, no, QualifiedCtorId, Var, ExtraArgRvals,
- ExtraArgTypes, ArgVars, ArgModes, HowToConstruct, Context,
+ ml_gen_new_object(MaybeConsId, PrimaryTag, MaybeSecondaryTag,
+ MaybeConsName, Var, ExtraArgRvals, ExtraArgTypes, ArgVars,
+ ArgModes, HowToConstruct, Context,
MLDS_Decls, MLDS_Statements).
%
@@ -1028,15 +1027,34 @@
{ code_util__cons_id_to_tag(ConsId, Type, ModuleInfo, Tag) }.
% generate code to construct a new object
-:- pred ml_gen_compound(mlds__tag, maybe(int), cons_id, prog_var, prog_vars,
+:- pred ml_gen_compound(cons_tag, cons_id, prog_var, prog_vars,
list(uni_mode), how_to_construct, prog_context,
mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
-:- mode ml_gen_compound(in, in, in, in, in, in, in, in, out, out, in, out)
+:- mode ml_gen_compound(in, in, in, in, in, in, in, out, out, in, out)
is det.
-ml_gen_compound(Tag, MaybeSecondaryTag, ConsId, Var, ArgVars, ArgModes,
+ml_gen_compound(Tag, ConsId, Var, ArgVars, ArgModes,
HowToConstruct, Context, MLDS_Decls, MLDS_Statements) -->
- ml_cons_name(ConsId, CtorName),
+ %
+ % get the primary and secondary tags
+ %
+ { get_primary_tag(Tag) = yes(PrimaryTag0) ->
+ PrimaryTag = PrimaryTag0
+ ;
+ unexpected(this_file, "ml_gen_compound: primary tag unknown")
+ },
+ { MaybeSecondaryTag = get_secondary_tag(Tag) },
+
+ %
+ % figure out which class name to construct
+ %
+ ( { ml_tag_uses_base_class(Tag) } ->
+ { MaybeCtorName = no }
+ ;
+ ml_cons_name(ConsId, CtorName),
+ { MaybeCtorName = yes(CtorName) }
+ ),
+
%
% If there is a secondary tag, it goes in the first field
%
@@ -1051,8 +1069,8 @@
ExtraRvals = [],
ExtraArgTypes = []
},
- ml_gen_new_object(yes(ConsId), Tag, HasSecTag, CtorName, Var,
- ExtraRvals, ExtraArgTypes, ArgVars, ArgModes,
+ ml_gen_new_object(yes(ConsId), PrimaryTag, HasSecTag, MaybeCtorName,
+ Var, ExtraRvals, ExtraArgTypes, ArgVars, ArgModes,
HowToConstruct, Context, MLDS_Decls, MLDS_Statements).
%
@@ -1063,15 +1081,15 @@
% additional constants to insert at the start of the
% argument list.
%
-:- pred ml_gen_new_object(maybe(cons_id), mlds__tag, bool, ctor_name, prog_var,
- list(mlds__rval), list(mlds__type), prog_vars,
+:- pred ml_gen_new_object(maybe(cons_id), mlds__tag, bool, maybe(ctor_name),
+ prog_var, list(mlds__rval), list(mlds__type), prog_vars,
list(uni_mode), how_to_construct,
prog_context, mlds__defns, mlds__statements,
ml_gen_info, ml_gen_info).
:- mode ml_gen_new_object(in, in, in, in, in, in, in, in, in, in, in, out, out,
in, out) is det.
-ml_gen_new_object(MaybeConsId, Tag, HasSecTag, CtorName, Var,
+ml_gen_new_object(MaybeConsId, Tag, HasSecTag, MaybeCtorName, Var,
ExtraRvals, ExtraTypes, ArgVars, ArgModes, HowToConstruct,
Context, MLDS_Decls, MLDS_Statements) -->
%
@@ -1112,7 +1130,7 @@
%
{ list__length(ArgRvals, NumArgs) },
{ SizeInWordsRval = const(int_const(NumArgs)) },
-
+
%
% Generate a `new_object' statement to dynamically allocate
% the memory for this term from the heap. The `new_object'
@@ -1120,7 +1138,7 @@
% with boxed versions of the specified arguments.
%
{ MakeNewObject = new_object(VarLval, MaybeTag, HasSecTag,
- MLDS_Type, yes(SizeInWordsRval), yes(CtorName),
+ MLDS_Type, yes(SizeInWordsRval), MaybeCtorName,
ArgRvals, MLDS_ArgTypes) },
{ MLDS_Stmt = atomic(MakeNewObject) },
{ MLDS_Statement = mlds__statement(MLDS_Stmt,
@@ -1226,12 +1244,12 @@
%
% For each field in the construction unification we need
% to generate an rval.
- % XXX we do more work then we need to here, as some of
+ % XXX we do more work than we need to here, as some of
% the cells may already contain the correct values.
%
ml_gen_unify_args(ConsId, ArgVars, ArgModes, ArgTypes,
- Fields, Type, VarLval, OffSet,
- ArgNum, PrimaryTag, Context, MLDS_Statements0),
+ Fields, Type, VarLval, OffSet, ArgNum,
+ ConsIdTag, Context, MLDS_Statements0),
{ MLDS_Decls = [] },
{ MLDS_Statements = [MLDS_Statement | MLDS_Statements0] }
@@ -1485,27 +1503,31 @@
)
;
{ Tag = single_functor },
- % treat single_functor the same as unshared_tag(0)
- ml_gen_det_deconstruct_2(unshared_tag(0), Type, Var, ConsId,
- Args, Modes, Context, MLDS_Statements)
+ ml_gen_var(Var, VarLval),
+ ml_variable_types(Args, ArgTypes),
+ ml_field_names_and_types(Type, ConsId, ArgTypes, Fields),
+ { ml_tag_offset_and_argnum(Tag, _, OffSet, ArgNum) },
+ ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, Type,
+ VarLval, OffSet, ArgNum,
+ Tag, Context, MLDS_Statements)
;
- { Tag = unshared_tag(UnsharedTag) },
+ { Tag = unshared_tag(_UnsharedTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
ml_field_names_and_types(Type, ConsId, ArgTypes, Fields),
{ ml_tag_offset_and_argnum(Tag, _, OffSet, ArgNum) },
ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, Type,
VarLval, OffSet, ArgNum,
- UnsharedTag, Context, MLDS_Statements)
+ Tag, Context, MLDS_Statements)
;
- { Tag = shared_remote_tag(PrimaryTag, _SecondaryTag) },
+ { Tag = shared_remote_tag(_PrimaryTag, _SecondaryTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
ml_field_names_and_types(Type, ConsId, ArgTypes, Fields),
{ ml_tag_offset_and_argnum(Tag, _, OffSet, ArgNum) },
ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, Type,
VarLval, OffSet, ArgNum,
- PrimaryTag, Context, MLDS_Statements)
+ Tag, Context, MLDS_Statements)
;
% For constants, if the deconstruction is det, then we already
% know the value of the constant, so MLDS_Statements = [].
@@ -1640,16 +1662,16 @@
:- pred ml_gen_unify_args(cons_id, prog_vars, list(uni_mode), list(prog_type),
list(constructor_arg), prog_type, mlds__lval, int, int,
- mlds__tag, prog_context, mlds__statements,
+ cons_tag, prog_context, mlds__statements,
ml_gen_info, ml_gen_info).
:- mode ml_gen_unify_args(in, in, in, in, in, in, in, in, in, in, in, out,
in, out) is det.
ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, VarType, VarLval,
- Offset, ArgNum, PrimaryTag, Context, MLDS_Statements) -->
+ Offset, ArgNum, Tag, Context, MLDS_Statements) -->
(
ml_gen_unify_args_2(ConsId, Args, Modes, ArgTypes, Fields,
- VarType, VarLval, Offset, ArgNum, PrimaryTag, Context,
+ VarType, VarLval, Offset, ArgNum, Tag, Context,
[], MLDS_Statements0)
->
{ MLDS_Statements = MLDS_Statements0 }
@@ -1659,7 +1681,7 @@
:- pred ml_gen_unify_args_2(cons_id, prog_vars, list(uni_mode), list(prog_type),
list(constructor_arg), prog_type, mlds__lval, int, int,
- mlds__tag, prog_context, mlds__statements, mlds__statements,
+ cons_tag, prog_context, mlds__statements, mlds__statements,
ml_gen_info, ml_gen_info).
:- mode ml_gen_unify_args_2(in, in, in, in, in, in, in, in, in, in, in, in, out,
in, out) is semidet.
@@ -1667,26 +1689,26 @@
ml_gen_unify_args_2(_, [], [], [], _, _, _, _, _, _, _, Statements, Statements)
--> [].
ml_gen_unify_args_2(ConsId, [Arg|Args], [Mode|Modes], [ArgType|ArgTypes],
- [Field|Fields], VarType, VarLval, Offset, ArgNum, PrimaryTag,
+ [Field|Fields], VarType, VarLval, Offset, ArgNum, Tag,
Context, MLDS_Statements0, MLDS_Statements) -->
{ Offset1 = Offset + 1 },
{ ArgNum1 = ArgNum + 1 },
ml_gen_unify_args_2(ConsId, Args, Modes, ArgTypes, Fields, VarType,
- VarLval, Offset1, ArgNum1, PrimaryTag, Context,
+ VarLval, Offset1, ArgNum1, Tag, Context,
MLDS_Statements0, MLDS_Statements1),
ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
- Offset, ArgNum, PrimaryTag, Context,
+ Offset, ArgNum, Tag, Context,
MLDS_Statements1, MLDS_Statements).
:- pred ml_gen_unify_arg(cons_id, prog_var, uni_mode, prog_type,
- constructor_arg, prog_type, mlds__lval, int, int, mlds__tag,
+ constructor_arg, prog_type, mlds__lval, int, int, cons_tag,
prog_context, mlds__statements, mlds__statements,
ml_gen_info, ml_gen_info).
:- mode ml_gen_unify_arg(in, in, in, in, in, in, in, in, in, in, in, in, out,
in, out) is det.
ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
- Offset, ArgNum, PrimaryTag, Context,
+ Offset, ArgNum, Tag, Context,
MLDS_Statements0, MLDS_Statements) -->
{ Field = MaybeFieldName - FieldType },
=(Info),
@@ -1716,7 +1738,7 @@
ConsId = cons(ConsName, ConsArity)
->
unqualify_name(ConsName, UnqualConsName),
- FieldId = ml_gen_field_id(VarType,
+ FieldId = ml_gen_field_id(VarType, Tag,
UnqualConsName, ConsArity, FieldName)
;
error("ml_gen_unify_args: invalid cons_id")
@@ -1757,7 +1779,8 @@
%
ml_gen_type(VarType, MLDS_VarType),
ml_gen_type(BoxedFieldType, MLDS_BoxedFieldType),
- { FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId,
+ { MaybePrimaryTag = get_primary_tag(Tag) },
+ { FieldLval = field(MaybePrimaryTag, lval(VarLval), FieldId,
MLDS_BoxedFieldType, MLDS_VarType) },
ml_gen_var(Arg, ArgLval),
@@ -2064,27 +2087,39 @@
QualifiedFieldName = qual(FieldQualifier, FieldName),
FieldId = named_field(QualifiedFieldName, ClassPtrType).
-:- func ml_gen_field_id(prog_type, mlds__class_name, arity, mlds__field_name) =
- mlds__field_id.
+:- func ml_gen_field_id(prog_type, cons_tag, mlds__class_name, arity,
+ mlds__field_name) = mlds__field_id.
-ml_gen_field_id(Type, ClassName, ClassArity, FieldName) = FieldId :-
+ml_gen_field_id(Type, Tag, ConsName, ConsArity, FieldName) = FieldId :-
(
type_to_type_id(Type, TypeId, _)
->
- ml_gen_type_name(TypeId, qual(MLDS_Module, TypeName), TypeArity),
- ClassQualifier = mlds__append_class_qualifier(
+ ml_gen_type_name(TypeId, QualTypeName, TypeArity),
+ QualTypeName = qual(MLDS_Module, TypeName),
+ TypeQualifier = mlds__append_class_qualifier(
MLDS_Module, TypeName, TypeArity),
- QualClassName = qual(ClassQualifier, ClassName),
- ClassPtrType = mlds__ptr_type(mlds__class_type(
- QualClassName, ClassArity, mlds__class)),
- FieldQualifier = mlds__append_class_qualifier(
- ClassQualifier, ClassName, ClassArity),
- QualifiedFieldName = qual(FieldQualifier, FieldName),
+
+ ( ml_tag_uses_base_class(Tag) ->
+ % in this case, there's only one functor for the type
+ % (other than reserved_address constants),
+ % and so the class name is determined by the type name
+ ClassPtrType = mlds__ptr_type(mlds__class_type(
+ QualTypeName, TypeArity, mlds__class)),
+ QualifiedFieldName = qual(TypeQualifier, FieldName)
+ ;
+ % in this case, the class name is determined by the
+ % constructor
+ QualConsName = qual(TypeQualifier, ConsName),
+ ClassPtrType = mlds__ptr_type(mlds__class_type(
+ QualConsName, ConsArity, mlds__class)),
+ FieldQualifier = mlds__append_class_qualifier(
+ TypeQualifier, ConsName, ConsArity),
+ QualifiedFieldName = qual(FieldQualifier, FieldName)
+ ),
FieldId = named_field(QualifiedFieldName, ClassPtrType)
;
error("ml_gen_field_id: invalid type")
).
-
:- func this_file = string.
this_file = "ml_unify_gen.m".
--
Fergus Henderson <fjh at cs.mu.oz.au> | "... it seems to me that 15 years of
The University of Melbourne | email is plenty for one lifetime."
WWW: <http://www.cs.mu.oz.au/~fjh> | -- Prof. Donald E. Knuth
--------------------------------------------------------------------------
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