[m-dev.] diff: --high-level-data: use field names instead of offsets

[Fergus Henderson]

On 06-Jun-2000, Fergus Henderson <fjh at cs.mu.OZ.AU> wrote:
> For --high-level-data, use field names rather than offsets
> when accessing fields.

I posted that diff a little prematurely; it didn't pass the bootcheck.
The problem was that the layouts for most types (e.g. list) didn't
match what the runtime expected, since it was always including a
secondary tag, even if one wasn't needed.  So I made some additional
changes to avoid the secondary tag if it isn't needed.

With these changes, using gcc it bootchecks with --high-level-data.
But there are still a lot of warnings, mostly relating to abstract
enum types or equivalence types.  Also it makes use of a GNU C
extension (empty structs).  And I don't think existential data types
work with --high-level-data yet.

I've enclosed both a relative diff and a full diff.

********************
RELATIVE DIFF
********************

diff -u old2/CHANGES41 ./CHANGES41
--- old2/CHANGES41	Tue Jun  6 13:01:48 2000
+++ ./CHANGES41	Tue Jun  6 13:14:16 2000
@@ -1,5 +1,5 @@
 
-Estimated hours taken: 8
+Estimated hours taken: 13
 
 For --high-level-data, use field names rather than offsets
 when accessing fields.
@@ -18,9 +18,18 @@
 	For fields of certain types, such as `float', etc.,
 	generate the field type as a boxed type (mlds__generic_type).
 
+	Don't generate a field for the secondary tag if it isn't
+	needed.  If none of the ctors need a secondary tag, then
+	skip it entirely.  If some but not all ctors need a
+	secondary tag, then put the secondary tag field in a
+	separate class derived fom the base class for this type,
+	and have the classes for the ctors that need it derived
+	from that class rather than from the base class.
+
 compiler/ml_unify_gen.m:
 	For --high-level-data, use field names rather than offsets
-	when accessing fields.
+	when accessing data fields and secondary tags.
+	(XXX the code for closures still uses offsets.)
 
 compiler/ml_code_util.m:
 	Add two new routines for dealing with fields,
diff -u old2/ml_type_gen.m ./ml_type_gen.m
--- old2/ml_type_gen.m	Tue Jun  6 11:20:01 2000
+++ ./ml_type_gen.m	Tue Jun  6 13:47:06 2000
@@ -188,15 +188,38 @@
 	%
 	%	class <ClassName> {
 	%	public:
-	%		int data_tag;
-	%		/* constants used for data_tag */
-	%		static const int <ctor1> = 0;
-	%		static const int <ctor2> = 1;
+	% #if some_but_not_all_ctors_use_secondary_tag
+	%		/* A nested derived class for the secondary tag */
+	%		class tag_type : public <ClassName> {
+	%		public:
+	% #endif
+	% #if some_ctors_use_secondary_tag
+	%			int data_tag;
+	%   #if 0
+	%   /*
+	%   ** XXX we don't yet bother with these;
+	%   ** mlds_to_c.m doesn't support static members.
+	%   */
+	%			/* constants used for data_tag */
+	%			static const int <ctor1> = 0;
+	%			static const int <ctor2> = 1;
+	%   #endif
+	% #endif
+	% #if some_but_not_all_ctors_use_secondary_tag
+	%		};
+	% #endif
 	%		...
 	%		/*
 	%		** Derived classes, one for each constructor;
 	%		** these are generated as nested classes to
 	%		** avoid name clashes.
+	%		** These will derive either directly from
+	%		** <ClassName> or from <ClassName>::tag_type
+	%		** (which in turn derives from <ClassName>),
+	%		** depending on whether they need a secondary
+	%		** tag.  If all the ctors for a type need a
+	%		** secondary tag, we put the secondary tag members
+	%		** directly in the base class.
 	%		*/
 	%		class <ctor1> : public <ClassName> {
 	%		public:
@@ -208,7 +231,7 @@
 	%			MR_Word F2;
 	%			...
 	%		};
-	%		class <ctor2> : public <ClassName> {
+	%		class <ctor2> : public <ClassName>::tag_type {
 	%		public:
 	%			...
 	%		};
@@ -220,27 +243,70 @@
 		mlds__defns, mlds__defns).
 :- mode ml_gen_du_parent_type(in, in, in, in, in, in, in, out) is det.
 
-ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn, Ctors, _TagValues,
+ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn, Ctors, TagValues,
 		MaybeEqualityMembers, MLDS_Defns0, MLDS_Defns) :-
 	hlds_data__get_type_defn_context(TypeDefn, Context),
 	MLDS_Context = mlds__make_context(Context),
 
 	% generate the class name
-	ml_gen_type_name(TypeId, qual(_, MLDS_ClassName), MLDS_ClassArity),
+	ml_gen_type_name(TypeId, QualBaseClassName, BaseClassArity),
+	BaseClassId = mlds__class_type(QualBaseClassName, BaseClassArity,
+		mlds__class),
+	QualBaseClassName = qual(BaseClassModuleName, BaseClassName),
+	BaseClassQualifier = mlds__append_class_qualifier(
+		BaseClassModuleName, BaseClassName, BaseClassArity),
 
-	% generate the class members
-	TagMember = ml_gen_tag_member("data_tag", Context),
-	TagConstMembers = [],
-	% XXX we don't yet bother with these;
-	% mlds_to_c.m doesn't support static members.
-	%	TagConstMembers = list__condense(list__map(
-	% 		ml_gen_tag_constant(Context, TagValues), Ctors)),
-	Members0 = list__append(MaybeEqualityMembers,
-		[TagMember|TagConstMembers]),
+	(
+		%
+		% If none of the constructors for this type need
+		% a secondary tag, then we don't need the
+		% members for the secondary tag.
+		%
+		\+ (some [Ctor] (
+			list__member(Ctor, Ctors),
+			ml_uses_secondary_tag(TagValues, Ctor, _)
+		))
+	->
+		TagMembers = [],
+		TagClassId = BaseClassId
+	;
+		%
+		% Generate the members for the secondary tag.
+		%
+		TagDataMember = ml_gen_tag_member("data_tag", Context),
+		TagConstMembers = [],
+		% XXX we don't yet bother with these;
+		% mlds_to_c.m doesn't support static members.
+		%	TagConstMembers = list__condense(list__map(
+		% 		ml_gen_tag_constant(Context, TagValues), Ctors)),
+		TagMembers0 = [TagDataMember | TagConstMembers],
+
+		%
+		% If all the constructors for this type need a
+		% secondary tag, then we put the secondary tag members
+		% directly in the base class, otherwise we put it in
+		% a separate nested derived class.
+		%
+		(
+			(all [Ctor] (
+				list__member(Ctor, Ctors)
+			=>
+				ml_uses_secondary_tag(TagValues, Ctor, _)
+			))
+		->
+			TagMembers = TagMembers0,
+			TagClassId = BaseClassId
+		;
+			ml_gen_secondary_tag_class(MLDS_Context,
+				BaseClassQualifier, BaseClassId, TagMembers0,
+				TagTypeDefn, TagClassId),
+			TagMembers = [TagTypeDefn]
+		)
+	),
 
 	% generate the nested derived classes
-	list__foldl(ml_gen_du_ctor_type(ModuleInfo, TypeId, TypeDefn), Ctors,
-		Members0, Members),
+	list__foldl(ml_gen_du_ctor_type(ModuleInfo, BaseClassId, TagClassId,
+		TypeDefn, TagValues), Ctors, [], CtorMembers),
 
 	% the base class doesn't import or inherit anything
 	Imports = [],
@@ -248,7 +314,9 @@
 	Implements = [],
 
 	% put it all together
-	MLDS_TypeName = type(MLDS_ClassName, MLDS_ClassArity),
+	Members = list__condense([MaybeEqualityMembers, TagMembers,
+		CtorMembers]),
+	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)),
@@ -257,6 +325,9 @@
 	
 	MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
 
+	%
+	% Generate the declaration for the field that holds the secondary tag.
+	%
 :- func ml_gen_tag_member(mlds__var_name, prog_context) = mlds__defn.
 ml_gen_tag_member(Name, Context) =
 	mlds__defn(data(var(Name)),
@@ -271,10 +342,7 @@
 	%
 	% Check if this constructor uses a secondary tag.
 	%
-	Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
-	list__length(Args, Arity),
-	map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
-	( TagVal = shared_remote_tag(_PrimaryTag, SecondaryTag) ->
+	( ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag) ->
 		%
 		% Generate an MLDS definition for this secondary
 		% tag constant.  We do this mainly for readability
@@ -283,6 +351,7 @@
 		% useful in the `--tags none' case, where there
 		% will be no primary tags.
 		%
+		Ctor = ctor(_ExistQTVars, _Constraints, Name, _Args),
 		unqualify_name(Name, UnqualifiedName),
 		ConstValue = const(int_const(SecondaryTag)),
 		MLDS_Defn = mlds__defn(data(var(UnqualifiedName)),
@@ -295,11 +364,63 @@
 		MLDS_Defns = []
 	).
 
-:- pred ml_gen_du_ctor_type(module_info, type_id, hlds_type_defn, constructor,
+	%
+	% Check if this constructor uses a secondary tag,
+	% and if so, return the secondary tag value.
+	%
+:- pred ml_uses_secondary_tag(cons_tag_values, constructor, int).
+:- mode ml_uses_secondary_tag(in, in, out) is semidet.
+
+ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag) :-
+	Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
+	list__length(Args, Arity),
+	map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
+	TagVal = shared_remote_tag(_PrimaryTag, SecondaryTag).
+
+	%
+	% Generate a definition for the class used for the secondary tag
+	% type.  This is needed for discriminated unions for which some
+	% but not all constructors use secondary tags.
+	%
+:- pred ml_gen_secondary_tag_class(mlds__context, mlds_module_name,
+		mlds__class_id, mlds__defns, mlds__defn, mlds__class_id).
+:- mode ml_gen_secondary_tag_class(in, in, in, in, out, out) is det.
+
+ml_gen_secondary_tag_class(MLDS_Context, BaseClassQualifier, BaseClassId, Members,
+		MLDS_TypeDefn, SecondaryTagClassId) :-
+	% Generate the class name for the secondary tag class.
+	% Note: the secondary tag class is nested inside the
+	% base class for this type.
+	UnqualClassName = "tag_type",
+	ClassName = qual(BaseClassQualifier, UnqualClassName),
+	ClassArity = 0,
+	SecondaryTagClassId = mlds__class_type(ClassName, ClassArity,
+		mlds__class),
+
+	% the secondary tag class inherits the base class for this type
+	Imports = [],
+	Inherits = [BaseClassId],
+	Implements = [],
+
+	% put it all together
+	MLDS_TypeName = type(UnqualClassName, ClassArity),
+	MLDS_TypeFlags = ml_gen_type_decl_flags,
+	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
+		Imports, Inherits, Implements, Members)),
+	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
+		MLDS_TypeDefnBody).
+	
+	%
+	% 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,
 		mlds__defns, mlds__defns).
-:- mode ml_gen_du_ctor_type(in, in, in, in, in, out) is det.
+:- mode ml_gen_du_ctor_type(in, in, in, in, in, in, in, out) is det.
 
-ml_gen_du_ctor_type(ModuleInfo, TypeId, TypeDefn, Ctor,
+ml_gen_du_ctor_type(ModuleInfo, BaseClassId, SecondaryTagClassId,
+		TypeDefn, ConsTagValues, Ctor,
 		MLDS_Defns0, MLDS_Defns) :-
 	Ctor = ctor(_ExistQTVars, _Constraints, CtorName, Args),
 
@@ -308,12 +429,6 @@
 	hlds_data__get_type_defn_context(TypeDefn, Context),
 	MLDS_Context = mlds__make_context(Context),
 
-	% generate the base class name
-	ClassKind = mlds__class,
-	ml_gen_type_name(TypeId, BaseClassName, BaseClassArity),
-	BaseClassId = mlds__class_type(BaseClassName, BaseClassArity,
-		ClassKind),
-
 	% generate the class name for this constructor
 	unqualify_name(CtorName, CtorClassName),
 	list__length(Args, CtorArity),
@@ -323,15 +438,22 @@
 	list__map_foldl(ml_gen_du_ctor_member(ModuleInfo, Context),
 		Args, Members, 1, _),
 
-	% we inherit the base class for this type
+	% 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
+	;
+		ParentClassId = BaseClassId
+	),
 	Imports = [],
-	Inherits = [BaseClassId],
+	Inherits = [ParentClassId],
 	Implements = [],
 
 	% put it all together
 	MLDS_TypeName = type(CtorClassName, CtorArity),
 	MLDS_TypeFlags = ml_gen_type_decl_flags,
-	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(ClassKind,
+	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
 		Imports, Inherits, Implements, Members)),
 	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
 		MLDS_TypeDefnBody),
diff -u old2/ml_unify_gen.m ./ml_unify_gen.m
--- old2/ml_unify_gen.m	Tue Jun  6 11:20:01 2000
+++ ./ml_unify_gen.m	Tue Jun  6 13:39:57 2000
@@ -1273,23 +1273,13 @@
 		HighLevelData = yes,
 		FieldName = ml_gen_field_name(MaybeFieldName, ArgNum),
 		(
-			ConsId = cons(ConsName, ConsArity),
-			type_to_type_id(VarType, TypeId, _)
+			ConsId = cons(ConsName, ConsArity)
 		->
-			ml_gen_type_name(TypeId,
-				qual(MLDS_Module, TypeName), TypeArity),
-			ConsQualifier = mlds__append_class_qualifier(
-				MLDS_Module, TypeName, TypeArity),
 			unqualify_name(ConsName, UnqualConsName),
-			QualConsName = qual(ConsQualifier, UnqualConsName),
-			ConsType = mlds__ptr_type(mlds__class_type(
-				QualConsName, ConsArity, mlds__class)),
-			FieldQualifier = mlds__append_class_qualifier(
-				ConsQualifier, UnqualConsName, ConsArity),
-			QualifiedFieldName = qual(FieldQualifier, FieldName),
-			FieldId = named_field(QualifiedFieldName, ConsType)
+			FieldId = ml_gen_field_id(VarType,
+				UnqualConsName, ConsArity, FieldName)
 		;
-			error("ml_gen_unify_args: invalid cons_id or type")
+			error("ml_gen_unify_args: invalid cons_id")
 		)
 	},
 	{
@@ -1458,10 +1448,9 @@
 	ml_gen_var(Var, VarLval),
 	ml_variable_type(Var, Type),
 	ml_cons_id_to_tag(ConsId, Type, Tag),
-	ml_gen_type(Type, MLDS_Type),
 	=(Info),
 	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
-	{ TagTestExpression = ml_gen_tag_test_rval(Tag, MLDS_Type, ModuleInfo,
+	{ TagTestExpression = ml_gen_tag_test_rval(Tag, Type, ModuleInfo,
 		lval(VarLval)) },
 	{ TagTestDecls = [] },
 	{ TagTestStatements = [] }.
@@ -1471,7 +1460,7 @@
 	%	true if VarRval has the specified Tag and false otherwise.
 	%	VarType is the type of VarRval. 
 	%
-:- func ml_gen_tag_test_rval(cons_tag, mlds__type, module_info, mlds__rval)
+:- func ml_gen_tag_test_rval(cons_tag, prog_type, module_info, mlds__rval)
 	= mlds__rval.
 
 ml_gen_tag_test_rval(string_constant(String), _, _, Rval) =
@@ -1500,19 +1489,29 @@
 ml_gen_tag_test_rval(unshared_tag(UnsharedTag), _, _, Rval) =
 	binop(eq, unop(std_unop(tag), Rval),
 		  unop(std_unop(mktag), const(int_const(UnsharedTag)))).
-ml_gen_tag_test_rval(shared_remote_tag(PrimaryTag, SecondaryTag), MLDS_VarType,
-		ModuleInfo, Rval) = TagTest :-
-	SecondaryTagTest = binop(eq,
-		% Note: with the current low-level data representation,
+ml_gen_tag_test_rval(shared_remote_tag(PrimaryTagVal, SecondaryTagVal),
+		VarType, ModuleInfo, Rval) = TagTest :-
+	MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
+	module_info_globals(ModuleInfo, Globals),
+	globals__lookup_bool_option(Globals, highlevel_data, HighLevelData),
+	( HighLevelData = no ->
+		% Note: with the low-level data representation,
 		% all fields -- even the secondary tag -- are boxed,
 		% and so we need to unbox (i.e. cast) it back to the
 		% right type here.
-		unop(unbox(mlds__native_int_type),
-			lval(field(yes(PrimaryTag), Rval,
-			offset(const(int_const(0))),
-			mlds__generic_type, MLDS_VarType))),
-		const(int_const(SecondaryTag))),
-	module_info_globals(ModuleInfo, Globals),
+		SecondaryTagField = 
+			unop(unbox(mlds__native_int_type),
+				lval(field(yes(PrimaryTagVal), Rval,
+				offset(const(int_const(0))),
+				mlds__generic_type, MLDS_VarType)))
+	;
+		FieldId = ml_gen_field_id(VarType, "tag_type", 0,
+			"data_tag"),
+		SecondaryTagField = lval(field(yes(PrimaryTagVal), Rval,
+			FieldId, mlds__native_int_type, MLDS_VarType))
+	),
+	SecondaryTagTest = binop(eq, SecondaryTagField,
+		const(int_const(SecondaryTagVal))),
 	globals__lookup_int_option(Globals, num_tag_bits, NumTagBits),
 	( NumTagBits = 0 ->
 		% no need to test the primary tag
@@ -1520,11 +1519,35 @@
 	;
 		PrimaryTagTest = binop(eq,
 			unop(std_unop(tag), Rval),
-			unop(std_unop(mktag), const(int_const(PrimaryTag)))), 
+			unop(std_unop(mktag),
+				const(int_const(PrimaryTagVal)))), 
 		TagTest = binop(and, PrimaryTagTest, SecondaryTagTest)
 	).
-ml_gen_tag_test_rval(shared_local_tag(Bits, Num), MLDS_VarType, _, Rval) =
-	binop(eq, Rval,
+ml_gen_tag_test_rval(shared_local_tag(Bits, Num), VarType, ModuleInfo, Rval) =
+		TestRval :-
+	MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
+	TestRval = binop(eq, Rval,
 		  unop(cast(MLDS_VarType), mkword(Bits,
 		  	unop(std_unop(mkbody), const(int_const(Num)))))).
 
+:- func ml_gen_field_id(prog_type, mlds__class_name, arity, mlds__field_name) =
+	mlds__field_id.
+
+ml_gen_field_id(Type, ClassName, ClassArity, FieldName) = FieldId :-
+	(
+		type_to_type_id(Type, TypeId, _)
+	->
+		ml_gen_type_name(TypeId,
+			qual(MLDS_Module, TypeName), TypeArity),
+		ClassQualifier = 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),
+		FieldId = named_field(QualifiedFieldName, ClassPtrType)
+	;
+		error("ml_gen_field_id: invalid type")
+	).

********************
FULL DIFF
********************

Estimated hours taken: 12

For --high-level-data, use field names rather than offsets
when accessing fields.

compiler/hlds_data.m:
	Include the field names in the hlds_cons_defn,
	for use by ml_unify_gen.m.

compiler/make_hlds.m:
compiler/typecheck.m:
compiler/post_typecheck.m:
compiler/type_util.m:
	Minor changes to handle the change to hlds_cons_defn.
	
compiler/ml_type_gen.m:
	For fields of certain types, such as `float', etc.,
	generate the field type as a boxed type (mlds__generic_type).

	Don't generate a field for the secondary tag if it isn't
	needed.  If none of the ctors need a secondary tag, then
	skip it entirely.  If some but not all ctors need a
	secondary tag, then put the secondary tag field in a
	separate class derived fom the base class for this type,
	and have the classes for the ctors that need it derived
	from that class rather than from the base class.

compiler/ml_unify_gen.m:
	For --high-level-data, use field names rather than offsets
	when accessing data fields and secondary tags.
	(XXX the code for closures still uses offsets.)

compiler/ml_code_util.m:
	Add two new routines for dealing with fields,
	`ml_gen_field_name' and `ml_must_box_field_type',
	for use by ml_type_gen.m and ml_unify_gen.m.

compiler/mlds.m:
	Change the documentation for the ClassType field in `field'
	lvals: rename it as `PtrType', and make it clear that this is
	the type of the pointer, not the type of the class pointed to.
	Also add a new CtorType field to the `named_field' field_id.

compiler/ml_elim_nested.m:
	Minor changes to handle the modifications to mlds.m.

compiler/mlds_to_c.m:
	Ensure that we name-mangle struct names and field names.
	For named_field field accesses, cast the pointer to the type
	specified by the new CtorType field before dereferencing it.

Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.45
diff -u -d -r1.45 hlds_data.m
--- compiler/hlds_data.m	2000/03/10 13:37:41	1.45
+++ compiler/hlds_data.m	2000/06/05 06:14:09
@@ -62,8 +62,9 @@
 			% you can get the tvarset from the hlds__type_defn.
 			existq_tvars,		% existential type vars
 			list(class_constraint), % existential class constraints
-			list(type),		% The types of the arguments
-						% of this functor (if any)
+			list(constructor_arg),	% The field names and types of
+						% the arguments of this functor
+						% (if any)
 			type_id,		% The result type, i.e. the
 						% type to which this
 						% cons_defn belongs.
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.335
diff -u -d -r1.335 make_hlds.m
--- compiler/make_hlds.m	2000/05/13 13:56:11	1.335
+++ compiler/make_hlds.m	2000/06/05 06:24:03
@@ -1935,8 +1935,7 @@
 		Ctors0, Ctors) -->
 	{ Ctor = ctor(ExistQVars, Constraints, Name, Args) },
 	{ make_cons_id(Name, Args, TypeId, QualifiedConsId) },
-	{ assoc_list__values(Args, Types) },
-	{ ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Types, TypeId,
+	{ ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeId,
 				Context) },
 	%
 	% Insert the fully-qualified version of this cons_id into the
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.16
diff -u -d -r1.16 ml_code_util.m
--- compiler/ml_code_util.m	2000/06/05 00:27:24	1.16
+++ compiler/ml_code_util.m	2000/06/05 08:57:47
@@ -224,6 +224,22 @@
 
 %-----------------------------------------------------------------------------%
 %
+% Routines for dealing with fields
+%
+
+	% Given the user-specified field name, if any,
+	% and the argument number (starting from one),
+	% generate an MLDS field name.
+:- func ml_gen_field_name(maybe(ctor_field_name), int) = mlds__field_name.
+
+	% Succeed iff the specified type must be boxed when used as a field.
+	% We need to box types that are not word-sized, because the code
+	% for `arg' etc. in std_util.m rely on all arguments being word-sized.
+:- pred ml_must_box_field_type(prog_type, module_info).
+:- mode ml_must_box_field_type(in, in) is semidet.
+
+%-----------------------------------------------------------------------------%
+%
 % Routines for handling success and failure
 %
 
@@ -1098,6 +1114,37 @@
 	Abstractness = concrete,
 	MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
 		Virtuality, Finality, Constness, Abstractness).
+
+%-----------------------------------------------------------------------------%
+%
+% Code for dealing with fields
+%
+
+	% Given the user-specified field name, if any,
+	% and the argument number (starting from one),
+	% generate an MLDS field name.
+	%
+ml_gen_field_name(MaybeFieldName, ArgNum) = FieldName :-
+	%
+	% If the programmer specified a field name, we use that,
+	% otherwise we just use `F' followed by the field number.
+	%
+	(
+		MaybeFieldName = yes(QualifiedFieldName),
+		unqualify_name(QualifiedFieldName, FieldName)
+	;
+		MaybeFieldName = no,
+		FieldName = string__format("F%d", [i(ArgNum)])
+	).
+
+	% Succeed iff the specified type must be boxed when used as a field.
+	% We need to box types that are not word-sized, because the code
+	% for `arg' etc. in std_util.m rely on all arguments being word-sized.
+ml_must_box_field_type(Type, ModuleInfo) :-
+	classify_type(Type, ModuleInfo, Category),
+	( Category = float_type
+	; Category = char_type
+	).
 
 %-----------------------------------------------------------------------------%
 %
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.26
diff -u -d -r1.26 mlds.m
--- compiler/mlds.m	2000/05/31 06:04:04	1.26
+++ compiler/mlds.m	2000/06/05 13:59:14
@@ -941,9 +941,17 @@
 	--->		% offset(N) represents the field
 			% at offset N Words.
 	 	offset(mlds__rval)
-	;		% named_field(Name) represents the field
-			% with the specified name.
-		named_field(mlds__fully_qualified_name(field_name))
+	;		% named_field(Name, CtorType) represents the field
+			% with the specified name.  The CtorType gives the
+			% MLDS type for this particular constructor.
+			% The type of the object is given by the PtrType
+			% in the field(..) lval; CtorType may either be
+			% the same as PtrType, or it may be a pointer to
+			% a derived class.  In the latter case, the
+			% MLDS->target code back-end is responsible
+			% for inserting a downcast from PtrType to CtorType
+			% before accessing the field.
+		named_field(mlds__fully_qualified_name(field_name), mlds__type)
 	.
 
 :- type field_name == string.
@@ -967,7 +975,7 @@
 	--->	field(maybe(mlds__tag), mlds__rval, field_id, 
 			mlds__type, mlds__type)
 				% field(Tag, Address, FieldName, FieldType,
-				%	ClassType)
+				%	PtrType)
 				% selects a field of a compound term.
 				% Address is a tagged pointer to a cell
 				% on the heap; the offset into the cell
@@ -978,8 +986,8 @@
 				% it is known, since this will lead to
 				% faster code.
 				% The FieldType is the type of the field.
-				% The ClassType is the type of the object from
-				% which we are fetching the field.
+				% The PtrType is the type of the pointer
+				% from which we are fetching the field.
 				%
 				% Note that currently we store all fields
 				% of objects created with new_object
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.37
diff -u -d -r1.37 mlds_to_c.m
--- compiler/mlds_to_c.m	2000/06/05 02:42:41	1.37
+++ compiler/mlds_to_c.m	2000/06/05 14:49:42
@@ -1157,7 +1157,7 @@
 		% actual enumeration type as a comment.
 		%
 		io__write_string("MR_Integer /* actually `enum "),
-		mlds_output_fully_qualified(Name, io__write_string),
+		mlds_output_fully_qualified(Name, mlds_output_mangled_name),
 		io__format("_%d_e", [i(Arity)]),
 		io__write_string("' */")
 	;
@@ -1165,7 +1165,7 @@
 		% since don't use these types directly, we only
 		% use pointers to them.
 		io__write_string("struct "),
-		mlds_output_fully_qualified(Name, io__write_string),
+		mlds_output_fully_qualified(Name, mlds_output_mangled_name),
 		io__format("_%d_s", [i(Arity)])
 	).
 mlds_output_type_prefix(mlds__ptr_type(Type)) -->
@@ -2038,28 +2038,34 @@
 	io__write_string(", "),
 	mlds_output_rval(OffsetRval),
 	io__write_string("))").
-mlds_output_lval(field(MaybeTag, PtrRval, named_field(FieldId), _, _)) -->
+mlds_output_lval(field(MaybeTag, PtrRval, named_field(FieldName, CtorType),
+		_FieldType, _PtrType)) -->
+	% XXX we shouldn't bother with this cast in the case where
+	% PtrType == CtorType
+	io__write_string("(("),
+	mlds_output_type(CtorType),
+	io__write_string(") "),
 	( { MaybeTag = yes(0) } ->
 		( { PtrRval = mem_addr(Lval) } ->
-			mlds_output_bracketed_lval(Lval),
-			io__write_string(".")
+			mlds_output_lval(Lval),
+			io__write_string(").")
 		;
 			mlds_output_bracketed_rval(PtrRval),
-			io__write_string("->")
+			io__write_string(")->")
 		)
 	;
 		( { MaybeTag = yes(Tag) } ->
 			io__write_string("MR_body("),
-			mlds_output_tag(Tag),
-			io__write_string(", ")
+			mlds_output_rval(PtrRval),
+			io__write_string(", "),
+			mlds_output_tag(Tag)
 		;
-			io__write_string("MR_strip_tag(")
+			io__write_string("MR_strip_tag("),
+			mlds_output_rval(PtrRval)
 		),
-		mlds_output_rval(PtrRval),
-		io__write_string(")"),
-		io__write_string("->")
+		io__write_string("))->")
 	),
-	mlds_output_fully_qualified(FieldId, io__write_string).
+	mlds_output_fully_qualified(FieldName, mlds_output_mangled_name).
 mlds_output_lval(mem_ref(Rval, _Type)) -->
 	io__write_string("*"),
 	mlds_output_bracketed_rval(Rval).
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.8
diff -u -d -r1.8 ml_elim_nested.m
--- compiler/ml_elim_nested.m	2000/05/31 06:04:11	1.8
+++ compiler/ml_elim_nested.m	2000/06/05 14:00:19
@@ -273,11 +273,12 @@
 		%
 		QualVarName = qual(ModuleName, VarName),
 		EnvModuleName = ml_env_module_name(ClassType),
-		FieldName = named_field(qual(EnvModuleName, VarName)),
+		FieldName = named_field(qual(EnvModuleName, VarName),
+			mlds__ptr_type(ClassType)),
 		Tag = yes(0),
 		EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
 		EnvArgLval = field(Tag, EnvPtr, FieldName, FieldType, 
-			ClassType),
+			mlds__ptr_type(ClassType)),
 		ArgRval = lval(var(QualVarName)),
 		AssignToEnv = assign(EnvArgLval, ArgRval),
 		CodeToCopyArg = mlds__statement(atomic(AssignToEnv), Context),
@@ -834,8 +835,8 @@
 :- pred fixup_lval(mlds__lval, mlds__lval, elim_info, elim_info).
 :- mode fixup_lval(in, out, in, out) is det.
 
-fixup_lval(field(MaybeTag, Rval0, FieldId, FieldType, ClassType), 
-		field(MaybeTag, Rval, FieldId, FieldType, ClassType)) --> 
+fixup_lval(field(MaybeTag, Rval0, FieldId, FieldType, PtrType), 
+		field(MaybeTag, Rval, FieldId, FieldType, PtrType)) --> 
 	fixup_rval(Rval0, Rval).
 fixup_lval(mem_ref(Rval0, Type), mem_ref(Rval, Type)) --> 
 	fixup_rval(Rval0, Rval).
@@ -874,7 +875,8 @@
 	->
 		EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
 		EnvModuleName = ml_env_module_name(ClassType),
-		FieldName = named_field(qual(EnvModuleName, ThisVarName)),
+		FieldName = named_field(qual(EnvModuleName, ThisVarName),
+			mlds__ptr_type(ClassType)),
 		Tag = yes(0),
 		Lval = field(Tag, EnvPtr, FieldName, FieldType, ClassType)
 	;
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.2
diff -u -d -r1.2 ml_type_gen.m
--- compiler/ml_type_gen.m	2000/06/01 08:57:35	1.2
+++ compiler/ml_type_gen.m	2000/06/06 03:47:06
@@ -39,7 +39,7 @@
 %-----------------------------------------------------------------------------%
 
 :- implementation.
-:- import_module hlds_pred, prog_data, prog_util.
+:- import_module hlds_pred, prog_data, prog_util, type_util.
 :- import_module ml_code_util.
 :- import_module globals, options.
 
@@ -188,15 +188,38 @@
 	%
 	%	class <ClassName> {
 	%	public:
-	%		int data_tag;
-	%		/* constants used for data_tag */
-	%		static const int <ctor1> = 0;
-	%		static const int <ctor2> = 1;
+	% #if some_but_not_all_ctors_use_secondary_tag
+	%		/* A nested derived class for the secondary tag */
+	%		class tag_type : public <ClassName> {
+	%		public:
+	% #endif
+	% #if some_ctors_use_secondary_tag
+	%			int data_tag;
+	%   #if 0
+	%   /*
+	%   ** XXX we don't yet bother with these;
+	%   ** mlds_to_c.m doesn't support static members.
+	%   */
+	%			/* constants used for data_tag */
+	%			static const int <ctor1> = 0;
+	%			static const int <ctor2> = 1;
+	%   #endif
+	% #endif
+	% #if some_but_not_all_ctors_use_secondary_tag
+	%		};
+	% #endif
 	%		...
 	%		/*
 	%		** Derived classes, one for each constructor;
 	%		** these are generated as nested classes to
 	%		** avoid name clashes.
+	%		** These will derive either directly from
+	%		** <ClassName> or from <ClassName>::tag_type
+	%		** (which in turn derives from <ClassName>),
+	%		** depending on whether they need a secondary
+	%		** tag.  If all the ctors for a type need a
+	%		** secondary tag, we put the secondary tag members
+	%		** directly in the base class.
 	%		*/
 	%		class <ctor1> : public <ClassName> {
 	%		public:
@@ -208,7 +231,7 @@
 	%			MR_Word F2;
 	%			...
 	%		};
-	%		class <ctor2> : public <ClassName> {
+	%		class <ctor2> : public <ClassName>::tag_type {
 	%		public:
 	%			...
 	%		};
@@ -220,27 +243,70 @@
 		mlds__defns, mlds__defns).
 :- mode ml_gen_du_parent_type(in, in, in, in, in, in, in, out) is det.
 
-ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn, Ctors, _TagValues,
+ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn, Ctors, TagValues,
 		MaybeEqualityMembers, MLDS_Defns0, MLDS_Defns) :-
 	hlds_data__get_type_defn_context(TypeDefn, Context),
 	MLDS_Context = mlds__make_context(Context),
 
 	% generate the class name
-	ml_gen_type_name(TypeId, qual(_, MLDS_ClassName), MLDS_ClassArity),
+	ml_gen_type_name(TypeId, QualBaseClassName, BaseClassArity),
+	BaseClassId = mlds__class_type(QualBaseClassName, BaseClassArity,
+		mlds__class),
+	QualBaseClassName = qual(BaseClassModuleName, BaseClassName),
+	BaseClassQualifier = mlds__append_class_qualifier(
+		BaseClassModuleName, BaseClassName, BaseClassArity),
 
-	% generate the class members
-	TagMember = ml_gen_tag_member("data_tag", Context),
-	TagConstMembers = [],
-	% XXX we don't yet bother with these;
-	% mlds_to_c.m doesn't support static members.
-	%	TagConstMembers = list__condense(list__map(
-	% 		ml_gen_tag_constant(Context, TagValues), Ctors)),
-	Members0 = list__append(MaybeEqualityMembers,
-		[TagMember|TagConstMembers]),
+	(
+		%
+		% If none of the constructors for this type need
+		% a secondary tag, then we don't need the
+		% members for the secondary tag.
+		%
+		\+ (some [Ctor] (
+			list__member(Ctor, Ctors),
+			ml_uses_secondary_tag(TagValues, Ctor, _)
+		))
+	->
+		TagMembers = [],
+		TagClassId = BaseClassId
+	;
+		%
+		% Generate the members for the secondary tag.
+		%
+		TagDataMember = ml_gen_tag_member("data_tag", Context),
+		TagConstMembers = [],
+		% XXX we don't yet bother with these;
+		% mlds_to_c.m doesn't support static members.
+		%	TagConstMembers = list__condense(list__map(
+		% 		ml_gen_tag_constant(Context, TagValues), Ctors)),
+		TagMembers0 = [TagDataMember | TagConstMembers],
+
+		%
+		% If all the constructors for this type need a
+		% secondary tag, then we put the secondary tag members
+		% directly in the base class, otherwise we put it in
+		% a separate nested derived class.
+		%
+		(
+			(all [Ctor] (
+				list__member(Ctor, Ctors)
+			=>
+				ml_uses_secondary_tag(TagValues, Ctor, _)
+			))
+		->
+			TagMembers = TagMembers0,
+			TagClassId = BaseClassId
+		;
+			ml_gen_secondary_tag_class(MLDS_Context,
+				BaseClassQualifier, BaseClassId, TagMembers0,
+				TagTypeDefn, TagClassId),
+			TagMembers = [TagTypeDefn]
+		)
+	),
 
 	% generate the nested derived classes
-	list__foldl(ml_gen_du_ctor_type(ModuleInfo, TypeId, TypeDefn), Ctors,
-		Members0, Members),
+	list__foldl(ml_gen_du_ctor_type(ModuleInfo, BaseClassId, TagClassId,
+		TypeDefn, TagValues), Ctors, [], CtorMembers),
 
 	% the base class doesn't import or inherit anything
 	Imports = [],
@@ -248,7 +314,9 @@
 	Implements = [],
 
 	% put it all together
-	MLDS_TypeName = type(MLDS_ClassName, MLDS_ClassArity),
+	Members = list__condense([MaybeEqualityMembers, TagMembers,
+		CtorMembers]),
+	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)),
@@ -257,6 +325,9 @@
 	
 	MLDS_Defns = [MLDS_TypeDefn | MLDS_Defns0].
 
+	%
+	% Generate the declaration for the field that holds the secondary tag.
+	%
 :- func ml_gen_tag_member(mlds__var_name, prog_context) = mlds__defn.
 ml_gen_tag_member(Name, Context) =
 	mlds__defn(data(var(Name)),
@@ -271,10 +342,7 @@
 	%
 	% Check if this constructor uses a secondary tag.
 	%
-	Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
-	list__length(Args, Arity),
-	map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
-	( TagVal = shared_remote_tag(_PrimaryTag, SecondaryTag) ->
+	( ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag) ->
 		%
 		% Generate an MLDS definition for this secondary
 		% tag constant.  We do this mainly for readability
@@ -283,6 +351,7 @@
 		% useful in the `--tags none' case, where there
 		% will be no primary tags.
 		%
+		Ctor = ctor(_ExistQTVars, _Constraints, Name, _Args),
 		unqualify_name(Name, UnqualifiedName),
 		ConstValue = const(int_const(SecondaryTag)),
 		MLDS_Defn = mlds__defn(data(var(UnqualifiedName)),
@@ -295,11 +364,63 @@
 		MLDS_Defns = []
 	).
 
-:- pred ml_gen_du_ctor_type(module_info, type_id, hlds_type_defn, constructor,
+	%
+	% Check if this constructor uses a secondary tag,
+	% and if so, return the secondary tag value.
+	%
+:- pred ml_uses_secondary_tag(cons_tag_values, constructor, int).
+:- mode ml_uses_secondary_tag(in, in, out) is semidet.
+
+ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag) :-
+	Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
+	list__length(Args, Arity),
+	map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
+	TagVal = shared_remote_tag(_PrimaryTag, SecondaryTag).
+
+	%
+	% Generate a definition for the class used for the secondary tag
+	% type.  This is needed for discriminated unions for which some
+	% but not all constructors use secondary tags.
+	%
+:- pred ml_gen_secondary_tag_class(mlds__context, mlds_module_name,
+		mlds__class_id, mlds__defns, mlds__defn, mlds__class_id).
+:- mode ml_gen_secondary_tag_class(in, in, in, in, out, out) is det.
+
+ml_gen_secondary_tag_class(MLDS_Context, BaseClassQualifier, BaseClassId, Members,
+		MLDS_TypeDefn, SecondaryTagClassId) :-
+	% Generate the class name for the secondary tag class.
+	% Note: the secondary tag class is nested inside the
+	% base class for this type.
+	UnqualClassName = "tag_type",
+	ClassName = qual(BaseClassQualifier, UnqualClassName),
+	ClassArity = 0,
+	SecondaryTagClassId = mlds__class_type(ClassName, ClassArity,
+		mlds__class),
+
+	% the secondary tag class inherits the base class for this type
+	Imports = [],
+	Inherits = [BaseClassId],
+	Implements = [],
+
+	% put it all together
+	MLDS_TypeName = type(UnqualClassName, ClassArity),
+	MLDS_TypeFlags = ml_gen_type_decl_flags,
+	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
+		Imports, Inherits, Implements, Members)),
+	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
+		MLDS_TypeDefnBody).
+	
+	%
+	% 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,
 		mlds__defns, mlds__defns).
-:- mode ml_gen_du_ctor_type(in, in, in, in, in, out) is det.
+:- mode ml_gen_du_ctor_type(in, in, in, in, in, in, in, out) is det.
 
-ml_gen_du_ctor_type(ModuleInfo, TypeId, TypeDefn, Ctor,
+ml_gen_du_ctor_type(ModuleInfo, BaseClassId, SecondaryTagClassId,
+		TypeDefn, ConsTagValues, Ctor,
 		MLDS_Defns0, MLDS_Defns) :-
 	Ctor = ctor(_ExistQTVars, _Constraints, CtorName, Args),
 
@@ -308,12 +429,6 @@
 	hlds_data__get_type_defn_context(TypeDefn, Context),
 	MLDS_Context = mlds__make_context(Context),
 
-	% generate the base class name
-	ClassKind = mlds__class,
-	ml_gen_type_name(TypeId, BaseClassName, BaseClassArity),
-	BaseClassId = mlds__class_type(BaseClassName, BaseClassArity,
-		ClassKind),
-
 	% generate the class name for this constructor
 	unqualify_name(CtorName, CtorClassName),
 	list__length(Args, CtorArity),
@@ -323,15 +438,22 @@
 	list__map_foldl(ml_gen_du_ctor_member(ModuleInfo, Context),
 		Args, Members, 1, _),
 
-	% we inherit the base class for this type
+	% 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
+	;
+		ParentClassId = BaseClassId
+	),
 	Imports = [],
-	Inherits = [BaseClassId],
+	Inherits = [ParentClassId],
 	Implements = [],
 
 	% put it all together
 	MLDS_TypeName = type(CtorClassName, CtorArity),
 	MLDS_TypeFlags = ml_gen_type_decl_flags,
-	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(ClassKind,
+	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
 		Imports, Inherits, Implements, Members)),
 	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
 		MLDS_TypeDefnBody),
@@ -344,15 +466,14 @@
 
 ml_gen_du_ctor_member(ModuleInfo, Context, MaybeFieldName - Type, MLDS_Defn,
 		ArgNum0, ArgNum) :-
-	(
-		MaybeFieldName = yes(QualifiedFieldName),
-		unqualify_name(QualifiedFieldName, FieldName)
+	FieldName = ml_gen_field_name(MaybeFieldName, ArgNum0),
+	( ml_must_box_field_type(Type, ModuleInfo) ->
+		MLDS_Type = mlds__generic_type
 	;
-		MaybeFieldName = no,
-		FieldName = string__format("F%d", [i(ArgNum0)])
+		MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type)
 	),
-	MLDS_Defn = ml_gen_var_decl(FieldName, Type,
-		mlds__make_context(Context), ModuleInfo),
+	MLDS_Defn = ml_gen_mlds_var_decl(var(FieldName), MLDS_Type,
+		mlds__make_context(Context)),
 	ArgNum = ArgNum0 + 1.
 
 %-----------------------------------------------------------------------------%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.13
diff -u -d -r1.13 ml_unify_gen.m
--- compiler/ml_unify_gen.m	2000/05/31 12:58:14	1.13
+++ compiler/ml_unify_gen.m	2000/06/06 03:39:57
@@ -75,7 +75,7 @@
 :- implementation.
 
 :- import_module hlds_module, hlds_out, builtin_ops.
-:- import_module ml_call_gen, prog_util, type_util, mode_util.
+:- import_module ml_call_gen, ml_type_gen, prog_util, type_util, mode_util.
 :- import_module rtti.
 :- import_module code_util. % XXX needed for `code_util__cons_id_to_tag'.
 :- import_module globals, options.
@@ -1153,16 +1153,16 @@
 		{ Tag = unshared_tag(UnsharedTag) },
 		ml_gen_var(Var, VarLval),
 		ml_variable_types(Args, ArgTypes),
-		ml_field_types(Type, ConsId, ArgTypes, FieldTypes),
-		ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, Type,
-			VarLval, 0, UnsharedTag, Context, MLDS_Statements)
+		ml_field_names_and_types(Type, ConsId, ArgTypes, Fields),
+		ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, Type,
+			VarLval, 0, 1, UnsharedTag, Context, MLDS_Statements)
 	;
 		{ Tag = shared_remote_tag(PrimaryTag, _SecondaryTag) },
 		ml_gen_var(Var, VarLval),
 		ml_variable_types(Args, ArgTypes),
-		ml_field_types(Type, ConsId, ArgTypes, FieldTypes),
-		ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, Type,
-			VarLval, 1, PrimaryTag, Context, MLDS_Statements)
+		ml_field_names_and_types(Type, ConsId, ArgTypes, Fields),
+		ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, Type,
+			VarLval, 1, 1, PrimaryTag, Context, MLDS_Statements)
 	;
 		{ Tag = shared_local_tag(_Bits1, _Num1) },
 		{ MLDS_Statements = [] } % if this is det, then nothing happens
@@ -1176,11 +1176,11 @@
 	% the types of the actual arguments can be an instance of the
 	% field types.
 	%
-:- pred ml_field_types(prog_type, cons_id, list(prog_type), list(prog_type),
-		ml_gen_info, ml_gen_info).
-:- mode ml_field_types(in, in, in, out, in, out) is det.
+:- pred ml_field_names_and_types(prog_type, cons_id, list(prog_type),
+		list(constructor_arg), ml_gen_info, ml_gen_info).
+:- mode ml_field_names_and_types(in, in, in, out, in, out) is det.
 
-ml_field_types(Type, ConsId, ArgTypes, FieldTypes) -->
+ml_field_names_and_types(Type, ConsId, ArgTypes, Fields) -->
 	%
 	% Lookup the field types for the arguments of this cons_id
 	%
@@ -1188,29 +1188,32 @@
 	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
 	{ type_util__get_type_and_cons_defn(ModuleInfo, Type, ConsId,
 			_TypeDefn, ConsDefn) },
-	{ ConsDefn = hlds_cons_defn(_, _, FieldTypes0, _, _) },
+	{ ConsDefn = hlds_cons_defn(_, _, Fields0, _, _) },
 	%
-	% Add the types for any type_infos and/or typeclass_infos
+	% Add the fields for any type_infos and/or typeclass_infos
 	% inserted for existentially quantified data types.
 	% For these, we just copy the types from the ArgTypes.
 	%
 	{ NumArgs = list__length(ArgTypes) },
-	{ NumFieldTypes0 = list__length(FieldTypes0) },
+	{ NumFieldTypes0 = list__length(Fields0) },
 	{ NumExtraTypes = NumArgs - NumFieldTypes0 },
 	{ ExtraFieldTypes = list__take_upto(NumExtraTypes, ArgTypes) },
-	{ FieldTypes = list__append(ExtraFieldTypes, FieldTypes0) }.
+	{ ExtraFields = list__map(func(FieldType) = no - FieldType,
+		ExtraFieldTypes) },
+	{ Fields = list__append(ExtraFields, Fields0) }.
 
-:- pred ml_gen_unify_args(prog_vars, list(uni_mode), list(prog_type),
-		list(prog_type), prog_type, mlds__lval, int, mlds__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, out, in, out)
-		is det.
+:- 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,
+		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(Args, Modes, ArgTypes, FieldTypes, VarType, VarLval, ArgNum,
-		PrimaryTag, Context, MLDS_Statements) -->
+ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, VarType, VarLval,
+		Offset, ArgNum, PrimaryTag, Context, MLDS_Statements) -->
 	(
-		ml_gen_unify_args_2(Args, Modes, ArgTypes, FieldTypes, VarType,
-			VarLval, ArgNum, PrimaryTag, Context,
+		ml_gen_unify_args_2(ConsId, Args, Modes, ArgTypes, Fields,
+			VarType, VarLval, Offset, ArgNum, PrimaryTag, Context,
 			[], MLDS_Statements0)
 	->
 		{ MLDS_Statements = MLDS_Statements0 }
@@ -1218,55 +1221,103 @@
 		{ error("ml_gen_unify_args: length mismatch") }
 	).
 
-:- pred ml_gen_unify_args_2(prog_vars, list(uni_mode), list(prog_type),
-		list(prog_type), prog_type, mlds__lval, int, mlds__tag,
-		prog_context, mlds__statements, mlds__statements,
+:- 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,
 		ml_gen_info, ml_gen_info).
-:- mode ml_gen_unify_args_2(in, in, in, in, in, in, in, in, in, in, out,
+:- mode ml_gen_unify_args_2(in, in, in, in, in, in, in, in, in, in, in, in, out,
 		in, out) is semidet.
 
-ml_gen_unify_args_2([], [], [], _, _, _, _, _, _, Statements, Statements) -->
-	[].
-ml_gen_unify_args_2([Arg|Args], [Mode|Modes], [ArgType|ArgTypes],
-		[FieldType|FieldTypes], VarType, VarLval, ArgNum, PrimaryTag,
+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,
 		Context, MLDS_Statements0, MLDS_Statements) -->
+	{ Offset1 = Offset + 1 },
 	{ ArgNum1 = ArgNum + 1 },
-	ml_gen_unify_args_2(Args, Modes, ArgTypes, FieldTypes, VarType,
-		VarLval, ArgNum1, PrimaryTag, Context,
+	ml_gen_unify_args_2(ConsId, Args, Modes, ArgTypes, Fields, VarType,
+		VarLval, Offset1, ArgNum1, PrimaryTag, Context,
 		MLDS_Statements0, MLDS_Statements1),
-	ml_gen_unify_arg(Arg, Mode, ArgType, FieldType, VarType, VarLval,
-		ArgNum, PrimaryTag, Context,
+	ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
+		Offset, ArgNum, PrimaryTag, Context,
 		MLDS_Statements1, MLDS_Statements).
 
-:- pred ml_gen_unify_arg(prog_var, uni_mode, prog_type, prog_type, prog_type,
-		mlds__lval, int, mlds__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, out, in, out)
-		is det.
+:- pred ml_gen_unify_arg(cons_id, prog_var, uni_mode, prog_type,
+		constructor_arg, prog_type, mlds__lval, int, int, mlds__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(Arg, Mode, ArgType, _FieldType, VarType, VarLval, ArgNum,
-		PrimaryTag, Context, MLDS_Statements0, MLDS_Statements) -->
-	%
-	% With the current low-level data representation,
-	% we store all fields as boxed, so we ignore _FieldType
-	% and instead generate a polymorphic type BoxedFieldType
-	% here.  This type is used in the calls to
-	% ml_gen_box_or_unbox_rval below to ensure that we
-	% box values when storing them into fields and
-	% unbox them when extracting them from fields.
-	%
-	{ varset__init(TypeVarSet0) },
-	{ varset__new_var(TypeVarSet0, TypeVar, _TypeVarSet) },
-	{ type_util__var(BoxedFieldType, TypeVar) },
+ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
+		Offset, ArgNum, PrimaryTag, Context,
+		MLDS_Statements0, MLDS_Statements) -->
+	{ Field = MaybeFieldName - FieldType },
+	=(Info),
+	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
+	{ module_info_globals(ModuleInfo, Globals) },
+	{ globals__lookup_bool_option(Globals, highlevel_data,
+		HighLevelData) },
+	{
+		%
+		% With the low-level data representation,
+		% we access all fields using offsets.
+		%
+		HighLevelData = no,
+		FieldId = offset(const(int_const(Offset)))
+	;
+		%
+		% With the high-level data representation,
+		% we always used named fields.
+		% 
+		HighLevelData = yes,
+		FieldName = ml_gen_field_name(MaybeFieldName, ArgNum),
+		(
+			ConsId = cons(ConsName, ConsArity)
+		->
+			unqualify_name(ConsName, UnqualConsName),
+			FieldId = ml_gen_field_id(VarType,
+				UnqualConsName, ConsArity, FieldName)
+		;
+			error("ml_gen_unify_args: invalid cons_id")
+		)
+	},
+	{
+		%
+		% With the low-level data representation,
+		% we store all fields as boxed, so we ignore the field
+		% type from `Field' and instead generate a polymorphic
+		% type BoxedFieldType which we use for the type of the field.
+		% This type is used in the calls to
+		% ml_gen_box_or_unbox_rval below to ensure that we
+		% box values when storing them into fields and
+		% unbox them when extracting them from fields.
+		%
+		% With the high-level data representation,
+		% we don't box everything, but we still need
+		% to box floating point fields.
+		%
+		(
+			HighLevelData = no
+		;
+			HighLevelData = yes,
+			ml_must_box_field_type(FieldType, ModuleInfo)
+		)
+	->
+		varset__init(TypeVarSet0),
+		varset__new_var(TypeVarSet0, TypeVar, _TypeVarSet),
+		type_util__var(BoxedFieldType, TypeVar)
+	;
+		BoxedFieldType = FieldType
+	},
 
-	%
-	% Generate lvals for the LHS and the RHS
-	%
-	{ FieldId = offset(const(int_const(ArgNum))) },
-	ml_gen_type(BoxedFieldType, MLDS_FieldType),
+		%
+		% Generate lvals for the LHS and the RHS
+		%
 	ml_gen_type(VarType, MLDS_VarType),
+	ml_gen_type(BoxedFieldType, MLDS_BoxedFieldType),
 	{ FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId,
-		MLDS_FieldType, MLDS_VarType) },
+		MLDS_BoxedFieldType, MLDS_VarType) },
 	ml_gen_var(Arg, ArgLval),
 
 	%
@@ -1397,10 +1448,9 @@
 	ml_gen_var(Var, VarLval),
 	ml_variable_type(Var, Type),
 	ml_cons_id_to_tag(ConsId, Type, Tag),
-	ml_gen_type(Type, MLDS_Type),
 	=(Info),
 	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
-	{ TagTestExpression = ml_gen_tag_test_rval(Tag, MLDS_Type, ModuleInfo,
+	{ TagTestExpression = ml_gen_tag_test_rval(Tag, Type, ModuleInfo,
 		lval(VarLval)) },
 	{ TagTestDecls = [] },
 	{ TagTestStatements = [] }.
@@ -1410,7 +1460,7 @@
 	%	true if VarRval has the specified Tag and false otherwise.
 	%	VarType is the type of VarRval. 
 	%
-:- func ml_gen_tag_test_rval(cons_tag, mlds__type, module_info, mlds__rval)
+:- func ml_gen_tag_test_rval(cons_tag, prog_type, module_info, mlds__rval)
 	= mlds__rval.
 
 ml_gen_tag_test_rval(string_constant(String), _, _, Rval) =
@@ -1439,19 +1489,29 @@
 ml_gen_tag_test_rval(unshared_tag(UnsharedTag), _, _, Rval) =
 	binop(eq, unop(std_unop(tag), Rval),
 		  unop(std_unop(mktag), const(int_const(UnsharedTag)))).
-ml_gen_tag_test_rval(shared_remote_tag(PrimaryTag, SecondaryTag), MLDS_VarType,
-		ModuleInfo, Rval) = TagTest :-
-	SecondaryTagTest = binop(eq,
-		% Note: with the current low-level data representation,
+ml_gen_tag_test_rval(shared_remote_tag(PrimaryTagVal, SecondaryTagVal),
+		VarType, ModuleInfo, Rval) = TagTest :-
+	MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
+	module_info_globals(ModuleInfo, Globals),
+	globals__lookup_bool_option(Globals, highlevel_data, HighLevelData),
+	( HighLevelData = no ->
+		% Note: with the low-level data representation,
 		% all fields -- even the secondary tag -- are boxed,
 		% and so we need to unbox (i.e. cast) it back to the
 		% right type here.
-		unop(unbox(mlds__native_int_type),
-			lval(field(yes(PrimaryTag), Rval,
-			offset(const(int_const(0))),
-			mlds__generic_type, MLDS_VarType))),
-		const(int_const(SecondaryTag))),
-	module_info_globals(ModuleInfo, Globals),
+		SecondaryTagField = 
+			unop(unbox(mlds__native_int_type),
+				lval(field(yes(PrimaryTagVal), Rval,
+				offset(const(int_const(0))),
+				mlds__generic_type, MLDS_VarType)))
+	;
+		FieldId = ml_gen_field_id(VarType, "tag_type", 0,
+			"data_tag"),
+		SecondaryTagField = lval(field(yes(PrimaryTagVal), Rval,
+			FieldId, mlds__native_int_type, MLDS_VarType))
+	),
+	SecondaryTagTest = binop(eq, SecondaryTagField,
+		const(int_const(SecondaryTagVal))),
 	globals__lookup_int_option(Globals, num_tag_bits, NumTagBits),
 	( NumTagBits = 0 ->
 		% no need to test the primary tag
@@ -1459,11 +1519,35 @@
 	;
 		PrimaryTagTest = binop(eq,
 			unop(std_unop(tag), Rval),
-			unop(std_unop(mktag), const(int_const(PrimaryTag)))), 
+			unop(std_unop(mktag),
+				const(int_const(PrimaryTagVal)))), 
 		TagTest = binop(and, PrimaryTagTest, SecondaryTagTest)
 	).
-ml_gen_tag_test_rval(shared_local_tag(Bits, Num), MLDS_VarType, _, Rval) =
-	binop(eq, Rval,
+ml_gen_tag_test_rval(shared_local_tag(Bits, Num), VarType, ModuleInfo, Rval) =
+		TestRval :-
+	MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
+	TestRval = binop(eq, Rval,
 		  unop(cast(MLDS_VarType), mkword(Bits,
 		  	unop(std_unop(mkbody), const(int_const(Num)))))).
 
+:- func ml_gen_field_id(prog_type, mlds__class_name, arity, mlds__field_name) =
+	mlds__field_id.
+
+ml_gen_field_id(Type, ClassName, ClassArity, FieldName) = FieldId :-
+	(
+		type_to_type_id(Type, TypeId, _)
+	->
+		ml_gen_type_name(TypeId,
+			qual(MLDS_Module, TypeName), TypeArity),
+		ClassQualifier = 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),
+		FieldId = named_field(QualifiedFieldName, ClassPtrType)
+	;
+		error("ml_gen_field_id: invalid type")
+	).
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.23
diff -u -d -r1.23 post_typecheck.m
--- compiler/post_typecheck.m	2000/05/09 02:44:28	1.23
+++ compiler/post_typecheck.m	2000/06/05 06:28:16
@@ -986,13 +986,14 @@
 
 	% Overloading resolution ignores the class constraints.
 	ConsDefn = hlds_cons_defn(ConsExistQVars, _,
-			ConsArgTypes, ConsTypeId, _),
+			ConsArgs, ConsTypeId, _),
 	ConsTypeId = TypeId,
 
 	module_info_types(ModuleInfo, Types),
 	map__search(Types, TypeId, TypeDefn),
 	hlds_data__get_type_defn_tvarset(TypeDefn, TypeTVarSet),
 
+	assoc_list__values(ConsArgs, ConsArgTypes),
 	arg_type_list_subsumes(TVarSet, ArgTypes,
 		TypeTVarSet, ConsExistQVars, ConsArgTypes).
 
@@ -1147,7 +1148,8 @@
 	%
 	type_util__get_type_and_cons_defn(ModuleInfo, TermType,
 		ConsId, TypeDefn, ConsDefn),
-	ConsDefn = hlds_cons_defn(ExistQVars, _, ArgTypes0, _, _),
+	ConsDefn = hlds_cons_defn(ExistQVars, _, Args, _, _),
+	assoc_list__values(Args, ArgTypes0),
 	( ExistQVars = [] ->
 		ArgTypes1 = ArgTypes0,
 		PredInfo = PredInfo0,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.276
diff -u -d -r1.276 typecheck.m
--- compiler/typecheck.m	2000/05/09 02:44:30	1.276
+++ compiler/typecheck.m	2000/06/05 06:29:42
@@ -4247,8 +4247,9 @@
 :- mode convert_cons_defn(typecheck_info_ui, in, out) is det.
 
 convert_cons_defn(TypeCheckInfo, HLDS_ConsDefn, ConsTypeInfo) :-
-	HLDS_ConsDefn = hlds_cons_defn(ExistQVars, ExistConstraints, ArgTypes,
+	HLDS_ConsDefn = hlds_cons_defn(ExistQVars, ExistConstraints, Args,
 				TypeId, Context),
+	assoc_list__values(Args, ArgTypes),
 	typecheck_info_get_types(TypeCheckInfo, Types),
 	map__lookup(Types, TypeId, TypeDefn),
 	hlds_data__get_type_defn_tvarset(TypeDefn, ConsTypeVarSet),
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.82
diff -u -d -r1.82 type_util.m
--- compiler/type_util.m	2000/05/09 02:44:29	1.82
+++ compiler/type_util.m	2000/06/05 06:56:59
@@ -371,7 +371,7 @@
 %-----------------------------------------------------------------------------%
 
 :- implementation.
-:- import_module bool, int, require, std_util, string, varset.
+:- import_module assoc_list, bool, int, require, std_util, string, varset.
 :- import_module prog_io, prog_io_goal, prog_util.
 
 type_util__type_id_module(_ModuleInfo, TypeName - _Arity, ModuleName) :-
@@ -685,8 +685,8 @@
 		type_util__do_get_type_and_cons_defn(ModuleInfo, VarType,
 			ConsId, TypeDefn, ConsDefn),
 		ConsDefn = hlds_cons_defn(ExistQVars0, _Constraints0,
-				ArgTypes0, _, _),
-		ArgTypes0 \= []
+				Args, _, _),
+		Args \= []
 	->
 		hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams),
 		term__term_list_to_var_list(TypeDefnParams, TypeDefnVars),
@@ -696,6 +696,7 @@
 	"type_util__get_cons_id_arg_types: existentially typed cons_id"),
 
 		map__from_corresponding_lists(TypeDefnVars, TypeArgs, TSubst),
+		assoc_list__values(Args, ArgTypes0),
 		term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes)
 	;
 		ArgTypes = []
@@ -718,7 +719,8 @@
 	% otherwise fail.
 type_util__get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :-
 	type_util__is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn),
-	ConsDefn = hlds_cons_defn(ExistQVars, Constraints, ArgTypes, _, _),
+	ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, _, _),
+	assoc_list__values(Args, ArgTypes),
 	module_info_types(ModuleInfo, Types),
 	type_to_type_id(VarType, TypeId, _),
 	map__lookup(Types, TypeId, TypeDefn),
-- 
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.

-- 
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
--------------------------------------------------------------------------