[m-rev.] diff: MLDS back-end fix needed for --grade il

[Fergus Henderson]

Estimated hours taken: 2
Branches: main

Fix a bug in the MLDS code generator that caused problems for the IL
back-end with --high-level-data.  The problem was that the MLDS code
generator was generating incorrect type annotations for the `data_tag'
field access (the secondary tag).

compiler/ml_type_gen.m:
	Export ml_uses_secondary_tag, for use by ml_unify_gen.m.

compiler/ml_unify_gen.m:
	When generating references to the "data_tag" field,
	don't qualify it with "tag_type"/0 unless some but not all
	of the constructors for that type use a secondary tag.
	This is needed to match the algorithm used by ml_type_gen.m
	to generate the types.

Workspace: /home/venus/fjh/ws-venus4/mercury
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.10
diff -u -d -r1.10 ml_type_gen.m
--- compiler/ml_type_gen.m	9 Jul 2001 15:55:04 -0000	1.10
+++ compiler/ml_type_gen.m	12 Aug 2001 22:35:44 -0000
@@ -22,7 +22,7 @@
 
 :- module ml_type_gen.
 :- interface.
-:- import_module prog_data, hlds_module, mlds.
+:- import_module prog_data, hlds_module, hlds_data, mlds.
 :- import_module io.
 
 	% Generate MLDS definitions for all the types in the HLDS.
@@ -53,11 +53,19 @@
 	% from normal members in that their finality is `final'.
 	%
 :- func ml_gen_special_member_decl_flags = mlds__decl_flags.
+
+	%
+	% ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag):
+	% 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.
+
 %-----------------------------------------------------------------------------%
 
 :- implementation.
 :- import_module hlds_pred, prog_data, prog_util, type_util, polymorphism.
-:- import_module hlds_data.
 :- import_module ml_code_util.
 :- import_module globals, options.
 
@@ -387,9 +395,6 @@
 	% 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),
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.39
diff -u -d -r1.39 ml_unify_gen.m
--- compiler/ml_unify_gen.m	13 Jul 2001 08:04:41 -0000	1.39
+++ compiler/ml_unify_gen.m	12 Aug 2001 22:56:43 -0000
@@ -1816,12 +1816,68 @@
 				offset(const(int_const(0))),
 				mlds__generic_type, MLDS_VarType)))
 	;
-		FieldId = ml_gen_field_id(VarType, "tag_type", 0,
-			"data_tag"),
+		FieldId = ml_gen_hl_tag_field_id(VarType, ModuleInfo),
 		SecondaryTagField = lval(field(yes(PrimaryTagVal), Rval,
 			FieldId, mlds__native_int_type, MLDS_VarType))
 	).
 
+	% Return the field_id for the "data_tag" field of the specified
+	% Mercury type, which holds the secondary tag.
+	%
+:- func ml_gen_hl_tag_field_id(prog_type, module_info) = mlds__field_id.
+
+ml_gen_hl_tag_field_id(Type, ModuleInfo) = FieldId :-
+	FieldName = "data_tag",
+
+	% Figure out the type name and arity
+	( type_to_type_id(Type, TypeId0, _) ->
+		TypeId = TypeId0
+	;
+		error("ml_gen_hl_tag_field_id: invalid type")
+	),
+	ml_gen_type_name(TypeId, qual(MLDS_Module, TypeName), TypeArity),
+
+	% Figure out whether this type has constructors both
+	% with and without secondary tags.  If so, then the
+	% secondary tag field is in a class "tag_type" that is
+	% derived from the base class for this type,
+	% rather than in the base class itself.
+	module_info_types(ModuleInfo, TypeTable),
+	TypeDefn = map__lookup(TypeTable, TypeId),
+	hlds_data__get_type_defn_body(TypeDefn, TypeDefnBody),
+	( TypeDefnBody = du_type(Ctors, TagValues, _, _) ->
+		(
+			(some [Ctor] (
+				list__member(Ctor, Ctors),
+				ml_uses_secondary_tag(TagValues, Ctor, _)
+			)),
+			(some [Ctor] (
+				list__member(Ctor, Ctors),
+				\+ ml_uses_secondary_tag(TagValues, Ctor, _)
+			))
+		->
+			ClassQualifier = mlds__append_class_qualifier(
+				MLDS_Module, TypeName, TypeArity),
+			ClassName = "tag_type",
+			ClassArity = 0
+		;
+			ClassQualifier = MLDS_Module,
+			ClassName = TypeName,
+			ClassArity = TypeArity
+		)
+	;
+		error("ml_gen_hl_tag_field_id: non-du type")
+	),
+
+	% Put it all together
+	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).
+
 :- func ml_gen_field_id(prog_type, mlds__class_name, arity, mlds__field_name) =
 	mlds__field_id.
 
@@ -1829,8 +1885,7 @@
 	(
 		type_to_type_id(Type, TypeId, _)
 	->
-		ml_gen_type_name(TypeId,
-			qual(MLDS_Module, TypeName), TypeArity),
+		ml_gen_type_name(TypeId, qual(MLDS_Module, TypeName), TypeArity),
 		ClassQualifier = mlds__append_class_qualifier(
 			MLDS_Module, TypeName, TypeArity),
 		QualClassName = qual(ClassQualifier, ClassName),

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