[m-rev.] for review: reserved address data representation (part 3)

[Fergus Henderson]

On 24-Oct-2001, Fergus Henderson <fjh at cs.mu.OZ.AU> wrote:
> Allow the compiler to optionally make use of reserved addresses --
> null pointers, ints cast to pointers, and addresses of global variables --
> to optimize the representation of constants in discriminated union types.
> 
> This will be particularly useful for the .NET and Java back-ends.
> 
> There are several parts to this change:
> 	- compiler support
> 	- RTTI support
> 	- fixes for code which makes assumptions that no longer hold
> 	- optimizing trivial switches in the MLDS back-end
> 
> For ease of review, I will post each of these parts separately.

Branches: main
Estimated hours taken: 2

compiler/mlds_to_il.m:
compiler/mlds.m:
	Fix a place in mlds_to_il.m where we were assuming that the
	arguments always included a secondary tag; this assumption is
	not robust and will be broken by my change to represent
	constants in discriminated union types using reserved addresses.
	This fix required adding a new boolean field to the `new_object'
	instruction to record whether or not the arguments include a
	secondary tag.

compiler/ml_elim_nested.m:
compiler/ml_unify_gen.m:
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
compiler/mlds_to_mcpp.m:
	Update to handle the new field of `new_object'.

Workspace: /home/earth/fjh/ws-earth2/mercury
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.70
diff -u -d -r1.70 mlds.m
--- compiler/mlds.m	24 Aug 2001 15:44:53 -0000	1.70
+++ compiler/mlds.m	23 Oct 2001 06:18:57 -0000
@@ -355,8 +355,8 @@
 % Given an MLDS module name (e.g. `foo.bar'), append another class qualifier
 % (e.g. for a class `baz'), and return the result (e.g. `foo.bar.baz').
 % The `arity' argument specifies the arity of the class.
-:- func mlds__append_class_qualifier(mlds_module_name, mlds__class_name, arity) =
-	mlds_module_name.
+:- func mlds__append_class_qualifier(mlds_module_name, mlds__class_name,
+		arity) = mlds_module_name.
 
 % Append a wrapper class qualifier to the module name and leave the
 % package name unchanged.
@@ -1072,9 +1072,13 @@
 			mlds__lval,	% The target to assign the new object's
 					% address to.
 			maybe(mlds__tag),
-					% A tag to tag the address with
-					% before assigning the result to the
-					% target.
+					% A (primary) tag to tag the address
+					% with before assigning the result to
+					% the target.
+			bool,		% Indicates whether or not there is
+					% a secondary tag.  If so, it will
+					% be stored as the first argument
+					% in the argument list (see below).
 			mlds__type,	% The type of the object being
 					% allocated.
 			maybe(mlds__rval),
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.85
diff -u -d -r1.85 mlds_to_il.m
--- compiler/mlds_to_il.m	17 Oct 2001 05:10:29 -0000	1.85
+++ compiler/mlds_to_il.m	23 Oct 2001 05:57:02 -0000
@@ -406,8 +406,8 @@
 rename_atomic(comment(S)) = comment(S).
 rename_atomic(assign(L, R)) = assign(rename_lval(L), rename_rval(R)).
 rename_atomic(delete_object(O)) = delete_object(rename_lval(O)).
-rename_atomic(new_object(L, Tag, Type, MaybeSize, Ctxt, Args, Types))
-	= new_object(rename_lval(L), Tag, Type, MaybeSize,
+rename_atomic(new_object(L, Tag, HasSecTag, Type, MaybeSize, Ctxt, Args, Types))
+	= new_object(rename_lval(L), Tag, HasSecTag, Type, MaybeSize,
 			Ctxt, list__map(rename_rval, Args), Types).
 rename_atomic(mark_hp(L)) = mark_hp(rename_lval(L)).
 rename_atomic(restore_hp(R)) = restore_hp(rename_rval(R)).
@@ -1876,8 +1876,8 @@
 	get_load_store_lval_instrs(Target, LoadInstrs, StoreInstrs),
 	{ Instrs = tree__list([LoadInstrs, instr_node(ldnull), StoreInstrs]) }.
 
-atomic_statement_to_il(new_object(Target, _MaybeTag, Type, Size, MaybeCtorName,
-		Args0, ArgTypes), Instrs) -->
+atomic_statement_to_il(new_object(Target, _MaybeTag, HasSecTag, Type, Size,
+		MaybeCtorName, Args0, ArgTypes0), Instrs) -->
 	DataRep =^ il_data_rep,
 	( 
 		{ 
@@ -1911,25 +1911,24 @@
 		;
 		 	{ ClassName = ClassName0 }
 		),
-		{ Type = mlds__generic_env_ptr_type ->
-			ILArgTypes = [],
-			Args = Args0
-		;
-			% It must be a user-defined type.
-			% Skip the secondary tag.
-			% We assume there is always a secondary tag,
-			% since ml_type_gen always generates one
-			% if we have --tags none, which the IL back-end
-			% requires.
-			ArgTypes = [_SecondaryTag | ArgTypes1],
-			Args0 = [_SecondaryTagVal | Args1]
-		->
-			Args = Args1,
-			ILArgTypes = list__map(mlds_type_to_ilds_type(DataRep),
-				ArgTypes1)
+			% Skip the secondary tag, if any
+		{ HasSecTag = yes ->
+			(
+				ArgTypes0 = [_SecondaryTag | ArgTypes1],
+				Args0 = [_SecondaryTagVal | Args1]
+			->
+				Args = Args1,
+				ArgTypes = ArgTypes1
+			;
+				unexpected(this_file,
+					"newobj without secondary tag")
+			)
 		;
-			sorry(this_file, "newobj without secondary tag")
+			ArgTypes = ArgTypes0,
+			Args = Args0
 		},
+		{ ILArgTypes = list__map(mlds_type_to_ilds_type(DataRep),
+					ArgTypes) },
 		list__map_foldl(load, Args, ArgsLoadInstrsTrees),
 		{ ArgsLoadInstrs = tree__list(ArgsLoadInstrsTrees) },
 		get_load_store_lval_instrs(Target, LoadMemRefInstrs,
@@ -1970,7 +1969,7 @@
 		{ Box = (pred(A - T::in, B::out) is det :- 
 			B = unop(box(T), A)   
 		) },
-		{ assoc_list__from_corresponding_lists(Args0, ArgTypes,
+		{ assoc_list__from_corresponding_lists(Args0, ArgTypes0,
 			ArgsAndTypes) },
 		{ list__map(Box, ArgsAndTypes, BoxedArgs) },
 	
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.42
diff -u -d -r1.42 ml_elim_nested.m
--- compiler/ml_elim_nested.m	24 Aug 2001 15:44:51 -0000	1.42
+++ compiler/ml_elim_nested.m	23 Oct 2001 05:33:44 -0000
@@ -429,7 +429,7 @@
 		NewObj = mlds__statement(
 				atomic(new_object(
 					var(EnvVar, EnvTypeName), 
-					no, EnvTypeName, no, no, [], [])),
+					no, no, EnvTypeName, no, no, [], [])),
 				Context),
 		InitEnv = mlds__statement(block([], 
 			[NewObj, InitEnv0]), Context),
@@ -980,10 +980,10 @@
 	fixup_rval(Rval0, Rval).
 fixup_atomic_stmt(delete_object(Lval0), delete_object(Lval)) -->
 	fixup_lval(Lval0, Lval).
-fixup_atomic_stmt(new_object(Target0, MaybeTag, Type, MaybeSize, MaybeCtorName,
-			Args0, ArgTypes),
-		new_object(Target, MaybeTag, Type, MaybeSize, MaybeCtorName,
-			Args, ArgTypes)) -->
+fixup_atomic_stmt(new_object(Target0, MaybeTag, HasSecTag, Type, MaybeSize,
+			MaybeCtorName, Args0, ArgTypes),
+		new_object(Target, MaybeTag, HasSecTag, Type, MaybeSize,
+			MaybeCtorName, Args, ArgTypes)) -->
 	fixup_lval(Target0, Target),
 	fixup_rvals(Args0, Args).
 fixup_atomic_stmt(mark_hp(Lval0), mark_hp(Lval)) -->
@@ -1516,8 +1516,8 @@
 	( lval_contains_var(Lval, Name)
 	; rval_contains_var(Rval, Name)
 	).
-atomic_stmt_contains_var(new_object(Target, _MaybeTag, _Type, _MaybeSize,
-			_MaybeCtorName, Args, _ArgTypes), Name) :-
+atomic_stmt_contains_var(new_object(Target, _MaybeTag, _HasSecTag, _Type,
+		_MaybeSize, _MaybeCtorName, Args, _ArgTypes), Name) :-
 	( lval_contains_var(Target, Name)
 	; rvals_contains_var(Args, Name)
 	).
Index: ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.40
diff -u -d -u -r1.40 ml_unify_gen.m
--- ml_unify_gen.m	12 Aug 2001 23:01:16 -0000	1.40
+++ ml_unify_gen.m	23 Oct 2001 06:37:00 -0000
@@ -487,7 +566,7 @@
 	% generate a `new_object' statement (or static constant)
 	% for the closure
 	%
-	ml_gen_new_object(no, Tag, QualifiedCtorId, Var, ExtraArgRvals, 
+	ml_gen_new_object(no, Tag, no, QualifiedCtorId, Var, ExtraArgRvals, 
 		ExtraArgTypes, ArgVars, ArgModes, HowToConstruct, Context,
 		MLDS_Decls, MLDS_Statements).
 
@@ -924,15 +1003,17 @@
 	% If there is a secondary tag, it goes in the first field
 	%
 	{ MaybeSecondaryTag = yes(SecondaryTag) ->
+		HasSecTag = yes,
 		SecondaryTagRval = const(int_const(SecondaryTag)),
 		SecondaryTagType = mlds__native_int_type,
 		ExtraRvals = [SecondaryTagRval],
 		ExtraArgTypes = [SecondaryTagType]
 	;
+		HasSecTag = no,
 		ExtraRvals = [],
 		ExtraArgTypes = []
 	},
-	ml_gen_new_object(yes(ConsId), Tag, CtorName, Var,
+	ml_gen_new_object(yes(ConsId), Tag, HasSecTag, CtorName, Var,
 			ExtraRvals, ExtraArgTypes, ArgVars, ArgModes,
 			HowToConstruct, Context, MLDS_Decls, MLDS_Statements).
 
@@ -944,17 +1025,17 @@
 	%	additional constants to insert at the start of the
 	%	argument list.
 	%
-:- pred ml_gen_new_object(maybe(cons_id), mlds__tag, ctor_name, prog_var,
+:- pred ml_gen_new_object(maybe(cons_id), mlds__tag, bool, 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, out, out,
+:- 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, CtorName, Var, ExtraRvals, ExtraTypes,
-		ArgVars, ArgModes, HowToConstruct, Context,
-		MLDS_Decls, MLDS_Statements) -->
+ml_gen_new_object(MaybeConsId, Tag, HasSecTag, CtorName, Var,
+		ExtraRvals, ExtraTypes, ArgVars, ArgModes, HowToConstruct,
+		Context, MLDS_Decls, MLDS_Statements) -->
 	%
 	% Determine the variable's type and lval,
 	% the tag to use, and the types of the argument vars.
@@ -1000,9 +1081,9 @@
 		% statement will also initialize the fields of this term
 		% with boxed versions of the specified arguments.
 		%
-		{ MakeNewObject = new_object(VarLval, MaybeTag, MLDS_Type,
-			yes(SizeInWordsRval), yes(CtorName), ArgRvals,
-			MLDS_ArgTypes) },
+		{ MakeNewObject = new_object(VarLval, MaybeTag, HasSecTag,
+			MLDS_Type, yes(SizeInWordsRval), yes(CtorName),
+			ArgRvals, MLDS_ArgTypes) },
 		{ MLDS_Stmt = atomic(MakeNewObject) },
 		{ MLDS_Statement = mlds__statement(MLDS_Stmt,
 			mlds__make_context(Context)) },
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.103
diff -u -d -r1.103 mlds_to_c.m
--- compiler/mlds_to_c.m	24 Aug 2001 15:44:53 -0000	1.103
+++ compiler/mlds_to_c.m	23 Oct 2001 05:36:53 -0000
@@ -2443,7 +2443,7 @@
 	{ error("mlds_to_c.m: sorry, delete_object not implemented") }.
 
 mlds_output_atomic_stmt(Indent, FuncInfo, NewObject, Context) -->
-	{ NewObject = new_object(Target, MaybeTag, Type, MaybeSize,
+	{ NewObject = new_object(Target, MaybeTag, _HasSecTag, Type, MaybeSize,
 		MaybeCtorName, Args, ArgTypes) },
 	mlds_indent(Indent),
 	io__write_string("{\n"),
Index: mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.51
diff -u -d -u -r1.51 mlds_to_gcc.m
--- mlds_to_gcc.m	24 Aug 2001 15:44:54 -0000	1.51
+++ mlds_to_gcc.m	23 Oct 2001 05:37:17 -0000
@@ -2688,7 +2719,7 @@
 	{ sorry(this_file, "delete_object") }.
 
 gen_atomic_stmt(DefnInfo, NewObject, Context) -->
-	{ NewObject = new_object(Target, MaybeTag, Type, MaybeSize,
+	{ NewObject = new_object(Target, MaybeTag, _HasSecTag, Type, MaybeSize,
 		_MaybeCtorName, Args, ArgTypes) },
 
 	%
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.13
diff -u -d -r1.13 mlds_to_java.m
--- compiler/mlds_to_java.m	24 Aug 2001 15:44:56 -0000	1.13
+++ compiler/mlds_to_java.m	23 Oct 2001 05:37:43 -0000
@@ -1772,8 +1772,8 @@
 	{ error("mlds_to_java.m: delete_object not supported in Java.") }.
 
 output_atomic_stmt(Indent, _FuncInfo, NewObject, Context) -->
-	{ NewObject = new_object(Target, _MaybeTag, Type, _MaybeSize,
-		MaybeCtorName, Args, ArgTypes) },
+	{ NewObject = new_object(Target, _MaybeTag, _HasSecTag, Type,
+		_MaybeSize, MaybeCtorName, Args, ArgTypes) },
 	
 	indent_line(Indent),
 	io__write_string("{\n"),
Index: compiler/mlds_to_mcpp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_mcpp.m,v
retrieving revision 1.20
diff -u -d -r1.20 mlds_to_mcpp.m
--- compiler/mlds_to_mcpp.m	17 Oct 2001 05:10:33 -0000	1.20
+++ compiler/mlds_to_mcpp.m	23 Oct 2001 05:38:11 -0000
@@ -346,8 +346,9 @@
 
 			% XXX This is not fully implemented
 		{ Statement = statement(atomic(
-			new_object(Target, _MaybeTag, Type, _MaybeSize, 
-				_MaybeCtorName, _Args, _ArgTypes)), _) },
+			new_object(Target, _MaybeTag, _HasSecTag, Type,
+				_MaybeSize, _MaybeCtorName,
+				_Args, _ArgTypes)), _) },
 		{ ClassName = mlds_type_to_ilds_class_name(ILDataRep, Type) }
 	->
 		write_managed_cpp_lval(Target),

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