[m-rev.] diff: IL back-end: another --high-level-data fix

[Fergus Henderson]

Estimated hours taken: 1
Branches: main

compiler/mlds_to_il.m:
	Fix another bug with --high-level-data: insert appropriate "castclass"
	instructions before referencing a field of a derived class.

Workspace: /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.70
diff -u -d -r1.70 mlds_to_il.m
--- compiler/mlds_to_il.m	13 Aug 2001 03:12:11 -0000	1.70
+++ compiler/mlds_to_il.m	13 Aug 2001 03:51:17 -0000
@@ -45,8 +45,6 @@
 % [ ] Computed gotos need testing.
 % [ ] :- extern doesn't work -- it needs to be treated like pragma c code.
 % [ ] nested modules need testing
-% [ ] We generate too many castclasses, it would be good to check if we
-%     really to do it before generating it.  Same with isinst.
 % [ ] Implement pragma export.
 % [ ] Fix issues with abstract types so that we can implement C
 %     pointers as MR_Box rather than MR_Word.
@@ -1841,10 +1839,12 @@
 		{ StoreLvalInstrs = instr_node(stind(SimpleType)) } 
 	; { Lval = field(_MaybeTag, FieldRval, FieldNum, FieldType, 
 			ClassType) } -> 
-		{ FieldRef = get_fieldref(DataRep, FieldNum, FieldType,
-			ClassType) },
+		{ get_fieldref(DataRep, FieldNum, FieldType, ClassType,
+			FieldRef, CastClassInstrs) },
 		load(FieldRval, LoadMemRefInstrs),
-		{ StoreLvalInstrs = instr_node(stfld(FieldRef)) } 
+		{ StoreLvalInstrs = tree__list([
+			CastClassInstrs,
+			instr_node(stfld(FieldRef))]) } 
 	;
 		{ LoadMemRefInstrs = empty },
 		store(Lval, StoreLvalInstrs)
@@ -1885,15 +1885,17 @@
 			{ SimpleFieldType = mlds_type_to_ilds_simple_type(
 				DataRep, FieldType) },
 			load(OffSet, OffSetLoadInstrs),
+			{ CastClassInstrs = empty },
 			{ LoadInstruction = ldelem(SimpleFieldType) }
 		;
-			{ FieldRef = get_fieldref(DataRep, FieldNum, FieldType,
-				ClassType) },
+			{ get_fieldref(DataRep, FieldNum, FieldType, ClassType,
+				FieldRef, CastClassInstrs) },
 			{ LoadInstruction = ldfld(FieldRef) },
 			{ OffSetLoadInstrs = empty }
 		),
 		{ Instrs = tree__list([
 				RvalLoadInstrs, 
+				CastClassInstrs,
 				OffSetLoadInstrs, 
 				instr_node(LoadInstruction)
 				]) }
@@ -1967,11 +1969,12 @@
 			Instrs = instr_node(ldsfld(FieldRef))
 		}
 	; { Lval = field(_MaybeTag, Rval, FieldNum, FieldType, ClassType) },
-		{ FieldRef = get_fieldref(DataRep, FieldNum, FieldType,
-			ClassType) },
+		{ get_fieldref(DataRep, FieldNum, FieldType, ClassType,
+			FieldRef, CastClassInstrs) },
 		load(Rval, RvalLoadInstrs),
 		{ Instrs = tree__list([
 			RvalLoadInstrs, 
+			CastClassInstrs,
 			instr_node(ldflda(FieldRef))
 			]) }
 	; { Lval = mem_ref(_, _) },
@@ -1986,9 +1989,13 @@
 
 store(field(_MaybeTag, Rval, FieldNum, FieldType, ClassType), Instrs) -->
 	DataRep =^ il_data_rep,
-	{ FieldRef = get_fieldref(DataRep, FieldNum, FieldType, ClassType) },
+	{ get_fieldref(DataRep, FieldNum, FieldType, ClassType,
+		FieldRef, CastClassInstrs) },
 	load(Rval, RvalLoadInstrs),
-	{ Instrs = tree__list([RvalLoadInstrs, instr_node(stfld(FieldRef))]) }.
+	{ Instrs = tree__list([
+		RvalLoadInstrs,
+		CastClassInstrs,
+		instr_node(stfld(FieldRef))]) }.
 
 store(mem_ref(_Rval, _Type), _Instrs, Info, Info) :- 
 		% you always need load the reference first, then
@@ -3216,8 +3223,12 @@
 	% XXX we remove byrefs from fields here.  Perhaps we ought to do
 	% this in a separate pass.   See defn_to_class_decl which does
 	% the same thing when creating the fields.
-:- func get_fieldref(il_data_rep, field_id, mlds__type, mlds__type) = fieldref.
-get_fieldref(DataRep, FieldNum, FieldType, ClassType0) = FieldRef :-
+:- pred get_fieldref(il_data_rep, field_id, mlds__type, mlds__type,
+		fieldref, instr_tree).
+:- mode get_fieldref(in, in, in, in, out, out) is det.
+
+get_fieldref(DataRep, FieldNum, FieldType, ClassType0,
+		FieldRef, CastClassInstrs) :-
 	( ClassType0 = mlds__ptr_type(ClassType1) ->
 		ClassType = ClassType1
 	;
@@ -3238,7 +3249,8 @@
 		;
 			sorry(this_file, 
 				"offsets for non-int_const rvals")
-		)
+		),
+		CastClassInstrs = empty
 	; 
 		FieldNum = named_field(qual(ModuleName, FieldId), _CtorType),
 		% The MLDS doesn't record which qualifiers are class qualifiers
@@ -3247,7 +3259,15 @@
 		% we call fixup_class_qualifiers to make it correct.
 		CtorClassName = mlds_module_name_to_class_name(ModuleName),
 		BaseClassName = mlds_type_to_ilds_class_name(DataRep, ClassType),
-		ClassName = fixup_class_qualifiers(CtorClassName, BaseClassName)
+		ClassName = fixup_class_qualifiers(CtorClassName, BaseClassName),
+		(
+			BaseClassName = CtorClassName
+		->
+			CastClassInstrs = empty
+		;
+			CastClassInstrs = instr_node(
+				castclass(ilds__type([], class(ClassName))))
+		)
 	),
 	FieldRef = make_fieldref(FieldILType, ClassName, FieldId).
 

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