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

Fergus Henderson fjh at cs.mu.OZ.AU
Wed Oct 24 14:34:04 AEST 2001


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.

Estimated hours taken: 18
Branches: main

Add compiler support for deciding when to use reserved addresses,
and for generating code appropriately when they are used.

compiler/options.m:
doc/user_guide.texi:
	Add new options `--num-reserved-addresses'
	and `--num-reserved-objects'.

compiler/hlds_data.m:
	Add new type `reserved_address ---> null_pointer ; small_pointer(int) ;
	reserved_object(sym_name, arity)'.
	Add new cons_tag alternatives `reserved_address(reserved_address)'
	and `shared_with_reserved_address(list(reserved_address), cons_tag)'.
	Also add get_secondary_tag, for use by ml_type_gen.m.

compiler/ml_type_gen.m:
	Don't generate types for constructors represented using reserved
	addresses.  For constructors represented using reserved_object,
	generate the reserved object.
	Also, use get_secondary_tag, rather than just unifying with
	shared_remote/2, so that it works for
	shared_with_reserved_tag(_, shared_remote(_, _)).

compiler/make_tags.m:
	If --tags none and --num-reserved-addresses are both set,
	then assign null_pointer and small_pointer(int) representations
	to constants up to the value set in num-reserved-addresses.
	If --tags none and --high-level-code are both set,
	and more constants remain unassigned, then assign reserved_object
	representations for those constants, and generate static member
	variable declarations for the reserved_objects.

compiler/make_hlds.m:
	Pass down the type_id to assign_constructor_tags in make_tags.m,
	since it is needed for reserved_object representations.

compiler/ml_unify_gen.m:
compiler/unify_gen.m:
	Handle construction, deconstruction, and tag tests for
	types represented using reserved tags.
	(In unify_gen.m, only null_pointer and small_pointer(int)
	are supported; for reserved_object we call sorry/2).

compiler/ml_switch_gen.m:
compiler/switch_gen.m:
compiler/switch_util.m:
	Handle switches on types represented using reserved tags.
	XXX Currently we always use if-then-else chains for such
	    switches; this may not be efficient.

compiler/ml_code_util.m:
	Add ml_format_reserved_object_name.
	Also add accessibility parameter to ml_gen_static_const_defn,
	so that it can be used for generating the class member
	static constants used for reserved_objects.

compiler/ml_string_switch.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
	Handle the new parameter to ml_gen_static_const_defn.

compiler/bytecode_gen.m:
	Call sorry/2 if types represented using reserved addresses are
	encountered.

Workspace: /home/earth/fjh/ws-earth2/mercury
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.63
diff -u -d -u -r1.63 bytecode_gen.m
--- compiler/bytecode_gen.m	16 Aug 2001 10:04:04 -0000	1.63
+++ compiler/bytecode_gen.m	24 Oct 2001 04:30:39 -0000
@@ -770,6 +770,16 @@
 	unexpected(this_file, "tabling_pointer_constant cons tag for non-tabling_pointer_constant cons id").
 bytecode_gen__map_cons_tag(deep_profiling_proc_static_tag(_), _) :-
 	unexpected(this_file, "deep_profiling_proc_static_tag cons tag for non-deep_profiling_proc_static cons id").
+bytecode_gen__map_cons_tag(reserved_address(_), _) :-
+	% These should only be generated if the --num-reserved-addresses
+	% or --num-reserved-objects options are used.
+	sorry(this_file,
+	   "bytecode with --num-reserved-addresses or --num-reserved-objects").
+bytecode_gen__map_cons_tag(shared_with_reserved_addresses(_, _), _) :-
+	% These should only be generated if the --num-reserved-addresses
+	% or --num-reserved-objects options are used.
+	sorry(this_file,
+	   "bytecode with --num-reserved-addresses or --num-reserved-objects").
 
 %---------------------------------------------------------------------------%
 
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.56
diff -u -d -r1.56 hlds_data.m
--- compiler/hlds_data.m	10 Jul 2001 10:45:22 -0000	1.56
+++ compiler/hlds_data.m	23 Oct 2001 06:20:16 -0000
@@ -382,10 +382,37 @@
 			% and a secondary tag, but this time the secondary
 			% tag is stored in the rest of the main word rather
 			% than in the first word of the argument vector.
-	;	no_tag.
+	;	no_tag
 			% This is for types with a single functor of arity one.
 			% In this case, we don't need to store the functor,
 			% and instead we store the argument directly.
+	;	reserved_address(reserved_address)
+			% This is for constants represented as null pointers,
+			% or as other reserved values in the address space.
+	;       shared_with_reserved_addresses(list(reserved_address),
+				cons_tag).
+			% This is for constructors of discriminated union
+			% types where one or more of the *other* constructors
+			% for that type is represented
+			% as a null_pointer, small_pointer(int),
+			% or reserved_pointer(sym_name, arity).
+			% The reserved_values field specifies which.
+			% Any semidet deconstruction against a constructor
+			% represented as a shared_with_reserved_values cons_tag
+			% must check that the value isn't any of the reserved
+			% values before doing a deconstruction against
+
+:- type reserved_address
+	--->	null_pointer
+			% This is for constants which are represented as a
+			% null pointer.
+	;	small_pointer(int)
+			% This is for constants which are represented as a
+			% small integer, cast to a pointer.
+	;	reserved_object(type_id, sym_name, arity).
+			% This is for constants which are represented as the
+			% address of a specially reserved global variable.
+
 
 	% The type `tag_bits' holds a primary tag value.
 
@@ -406,7 +433,28 @@
 :- type no_tag_type_table == map(type_id, no_tag_type).
 
 
+	% Return the secondary tag, if any, for a cons_tag.
+:- func get_secondary_tag(cons_tag) = maybe(int).
+
 :- implementation.
+
+get_secondary_tag(string_constant(_)) = no.
+get_secondary_tag(float_constant(_)) = no.
+get_secondary_tag(int_constant(_)) = no.
+get_secondary_tag(pred_closure_tag(_, _, _)) = no.
+get_secondary_tag(code_addr_constant(_, _)) = no.
+get_secondary_tag(type_ctor_info_constant(_, _, _)) = no.
+get_secondary_tag(base_typeclass_info_constant(_, _, _)) = no.
+get_secondary_tag(tabling_pointer_constant(_, _)) = no.
+get_secondary_tag(deep_profiling_proc_static_tag(_)) = no.
+get_secondary_tag(unshared_tag(_)) = no.
+get_secondary_tag(shared_remote_tag(_PrimaryTag, SecondaryTag)) =
+		yes(SecondaryTag).
+get_secondary_tag(shared_local_tag(_, _)) = no.
+get_secondary_tag(no_tag) = no.
+get_secondary_tag(reserved_address(_)) = no.
+get_secondary_tag(shared_with_reserved_addresses(_ReservedAddresses, TagValue))
+		= get_secondary_tag(TagValue).
 
 :- type hlds_type_defn
 	--->	hlds_type_defn(
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.385
diff -u -d -r1.385 make_hlds.m
--- compiler/make_hlds.m	9 Oct 2001 03:50:18 -0000	1.385
+++ compiler/make_hlds.m	23 Oct 2001 06:35:24 -0000
@@ -1788,9 +1788,9 @@
 		item_status(Status0, NeedQual), Module) -->
 	{ module_info_types(Module0, Types0) },
 	globals__io_get_globals(Globals),
-	{ convert_type_defn(TypeDefn, Globals, Body) },
 	{ list__length(Args, Arity) },
 	{ TypeId = Name - Arity },
+	{ convert_type_defn(TypeDefn, TypeId, Globals, Body) },
 	{ Body = abstract_type ->
 		make_status_abstract(Status0, Status1)
 	;
@@ -2011,15 +2011,15 @@
 		Status = abstract_imported
 	).
 
-:- pred convert_type_defn(type_defn, globals, hlds_type_body).
-:- mode convert_type_defn(in, in, out) is det.
+:- pred convert_type_defn(type_defn, type_id, globals, hlds_type_body).
+:- mode convert_type_defn(in, in, in, out) is det.
 
-convert_type_defn(du_type(Body, EqualityPred), Globals,
+convert_type_defn(du_type(Body, EqualityPred), TypeId, Globals,
 		du_type(Body, CtorTags, IsEnum, EqualityPred)) :-
-	assign_constructor_tags(Body, Globals, CtorTags, IsEnum).
-convert_type_defn(uu_type(Body), _, uu_type(Body)).
-convert_type_defn(eqv_type(Body), _, eqv_type(Body)).
-convert_type_defn(abstract_type, _, abstract_type).
+	assign_constructor_tags(Body, TypeId, Globals, CtorTags, IsEnum).
+convert_type_defn(uu_type(Body), _, _, uu_type(Body)).
+convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
+convert_type_defn(abstract_type, _, _, abstract_type).
 
 :- pred ctors_add(list(constructor), type_id, tvarset, need_qualifier,
 		partial_qualifier_info, prog_context, import_status,
Index: compiler/make_tags.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_tags.m,v
retrieving revision 1.33
diff -u -d -r1.33 make_tags.m
--- compiler/make_tags.m	18 Mar 2001 23:09:57 -0000	1.33
+++ compiler/make_tags.m	23 Oct 2001 08:58:10 -0000
@@ -31,6 +31,19 @@
 	% remaining functors all get the last remaining two-bit tag.
 	% These functors are distinguished by a secondary tag which is
 	% the first word of the argument vector for those functors.
+	%
+	% If there are no tag bits available, then we try using reserved
+	% addresses (e.g. NULL, (void *)1, (void *)2, etc.) instead.
+	% We split the constructors into constants and functors,
+	% and assign numerical reserved addresses to the first constants,
+	% up to the limit set by --num-reserved-addresses.
+	% After that, for the MLDS back-end, we assign symbolic reserved
+	% addresses to the remaining constants, up to the limit set by
+	% --num-reserved-objects; these symbolic reserved addresses
+	% are the addresses of global variables that we generate specially
+	% for this purpose.  Finally, the functors and any remaining
+	% constants are distinguished by a secondary tag, if there are more
+	% than one of them.
 
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
@@ -41,15 +54,15 @@
 :- import_module prog_data, hlds_data, globals.
 :- import_module bool, list.
 
-% assign_constructor_tags(Constructors, Globals, TagValues, IsEnum):
+% assign_constructor_tags(Constructors, TypeId, Globals, TagValues, IsEnum):
 %	Assign a constructor tag to each constructor for a discriminated
 %	union type, and determine whether the type is an enumeration
 %	type or not.  (`Globals' is passed because exact way in which
 %	this is done is dependent on a compilation option.)
 
-:- pred assign_constructor_tags(list(constructor), globals,
+:- pred assign_constructor_tags(list(constructor), type_id, globals,
 				cons_tag_values, bool).
-:- mode assign_constructor_tags(in, in, out, out) is det.
+:- mode assign_constructor_tags(in, in, in, out, out) is det.
 
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
@@ -61,10 +74,16 @@
 
 %-----------------------------------------------------------------------------%
 
-assign_constructor_tags(Ctors, Globals, CtorTags, IsEnum) :-
+assign_constructor_tags(Ctors, TypeId, Globals, CtorTags, IsEnum) :-
 
-		% work out how many tag bits there are
+		% work out how many tag bits and reserved addresses
+		% we've got to play with
 	globals__lookup_int_option(Globals, num_tag_bits, NumTagBits),
+	globals__lookup_int_option(Globals, num_reserved_addresses,
+		NumReservedAddresses),
+	globals__lookup_int_option(Globals, num_reserved_objects,
+		NumReservedObjects),
+	globals__lookup_bool_option(Globals, highlevel_code, HighLevelCode),
 
 		% determine if we need to reserve a tag for use by HAL's
 		% Herbrand constraint solver
@@ -84,7 +103,8 @@
 		% now assign them
 	map__init(CtorTags0),
 	(
-			% All the constructors must be constant, and we
+			% Try representing the type as an enumeration:
+			% all the constructors must be constant, and we
 			% must be allowed to make unboxed enums.
 		globals__lookup_bool_option(Globals, unboxed_enums, yes),
 		ctors_are_all_constants(Ctors),
@@ -95,6 +115,7 @@
 	;
 		IsEnum = no,
 		(
+				% Try representing it as a no-tag type
 			type_constructors_should_be_no_tag(Ctors, Globals,
 				SingleFunc, SingleArg, _)
 		->
@@ -107,24 +128,44 @@
 			( ReserveTag = yes ->
 				% XXX Need to fix this.
 				% This occurs for the .NET and Java backends
-				sorry("make_tags", "--reserve-tag with num_tag_bits = 0")
+				sorry("make_tags",
+					"--reserve-tag with num_tag_bits = 0")
 			;
 				true
 			),
-			( Ctors = [_SingleCtor] ->
-				assign_unshared_tags(Ctors, 0, 1,
-					CtorTags0, CtorTags)
+			% assign reserved addresses to the constants,
+			% if possible
+			split_constructors(Ctors, Constants, Functors),
+			assign_reserved_numeric_addresses(Constants, 
+				LeftOverConstants0, CtorTags0, CtorTags1,
+				0, NumReservedAddresses),
+			( HighLevelCode = yes ->
+				assign_reserved_symbolic_addresses(
+					LeftOverConstants0,
+					LeftOverConstants, TypeId,
+					CtorTags1, CtorTags2,
+					0, NumReservedObjects)
 			;
-				assign_shared_remote_tags(Ctors, 0, 0,
-					CtorTags0, CtorTags)
-			)
+				% reserved symbolic addresses are not
+				% supported for the LLDS back-end
+				LeftOverConstants = LeftOverConstants0,
+				CtorTags2 = CtorTags1
+			),
+			% assign shared_with_reserved_address(...)
+			% representations for the remaining constructors
+			RemainingCtors = LeftOverConstants ++ Functors,
+			ReservedAddresses = list__filter_map(
+				(func(reserved_address(RA)) = RA is semidet),
+				map__values(CtorTags2)),
+			assign_unshared_tags(RemainingCtors, 0, 0,
+				ReservedAddresses, CtorTags2, CtorTags)
 		;
 			max_num_tags(NumTagBits, MaxNumTags),
 			MaxTag is MaxNumTags - 1,
 			split_constructors(Ctors, Constants, Functors),
 			assign_constant_tags(Constants, CtorTags0,
 						CtorTags1, InitTag, NextTag),
-			assign_unshared_tags(Functors, NextTag, MaxTag,
+			assign_unshared_tags(Functors, NextTag, MaxTag, [],
 						CtorTags1, CtorTags)
 		)
 	).
@@ -142,6 +183,55 @@
 	Val1 is Val + 1,
 	assign_enum_constants(Rest, Val1, CtorTags1, CtorTags).
 
+	% assign the representations null_pointer, small_pointer(1),
+	% small_pointer(2), ..., small_pointer(N) to the constructors,
+	% until N >= NumReservedAddresses.
+:- pred assign_reserved_numeric_addresses(list(constructor), list(constructor),
+		cons_tag_values, cons_tag_values, int, int).
+:- mode assign_reserved_numeric_addresses(in, out, in, out, in, in) is det.
+
+assign_reserved_numeric_addresses([], [], CtorTags, CtorTags, _, _).
+assign_reserved_numeric_addresses([Ctor | Rest], LeftOverConstants,
+		CtorTags0, CtorTags, Address, NumReservedAddresses) :-
+	( Address >= NumReservedAddresses ->
+		LeftOverConstants = [Ctor | Rest],
+		CtorTags = CtorTags0
+	;
+		Ctor = ctor(_ExistQVars, _Constraints, Name, Args),
+		make_cons_id_from_qualified_sym_name(Name, Args, ConsId),
+		( Address = 0 ->
+			Tag = reserved_address(null_pointer)
+		;
+			Tag = reserved_address(small_pointer(Address))
+		),
+		map__set(CtorTags0, ConsId, Tag, CtorTags1),
+		assign_reserved_numeric_addresses(Rest, LeftOverConstants,
+			CtorTags1, CtorTags, Address + 1, NumReservedAddresses)
+	).
+
+	% assign reserved_object(CtorName, CtorArity) representations
+	% to the specified constructors
+:- pred assign_reserved_symbolic_addresses(list(constructor),
+		list(constructor), type_id, cons_tag_values, cons_tag_values,
+		int, int).
+:- mode assign_reserved_symbolic_addresses(in, out, in, in, out, in, in) is det.
+
+assign_reserved_symbolic_addresses([], [], _, CtorTags, CtorTags, _, _).
+assign_reserved_symbolic_addresses([Ctor | Ctors], LeftOverConstants, TypeId,
+		CtorTags0, CtorTags, Num, Max) :-
+	( Num >= Max ->
+		LeftOverConstants = [Ctor | Ctors],
+		CtorTags = CtorTags0
+	;
+		Ctor = ctor(_ExistQVars, _Constraints, Name, Args),
+		Arity = list__length(Args),
+		Tag = reserved_address(reserved_object(TypeId, Name, Arity)),
+		make_cons_id_from_qualified_sym_name(Name, Args, ConsId),
+		map__set(CtorTags0, ConsId, Tag, CtorTags1),
+		assign_reserved_symbolic_addresses(Ctors, LeftOverConstants,
+			TypeId, CtorTags1, CtorTags, Num + 1, Max)
+	).
+
 :- pred assign_constant_tags(list(constructor), cons_tag_values,
 				cons_tag_values, int, int).
 :- mode assign_constant_tags(in, in, out, in, out) is det.
@@ -166,40 +256,44 @@
 			InitTag, 0, CtorTags0, CtorTags1)
 	).
 
-:- pred assign_unshared_tags(list(constructor), int, int, cons_tag_values,
-				cons_tag_values).
-:- mode assign_unshared_tags(in, in, in, in, out) is det.
+:- pred assign_unshared_tags(list(constructor), int, int,
+		list(reserved_address), cons_tag_values, cons_tag_values).
+:- mode assign_unshared_tags(in, in, in, in, in, out) is det.
 
-assign_unshared_tags([], _, _, CtorTags, CtorTags).
-assign_unshared_tags([Ctor | Rest], Val, MaxTag, CtorTags0, CtorTags) :-
+assign_unshared_tags([], _, _, _, CtorTags, CtorTags).
+assign_unshared_tags([Ctor | Rest], Val, MaxTag, ReservedAddresses,
+		CtorTags0, CtorTags) :-
 	Ctor = ctor(_ExistQVars, _Constraints, Name, Args),
 	make_cons_id_from_qualified_sym_name(Name, Args, ConsId),
 		% if we're about to run out of unshared tags, start assigning
 		% shared remote tags instead
 	( Val = MaxTag, Rest \= [] ->
 		assign_shared_remote_tags([Ctor | Rest], MaxTag, 0,
-			CtorTags0, CtorTags)
+			ReservedAddresses, CtorTags0, CtorTags)
 	;
-		Tag = unshared_tag(Val),
+		Tag = maybe_add_reserved_addresses(ReservedAddresses,
+			unshared_tag(Val)),
 		map__set(CtorTags0, ConsId, Tag, CtorTags1),
 		Val1 is Val + 1,
-		assign_unshared_tags(Rest, Val1, MaxTag, CtorTags1, CtorTags)
+		assign_unshared_tags(Rest, Val1, MaxTag,
+			ReservedAddresses, CtorTags1, CtorTags)
 	).
 
-:- pred assign_shared_remote_tags(list(constructor), int, int, cons_tag_values,
-				cons_tag_values).
-:- mode assign_shared_remote_tags(in, in, in, in, out) is det.
+:- pred assign_shared_remote_tags(list(constructor), int, int, 
+		list(reserved_address), cons_tag_values, cons_tag_values).
+:- mode assign_shared_remote_tags(in, in, in, in, in, out) is det.
 
-assign_shared_remote_tags([], _, _, CtorTags, CtorTags).
+assign_shared_remote_tags([], _, _, _, CtorTags, CtorTags).
 assign_shared_remote_tags([Ctor | Rest], PrimaryVal, SecondaryVal,
-		CtorTags0, CtorTags) :-
+		ReservedAddresses, CtorTags0, CtorTags) :-
 	Ctor = ctor(_ExistQVars, _Constraints, Name, Args),
 	make_cons_id_from_qualified_sym_name(Name, Args, ConsId),
-	Tag = shared_remote_tag(PrimaryVal, SecondaryVal),
+	Tag = maybe_add_reserved_addresses(ReservedAddresses,
+		shared_remote_tag(PrimaryVal, SecondaryVal)),
 	map__set(CtorTags0, ConsId, Tag, CtorTags1),
 	SecondaryVal1 is SecondaryVal + 1,
 	assign_shared_remote_tags(Rest, PrimaryVal, SecondaryVal1,
-		CtorTags1, CtorTags).
+		ReservedAddresses, CtorTags1, CtorTags).
 
 :- pred assign_shared_local_tags(list(constructor), int, int,
 				cons_tag_values, cons_tag_values).
@@ -215,6 +309,16 @@
 	SecondaryVal1 is SecondaryVal + 1,
 	assign_shared_local_tags(Rest, PrimaryVal, SecondaryVal1,
 		CtorTags1, CtorTags).
+
+:- func maybe_add_reserved_addresses(list(reserved_address), cons_tag) =
+	cons_tag.
+maybe_add_reserved_addresses(ReservedAddresses, Tag) =
+	( ReservedAddresses = [] ->
+		Tag
+	;
+		shared_with_reserved_addresses(
+			ReservedAddresses, Tag)
+	).
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.44
diff -u -d -r1.44 ml_code_util.m
--- compiler/ml_code_util.m	24 Aug 2001 15:44:51 -0000	1.44
+++ compiler/ml_code_util.m	23 Oct 2001 03:52:27 -0000
@@ -280,17 +280,24 @@
 % Routines for dealing with static constants
 %
 
+	% ml_format_reserved_object_name(CtorName, CtorArity, ReservedObjName):
+	% Generate a name for a specially reserved global variable
+	% (or static member variable)
+	% whose address is used to represent the specified constructor.
+:- func ml_format_reserved_object_name(string, arity) = mlds__var_name.
+
 	% Generate a name for a local static constant.
 	%
 :- pred ml_format_static_const_name(string, const_seq, mlds__var_name,
 		ml_gen_info, ml_gen_info).
 :- mode ml_format_static_const_name(in, in, out, in, out) is det.
 
-	% Generate a definition of a local static constant,
-	% given the constant's name, type, and initializer.
+	% Generate a definition of a static constant,
+	% given the constant's name, type, accessibility,
+	% and initializer.
 	%
-:- func ml_gen_static_const_defn(mlds__var_name, mlds__type, mlds__initializer,
-		prog_context) = mlds__defn.
+:- func ml_gen_static_const_defn(mlds__var_name, mlds__type, mlds__access,
+		mlds__initializer, prog_context) = mlds__defn.
 
 	% Return the declaration flags appropriate for an
 	% initialized local static constant.
@@ -298,7 +305,7 @@
 :- func ml_static_const_decl_flags = mlds__decl_flags.
 
 	% Succeed iff the specified mlds__defn defines
-	% a static constant.
+	% a local static constant.
 	%
 :- pred ml_decl_is_static_const(mlds__defn::in) is semidet.
 
@@ -1402,6 +1409,19 @@
 	term__var_to_int(Var, VarNumber),
 	UniqueVarName = mlds__var_name(VarName, yes(VarNumber)).
 
+	% ml_format_reserved_object_name(CtorName, CtorArity, ReservedObjName):
+	% Generate a name for a specially reserved global variable
+	% (or static member variable)
+	% whose address is used to represent the specified constructor.
+	%
+	% We add the "obj_" prefix to avoid a name clash in the IL back-end
+	% between the type for a given constructor
+	% and the reserved object for that constructor.
+	%
+ml_format_reserved_object_name(CtorName, CtorArity) = ReservedObjName :-
+	Name = string__format("obj_%s_%d", [s(CtorName), i(CtorArity)]),
+	ReservedObjName = var_name(Name, no).
+
 	% Generate a name for a local static constant.
 	%
 	% To ensure that the names are unique, we qualify them with the
@@ -1451,11 +1471,11 @@
 	% Generate a definition of a local static constant,
 	% given the constant's name, type, and initializer.
 	%
-ml_gen_static_const_defn(ConstName, ConstType, Initializer, Context) =
+ml_gen_static_const_defn(ConstName, ConstType, Access, Initializer, Context) =
 		MLDS_Defn :-
 	Name = data(var(ConstName)),
 	Defn = data(ConstType, Initializer),
-	DeclFlags = ml_static_const_decl_flags,
+	DeclFlags = mlds__set_access(ml_static_const_decl_flags, Access),
 	MLDS_Context = mlds__make_context(Context),
 	MLDS_Defn = mlds__defn(Name, MLDS_Context, DeclFlags, Defn).
 
Index: compiler/ml_string_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_string_switch.m,v
retrieving revision 1.7
diff -u -d -r1.7 ml_string_switch.m
--- compiler/ml_string_switch.m	8 Jul 2001 16:40:08 -0000	1.7
+++ compiler/ml_string_switch.m	23 Oct 2001 03:50:06 -0000
@@ -116,8 +116,7 @@
 		NextSlotsName),
 	{ NextSlotsType = mlds__array_type(SlotVarType) },
 	{ NextSlotsDefn = ml_gen_static_const_defn(NextSlotsName,
-		NextSlotsType,
-		init_array(NextSlots), Context) },
+		NextSlotsType, local, init_array(NextSlots), Context) },
 	ml_gen_var_lval(NextSlotsName, NextSlotsType, NextSlotsLval),
 
 	ml_gen_info_new_const(StringTableSeq),
@@ -125,7 +124,7 @@
 		StringTableName),
 	{ StringTableType = mlds__array_type(StringVarType) },
 	{ StringTableDefn = ml_gen_static_const_defn(StringTableName,
-		StringTableType, init_array(Strings), Context) },
+		StringTableType, local, init_array(Strings), Context) },
 	ml_gen_var_lval(StringTableName, StringTableType ,StringTableLval),
 	
 	%
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.7
diff -u -d -r1.7 ml_switch_gen.m
--- compiler/ml_switch_gen.m	10 Jan 2001 11:15:32 -0000	1.7
+++ compiler/ml_switch_gen.m	23 Oct 2001 08:21:04 -0000
@@ -127,6 +127,22 @@
 	ml_gen_info_get_globals(Globals),
 	{ globals__lookup_bool_option(Globals, smart_indexing, Indexing) },
 	(
+		% Check for a switch on a type whose representation
+		% uses reserved addresses 
+		{ list__member(Case, TaggedCases) },	
+		{ Case = case(_Priority, Tag, _ConsId, _Goal) },
+		{
+			Tag = reserved_address(_)
+		;
+			Tag = shared_with_reserved_addresses(_, _)
+		}
+	->
+		% XXX This may be be inefficient in some cases.
+		ml_switch_generate_if_else_chain(TaggedCases, CaseVar,
+			CodeModel, CanFail, Context,
+			MLDS_Decls, MLDS_Statements)
+	;
+		
 /**************
 XXX Lookup switches are NYI
 When we do get around to implementing them,
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.13
diff -u -d -r1.13 ml_type_gen.m
--- compiler/ml_type_gen.m	24 Aug 2001 15:44:52 -0000	1.13
+++ compiler/ml_type_gen.m	23 Oct 2001 06:20:48 -0000
@@ -10,13 +10,16 @@
 % MLDS type generation -- convert HLDS types to MLDS.
 
 % For enumerations, we use a Java-style emulation: we convert them
-% to classes with a single int member, plus a bunch of static const
-% members for the different enumerations consts.
+% to classes with a single int member, plus a bunch of static (one_copy)
+% const members for the different enumerations consts.
 % 
 % For discriminated unions, we create an MLDS base class type
 % corresponding to the HLDS type, and we also create MLDS
 % derived class types corresponding to each of the constructors
 % which are defined from the base class type.
+% For constructors which are represented as the addresses of
+% specially reserved objects, we generate the static (one_copy)
+% members for those objects.
 
 %-----------------------------------------------------------------------------%
 
@@ -237,9 +240,17 @@
 	%		};
 	% #endif
 	%		...
+	%
 	%		/*
-	%		** Derived classes, one for each constructor;
-	%		** these are generated as nested classes to
+	%		** Reserved objects and/or derived classes,
+	%		** one for each constructor.
+	%		**
+	%		** Reserved objects are generated for any constructors
+	%		** that use a `reserved_address(reserved_object(...))'
+	% 		** representation.
+	%		**
+	%		** Derived classes are generated for any other
+	%		** constructors; these are generated as nested classes
 	%		** avoid name clashes.
 	%		** These will derive either directly from
 	%		** <ClassName> or from <ClassName>::tag_type
@@ -249,6 +260,10 @@
 	%		** secondary tag, we put the secondary tag members
 	%		** directly in the base class.
 	%		*/
+	%		*/
+	% #if ctor1_uses_reserved_object
+	%		static <ClassName> obj_<ctor1>;		
+	% #else
 	%		static class <ctor1> : public <ClassName> {
 	%		public:
 	%			/*
@@ -267,11 +282,13 @@
 	%				...
 	%			}
 	%		};
+	% #endif
 	%		static class <ctor2> : public <ClassName>::tag_type {
 	%		public:
 	%			...
 	%		};
 	%		...
+	%
 	%	};
 	%
 :- pred ml_gen_du_parent_type(module_info, type_id, hlds_type_defn,
@@ -312,9 +329,9 @@
 		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.
+		% mlds_to_c.m doesn't support static (one_copy) members.
 		%	TagConstMembers = list__condense(list__map(
-		% 		ml_gen_tag_constant(Context, TagValues), Ctors)),
+		% 	    ml_gen_tag_constant(Context, TagValues), Ctors)),
 		TagMembers0 = [TagDataMember | TagConstMembers],
 
 		%
@@ -340,8 +357,10 @@
 		)
 	),
 
-	% generate the nested derived classes for the constructors
-	list__foldl(ml_gen_du_ctor_type(ModuleInfo, BaseClassId,
+	% 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,
 		BaseClassQualifier, TagClassId, TypeDefn, TagValues),
 		Ctors, [], CtorMembers),
 
@@ -410,7 +429,27 @@
 	Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
 	list__length(Args, Arity),
 	map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
-	TagVal = shared_remote_tag(_PrimaryTag, SecondaryTag).
+	get_secondary_tag(TagVal) = yes(SecondaryTag).
+
+	%
+	% Check if this constructor is a constant whose
+	% value is represented as the address of a reserved object.
+	%
+:- pred ml_uses_reserved_addr(cons_tag_values, constructor, reserved_address).
+:- mode ml_uses_reserved_addr(in, in, out) is semidet.
+
+ml_uses_reserved_addr(ConsTagValues, Ctor, RA) :-
+	Ctor = ctor(_ExistQTVars, _Constraints, Name, Args),
+	list__length(Args, Arity),
+	map__lookup(ConsTagValues, cons(Name, Arity), TagVal),
+	tagval_is_reserved_addr(TagVal, RA).
+
+:- pred tagval_is_reserved_addr(cons_tag::in, reserved_address::out)
+	is semidet.
+
+tagval_is_reserved_addr(reserved_address(RA), RA).
+tagval_is_reserved_addr(shared_with_reserved_addresses(_, TagVal), RA) :-
+	tagval_is_reserved_addr(TagVal, RA).
 
 	%
 	% Generate a definition for the class used for the secondary tag
@@ -421,8 +460,8 @@
 		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) :-
+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.
@@ -447,15 +486,17 @@
 		MLDS_TypeDefnBody).
 	
 	%
-	% Generate a definition for the class corresponding to
+	% Generate a definition 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.
 	%
-:- pred ml_gen_du_ctor_type(module_info, mlds__class_id, mlds_module_name,
+:- 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_type(in, in, in, in, in, in, in, in, out) is det.
+:- mode ml_gen_du_ctor_member(in, in, in, in, in, in, in, in, out) is det.
 
-ml_gen_du_ctor_type(ModuleInfo, BaseClassId, BaseClassQualifier,
+ml_gen_du_ctor_member(ModuleInfo, BaseClassId, BaseClassQualifier,
 		SecondaryTagClassId, TypeDefn, ConsTagValues, Ctor,
 		MLDS_Defns0, MLDS_Defns) :-
 	Ctor = ctor(ExistQTVars, Constraints, CtorName, Args),
@@ -466,74 +507,97 @@
 	MLDS_Context = mlds__make_context(Context),
 
 	% generate the class name for this constructor
-	unqualify_name(CtorName, CtorClassName),
+	unqualify_name(CtorName, UnqualCtorName),
 	list__length(Args, CtorArity),
 
-	% number any unnamed fields starting from 1
-	ArgNum0 = 1,
-
-	% generate class members for the type_infos and typeclass_infos
-	% that hold information about existentially quantified
-	% type variables and type class constraints
-	( ExistQTVars = [] ->
-		% optimize common case
-		ExtraMembers = [],
-		ArgNum2 = ArgNum0
+	( ml_uses_reserved_addr(ConsTagValues, Ctor, ReservedAddr) ->
+		( ReservedAddr = reserved_object(_, _, _) ->
+			%
+			% Generate a reserved object for this constructor
+			%
+			MLDS_ReservedObjName = ml_format_reserved_object_name(
+				UnqualCtorName, CtorArity),
+			MLDS_ReservedObjDefn = ml_gen_static_const_defn(
+				MLDS_ReservedObjName, BaseClassId,
+				public, no_initializer, Context),
+			MLDS_Defns = [MLDS_ReservedObjDefn | MLDS_Defns0]
+		;
+			% for reserved numeric addresses, we don't need
+			% to generate any objects or types
+			MLDS_Defns = MLDS_Defns0
+		)
 	;
-		list__map_foldl(ml_gen_typeclass_info_member(ModuleInfo,
-			Context), Constraints, TypeClassInfoMembers,
-			ArgNum0, ArgNum1),
-		constraint_list_get_tvars(Constraints, ConstrainedTVars),
-		list__delete_elems(ExistQTVars, ConstrainedTVars,
-			UnconstrainedTVars),
-		list__map_foldl(ml_gen_type_info_member(ModuleInfo, Context),
-			UnconstrainedTVars, TypeInfoMembers,
-			ArgNum1, ArgNum2),
-		list__append(TypeClassInfoMembers, TypeInfoMembers,
-			ExtraMembers)
-	),
+		%
+		% Generate a type for this constructor
+		%
 
-	% generate the class members for the ordinary fields
-	% of this constructor
-	list__map_foldl(ml_gen_du_ctor_member(ModuleInfo, Context),
-		Args, OrdinaryMembers, ArgNum2, _ArgNum3),
+		% number any unnamed fields starting from 1
+		ArgNum0 = 1,
 
-	list__append(ExtraMembers, OrdinaryMembers, Members),
+		% generate class members for the type_infos and typeclass_infos
+		% that hold information about existentially quantified
+		% type variables and type class constraints
+		( ExistQTVars = [] ->
+			% optimize common case
+			ExtraMembers = [],
+			ArgNum2 = ArgNum0
+		;
+			list__map_foldl(ml_gen_typeclass_info_member(ModuleInfo,
+				Context), Constraints, TypeClassInfoMembers,
+				ArgNum0, ArgNum1),
+			constraint_list_get_tvars(Constraints,
+				ConstrainedTVars),
+			list__delete_elems(ExistQTVars, ConstrainedTVars,
+				UnconstrainedTVars),
+			list__map_foldl(
+				ml_gen_type_info_member(ModuleInfo, Context),
+				UnconstrainedTVars, TypeInfoMembers,
+				ArgNum1, ArgNum2),
+			list__append(TypeClassInfoMembers, TypeInfoMembers,
+				ExtraMembers)
+		),
 
-	% 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, TagVal) ->
-		ParentClassId = SecondaryTagClassId,
-		MaybeTagVal = yes(TagVal)
-	;
-		ParentClassId = BaseClassId,
-		MaybeTagVal = no
-	),
-	Imports = [],
-	Inherits = [ParentClassId],
-	Implements = [],
+		% generate the class members for the ordinary fields
+		% of this constructor
+		list__map_foldl(ml_gen_du_ctor_field(ModuleInfo, Context),
+			Args, OrdinaryMembers, ArgNum2, _ArgNum3),
 
-	% generate a constructor function to initialize the fields
-	%
-	CtorClassType = mlds__class_type(qual(BaseClassQualifier, CtorClassName),
-			CtorArity, mlds__class),
-	CtorClassQualifier = mlds__append_class_qualifier(
-			BaseClassQualifier, CtorClassName, CtorArity),
-	CtorFunction = gen_constructor_function(BaseClassId, CtorClassType,
-		CtorClassQualifier, SecondaryTagClassId, MaybeTagVal, Members,
-		MLDS_Context),
-	Ctors = [CtorFunction],
+		list__append(ExtraMembers, OrdinaryMembers, Members),
 
-	% put it all together
-	MLDS_TypeName = type(CtorClassName, 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].
+		% 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, TagVal) ->
+			ParentClassId = SecondaryTagClassId,
+			MaybeTagVal = yes(TagVal)
+		;
+			ParentClassId = BaseClassId,
+			MaybeTagVal = no
+		),
+		Imports = [],
+		Inherits = [ParentClassId],
+		Implements = [],
+
+		% generate a constructor function to initialize the fields
+		%
+		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,
+			MaybeTagVal, Members, MLDS_Context),
+		Ctors = [CtorFunction],
+
+		% 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]
+	).
 
 :- func gen_constructor_function(mlds__class_id, mlds__type, mlds_module_name,
 		mlds__class_id, maybe(int), mlds__defns, mlds__context) =
@@ -565,7 +629,8 @@
 
 		% Note that the name of constructor is
 		% determined by the backend convention.
-	CtorDefn = mlds__defn(export("<constructor>"), Context, CtorFlags, Ctor).
+	CtorDefn = mlds__defn(export("<constructor>"), Context, CtorFlags,
+			Ctor).
 
 	% Get the name and type from the field definition,
 	% for use as a constructor argument name and type.
@@ -616,7 +681,8 @@
 		TagClassQualifier = mlds__append_class_qualifier(
 				BaseClassQualifier, TagClassName, TagArity)
 	;
-		unexpected(this_file, "gen_init_tag: class_id should be a class")
+		unexpected(this_file,
+				"gen_init_tag: class_id should be a class")
 	),
 	Name = "data_tag",
 	Type = mlds__native_int_type,
@@ -645,11 +711,11 @@
 	polymorphism__build_type_info_type(term__variable(TypeVar), Type),
 	ml_gen_field(ModuleInfo, Context, no, Type, MLDS_Defn, ArgNum0, ArgNum).
 
-:- pred ml_gen_du_ctor_member(module_info, prog_context, constructor_arg,
+:- pred ml_gen_du_ctor_field(module_info, prog_context, constructor_arg,
 		mlds__defn, int, int).
-:- mode ml_gen_du_ctor_member(in, in, in, out, in, out) is det.
+:- mode ml_gen_du_ctor_field(in, in, in, out, in, out) is det.
 
-ml_gen_du_ctor_member(ModuleInfo, Context, MaybeFieldName - Type, MLDS_Defn,
+ml_gen_du_ctor_field(ModuleInfo, Context, MaybeFieldName - Type, MLDS_Defn,
 		ArgNum0, ArgNum) :-
 	ml_gen_field(ModuleInfo, Context, MaybeFieldName, Type, MLDS_Defn,
 		ArgNum0, ArgNum).
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.40
diff -u -d -r1.40 ml_unify_gen.m
--- compiler/ml_unify_gen.m	12 Aug 2001 23:01:16 -0000	1.40
+++ compiler/ml_unify_gen.m	24 Oct 2001 04:26:45 -0000
@@ -75,6 +75,10 @@
 :- mode ml_gen_closure_wrapper(in, in, in, in, in, out, out,
 		in, out) is det.
 
+	% Generate an MLDS rval for a given reserved address,
+	% cast to the appropriate type.
+:- func ml_gen_reserved_address(reserved_address, mlds__type) = mlds__rval.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
@@ -204,8 +208,30 @@
 	ml_variable_type(Var, Type),
 	ml_cons_id_to_tag(ConsId, Type, Tag),
 
+	ml_gen_construct_2(Tag, Type, Var, ConsId, Args, ArgModes,
+		HowToConstruct, Context, MLDS_Decls, MLDS_Statements).
+
+:- pred ml_gen_construct_2(cons_tag, prog_type, prog_var, cons_id, prog_vars,
+		list(uni_mode), how_to_construct, prog_context,
+		mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_construct_2(in, in, in, in, in, in, in, in, out, out, in, out)
+		is det.
+
+ml_gen_construct_2(Tag, Type, Var, ConsId, Args, ArgModes, HowToConstruct,
+		Context, MLDS_Decls, MLDS_Statements) -->
 	(
 		%
+		% types for which some other constructor has a
+		% reserved_address -- that only makes a difference when
+		% deconstructing, so here we ignore that, and just
+		% recurse on the representation for this constructor.
+		%
+		{ Tag = shared_with_reserved_addresses(_, ThisTag) }
+	->
+		ml_gen_construct_2(ThisTag, Type, Var, ConsId, Args, ArgModes,
+			HowToConstruct, Context, MLDS_Decls, MLDS_Statements)
+	;
+		%
 		% no_tag types
 		%
 		{ Tag = no_tag }
@@ -268,18 +294,38 @@
 	% ml_gen_construct.
 	%
 :- pred ml_gen_static_const_arg(prog_var, static_cons, mlds__rval,
-	ml_gen_info, ml_gen_info).
+		ml_gen_info, ml_gen_info).
 :- mode ml_gen_static_const_arg(in, in, out, in, out) is det.
 
-ml_gen_static_const_arg(Var, static_cons(ConsId, ArgVars, StaticArgs), Rval) -->
+ml_gen_static_const_arg(Var, StaticCons, Rval) -->
 	%
 	% figure out how this argument is represented
 	%
+	{ StaticCons = static_cons(ConsId, _ArgVars, _StaticArgs) },
 	ml_variable_type(Var, VarType),
 	ml_cons_id_to_tag(ConsId, VarType, Tag),
 
+	ml_gen_static_const_arg_2(Tag, VarType, Var, StaticCons, Rval).
+
+:- pred ml_gen_static_const_arg_2(cons_tag, prog_type, prog_var, static_cons,
+		mlds__rval, ml_gen_info, ml_gen_info).
+:- mode ml_gen_static_const_arg_2(in, in, in, in, out, in, out) is det.
+
+ml_gen_static_const_arg_2(Tag, VarType, Var, StaticCons, Rval) -->
+	{ StaticCons = static_cons(_ConsId, ArgVars, StaticArgs) }, 
 	(
 		%
+		% types for which some other constructor has a
+		% reserved_address -- that only makes a difference when
+		% constructing, so here we ignore that, and just
+		% recurse on the representation for this constructor.
+		%
+		{ Tag = shared_with_reserved_addresses(_, ThisTag) }
+	->
+		ml_gen_static_const_arg_2(ThisTag, VarType, Var, StaticCons,
+			Rval)
+	;
+		%
 		% no_tag types
 		%
 		{ Tag = no_tag }
@@ -397,7 +443,17 @@
 ml_gen_constant(code_addr_constant(PredId, ProcId), _, ProcAddrRval) -->
 	ml_gen_proc_addr_rval(PredId, ProcId, ProcAddrRval).
 
-% tags which are not (necessarily) constants are handled
+ml_gen_constant(reserved_address(ReservedAddr), VarType, Rval) -->
+	ml_gen_type(VarType, MLDS_VarType),
+	{ Rval = ml_gen_reserved_address(ReservedAddr, MLDS_VarType) }.
+
+ml_gen_constant(shared_with_reserved_addresses(_, ThisTag), VarType, Rval) -->
+	% For shared_with_reserved_address, the sharing is only
+	% important for tag tests, not for constructions,
+	% so here we just recurse on the real representation.
+	ml_gen_constant(ThisTag, VarType, Rval).
+
+% these tags, which are not (necessarily) constants, are handled
 % in ml_gen_construct and ml_gen_static_const_arg,
 % so we don't need to handle them here.
 ml_gen_constant(no_tag, _, _) -->
@@ -411,6 +467,29 @@
 
 %-----------------------------------------------------------------------------%
 
+% Generate an MLDS rval for a given reserved address,
+% cast to the appropriate type.
+ml_gen_reserved_address(null_pointer, MLDS_Type) = const(null(MLDS_Type)).
+ml_gen_reserved_address(small_pointer(Int), MLDS_Type) =
+		unop(cast(MLDS_Type), const(int_const(Int))).
+ml_gen_reserved_address(reserved_object(TypeId, QualCtorName, CtorArity),
+		_Type) = Rval :-
+	( QualCtorName = qualified(ModuleName, CtorName) ->
+		MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+		TypeId = TypeName - TypeArity,
+		unqualify_name(TypeName, UnqualTypeName),
+		MLDS_TypeName = mlds__append_class_qualifier(MLDS_ModuleName,
+			UnqualTypeName, TypeArity),
+		Name = ml_format_reserved_object_name(CtorName, CtorArity),
+		Rval = const(data_addr_const(
+			data_addr(MLDS_TypeName, var(Name))))
+	;
+		unexpected(this_file,
+			"unqualified ctor name in reserved_object")
+	).
+
+%-----------------------------------------------------------------------------%
+
 :- pred ml_gen_closure(pred_id, proc_id, lambda_eval_method, prog_var,
 		prog_vars, list(uni_mode), how_to_construct, prog_context,
 		mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
@@ -1038,7 +1117,7 @@
 		{ ArgInits = list__map(func(X) = init_obj(X), ArgRvals) },
 		{ Initializer = init_array(ArgInits) },
 		{ ConstDefn = ml_gen_static_const_defn(ConstName, ConstType,
-			Initializer, Context) },
+			local, Initializer, Context) },
 
 		%
 		% Assign the address of the local static constant to
@@ -1176,7 +1255,7 @@
 			[i(PredIdNum), i(ProcIdNum), i(SequenceNum)]), no) },
 		{ Initializer = init_obj(Rval) },
 		{ ConstDefn = ml_gen_static_const_defn(ConstName, Type,
-			Initializer, Context) },
+			local, Initializer, Context) },
 		{ ConstDefns = [ConstDefn] },
 		%
 		% Return as the boxed rval the address of that constant,
@@ -1313,6 +1392,17 @@
 	{ MLDS_Decls = [] },
 	ml_variable_type(Var, Type),
 	ml_cons_id_to_tag(ConsId, Type, Tag),
+	ml_gen_det_deconstruct_2(Tag, Type, Var, ConsId, Args, Modes, Context,
+			MLDS_Statements).
+
+:- pred ml_gen_det_deconstruct_2(cons_tag, prog_type, prog_var, cons_id,
+		prog_vars, list(uni_mode), prog_context,
+		mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_det_deconstruct_2(in, in, in, in, in, in, in, out, in, out)
+		is det.
+
+ml_gen_det_deconstruct_2(Tag, Type, Var, ConsId, Args, Modes, Context,
+		MLDS_Statements) -->
 	% For constants, if the deconstruction is det, then we already know
 	% the value of the constant, so MLDS_Statements = [].
 	(
@@ -1372,8 +1462,22 @@
 				VarLval, OffSet, ArgNum,
 				PrimaryTag, Context, MLDS_Statements)
 	;
+		% For constants, if the deconstruction is det, then we already
+		% know the value of the constant, so MLDS_Statements = [].
 		{ Tag = shared_local_tag(_Bits1, _Num1) },
-		{ MLDS_Statements = [] } % if this is det, then nothing happens
+		{ MLDS_Statements = [] }
+	;
+		% For constants, if the deconstruction is det, then we already
+		% know the value of the constant, so MLDS_Statements = [].
+		{ Tag = reserved_address(_) },
+		{ MLDS_Statements = [] }
+	;
+		% For shared_with_reserved_address, the sharing is only
+		% important for tag tests, not for det deconstructions,
+		% so here we just recurse on the real representation.
+		{ Tag = shared_with_reserved_addresses(_, ThisTag) },
+		ml_gen_det_deconstruct_2(ThisTag, Type, Var, ConsId, Args,
+				Modes, Context, MLDS_Statements)
 	).
 
 	% Calculate the integer offset used to reference the first field
@@ -1396,6 +1500,10 @@
 		OffSet = 1,
 		ArgNum = 1
 	;
+		Tag = shared_with_reserved_addresses(_, ThisTag),
+		% just recurse on ThisTag
+		ml_tag_offset_and_argnum(ThisTag, TagBits, OffSet, ArgNum)
+	;
 		Tag = string_constant(_String),
 		error("ml_tag_offset_and_argnum")
 	;
@@ -1428,6 +1536,9 @@
 	;
 		Tag = shared_local_tag(_Bits1, _Num1),
 		error("ml_tag_offset_and_argnum")
+	;
+		Tag = reserved_address(_),
+		error("ml_tag_offset_and_argnum")
 	).
 
 
@@ -1796,6 +1907,28 @@
 	TestRval = binop(eq, Rval,
 		  unop(cast(MLDS_VarType), mkword(Bits,
 		  	unop(std_unop(mkbody), const(int_const(Num)))))).
+
+ml_gen_tag_test_rval(reserved_address(ReservedAddr), VarType, ModuleInfo,
+		Rval) = TestRval :-
+	MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
+	ReservedAddrRval = ml_gen_reserved_address(ReservedAddr, MLDS_VarType),
+	TestRval = binop(eq, Rval, ReservedAddrRval).
+
+ml_gen_tag_test_rval(shared_with_reserved_addresses(ReservedAddrs, ThisTag),
+		VarType, ModuleInfo, Rval) = FinalTestRval :-
+	%
+	% We first check that the Rval doesn't match any of the
+	% ReservedAddrs, and then check that it matches ThisTag.
+	%
+	CheckReservedAddrs = (func(RA, TestRval0) = TestRval :-
+		EqualRA = ml_gen_tag_test_rval(reserved_address(RA), VarType,
+					ModuleInfo, Rval),
+		TestRval = binop((and), unop(std_unop(not), EqualRA), TestRval0)
+	),
+	MatchesThisTag = ml_gen_tag_test_rval(ThisTag, VarType, ModuleInfo,
+			Rval),
+	FinalTestRval = list__foldr(CheckReservedAddrs, ReservedAddrs,
+			MatchesThisTag).
 
 	% ml_gen_secondary_tag_rval(PrimaryTag, VarType, ModuleInfo, VarRval):
 	%	Return the rval for the secondary tag field of VarRval,
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.338
diff -u -d -r1.338 options.m
--- compiler/options.m	2 Oct 2001 07:09:45 -0000	1.338
+++ compiler/options.m	23 Oct 2001 09:04:00 -0000
@@ -188,6 +188,8 @@
 		;	reserve_tag
 		;	tags
 		;	num_tag_bits
+		;	num_reserved_addresses
+		;	num_reserved_objects
 		;	bits_per_word
 		;	bytes_per_word
 				% The undocumented conf_low_tag_bits option
@@ -661,6 +663,8 @@
 					% -1 is a special value which means
 					% use the value of conf_low_tag_bits
 					% instead
+	num_reserved_addresses	-	int(0),
+	num_reserved_objects	-	int(0),
 	bits_per_word		-	int(32),
 					% A good default for the current
 					% generation of architectures.
@@ -1119,6 +1123,8 @@
 long_option("pic-reg",			pic_reg).
 long_option("tags",			tags).
 long_option("num-tag-bits",		num_tag_bits).
+long_option("num-reserved-addresses",	num_reserved_addresses).
+long_option("num-reserved-objects",	num_reserved_objects).
 long_option("bits-per-word",		bits_per_word).
 long_option("bytes-per-word",		bytes_per_word).
 long_option("conf-low-tag-bits",	conf_low_tag_bits).
@@ -1979,7 +1985,8 @@
 		"--dump-mlds <stage number or name>",
 		"\tDump the MLDS (medium level intermediate representation) after",
 		"\tthe specified stage to `<module>.mlds_dump.<num>-<name>',",
-		"\t`<module>.c_dump.<num>-<name>' and `<module>.h_dump.<num>-<name>'.",
+		"\t`<module>.c_dump.<num>-<name>',",
+		"\tand `<module>.h_dump.<num>-<name>'.",
 		"\tStage numbers range from 1-99.",
 		"\tMultiple dump options accumulate.",
 		"--dump-rl",
@@ -2342,6 +2349,15 @@
 	% 	"\t\t`--tags none' implies `--num-tag-bits 0'.",
 		"--num-tag-bits <n>\t\t(This option is not for general use.)",
 		"\tUse <n> tag bits.",
+		"--num-reserved-addresses <n>\t(This option is not for general use.)",
+		"\tTreat the integer values from 0 up to <n> - 1 as reserved",
+		"\taddresses that can be used to represent nullary constructors",
+		"\t(constants) of discriminated union types.",
+		"--num-reserved-objects <n>\t(This option is not for general use.)",
+		"\tAllocate up to <n> global objects per type,",
+		"\tfor representing nullary constructors",
+		"\t(constants) of discriminated union types.",
+
 
 		"--reserve-tag\t\t\t(grade modifier: `.rt')",
 		"\tReserve a tag in the data representation of the generated ",
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.75
diff -u -d -r1.75 switch_gen.m
--- compiler/switch_gen.m	23 Nov 2000 04:32:47 -0000	1.75
+++ compiler/switch_gen.m	24 Oct 2001 04:24:48 -0000
@@ -79,6 +79,21 @@
 	{ globals__lookup_bool_option(Globals, smart_indexing,
 		Indexing) },
 	(
+		% Check for a switch on a type whose representation
+		% uses reserved addresses 
+		{ list__member(Case, TaggedCases) },    
+		{ Case = case(_Priority, Tag, _ConsId, _Goal) },
+		{
+			Tag = reserved_address(_)
+		;
+			Tag = shared_with_reserved_addresses(_, _)
+		}
+	->
+		% XXX This may be be inefficient in some cases.
+		switch_gen__generate_all_cases(TaggedCases, CaseVar,
+			CodeModel, CanFail, StoreMap, EndLabel, no, MaybeEnd,
+			Code)
+	;
 		{ Indexing = yes },
 		{ SwitchCategory = atomic_switch },
 		code_info__get_maybe_trace_info(MaybeTraceInfo),
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.3
diff -u -d -r1.3 switch_util.m
--- compiler/switch_util.m	31 May 2001 05:59:53 -0000	1.3
+++ compiler/switch_util.m	16 Aug 2001 16:34:09 -0000
@@ -276,11 +276,15 @@
 	%
 switch_util__switch_priority(no_tag, 0).		% should never occur
 switch_util__switch_priority(int_constant(_), 1).
+switch_util__switch_priority(reserved_address(_), 1).
 switch_util__switch_priority(shared_local_tag(_, _), 1).
 switch_util__switch_priority(unshared_tag(_), 2).
 switch_util__switch_priority(float_constant(_), 3).
 switch_util__switch_priority(shared_remote_tag(_, _), 4).
 switch_util__switch_priority(string_constant(_), 5).
+switch_util__switch_priority(shared_with_reserved_addresses(RAs, Tag), N) :-
+	switch_util__switch_priority(Tag, N0),
+	N = N0 + list__length(RAs).
 	% The following tags should all never occur in switches.
 switch_util__switch_priority(pred_closure_tag(_, _, _), 6).
 switch_util__switch_priority(code_addr_constant(_, _), 6).
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.115
diff -u -d -r1.115 unify_gen.m
--- compiler/unify_gen.m	16 Aug 2001 16:00:39 -0000	1.115
+++ compiler/unify_gen.m	23 Oct 2001 06:23:40 -0000
@@ -42,7 +42,7 @@
 :- import_module hlds_module, hlds_pred, prog_data, prog_out, code_util.
 :- import_module mode_util, type_util, code_aux, hlds_out, tree, arg_info.
 :- import_module globals, options, continuation_info, stack_layout.
-:- import_module rl, trace.
+:- import_module rl, trace, error_util.
 
 :- import_module term, bool, string, int, list, map, require, std_util.
 
@@ -273,6 +273,34 @@
 	TestRval = binop(eq,	Rval,
 			mkword(Bits, unop(mkbody, const(int_const(Num))))).
 
+unify_gen__generate_tag_test_rval_2(reserved_address(RA), Rval, TestRval) :-
+	TestRval = binop(eq,	Rval,
+			unify_gen__generate_reserved_address(RA)).
+
+unify_gen__generate_tag_test_rval_2(
+		shared_with_reserved_addresses(ReservedAddrs, ThisTag),
+		Rval, FinalTestRval) :-
+	%
+	% We first check that the Rval doesn't match any of the
+	% ReservedAddrs, and then check that it matches ThisTag.
+	%
+	CheckReservedAddrs = (func(RA, TestRval0) = TestRval :-
+		unify_gen__generate_tag_test_rval_2(reserved_address(RA), Rval,
+			EqualRA),
+		TestRval = binop((and), unop(not, EqualRA), TestRval0)
+	),
+	unify_gen__generate_tag_test_rval_2(ThisTag, Rval, MatchesThisTag),
+	FinalTestRval = list__foldr(CheckReservedAddrs, ReservedAddrs,
+			MatchesThisTag).
+
+
+:- func unify_gen__generate_reserved_address(reserved_address) = rval.
+unify_gen__generate_reserved_address(null_pointer) = const(int_const(0)).
+unify_gen__generate_reserved_address(small_pointer(N)) = const(int_const(N)).
+unify_gen__generate_reserved_address(reserved_object(_, _, _)) = _ :-
+	% These should only be used for the MLDS back-end
+	unexpected(this_file, "reserved_object").
+
 %---------------------------------------------------------------------------%
 
 	% A construction unification is implemented as a simple assignment
@@ -393,6 +421,23 @@
 	code_info__get_module_info(ModuleInfo),
 	code_info__make_entry_label(ModuleInfo, PredId, ProcId, no, CodeAddr),
 	code_info__assign_const_to_var(Var, const(code_addr_const(CodeAddr))).
+unify_gen__generate_construction_2(reserved_address(RA),
+		Var, Args, _Modes, _, _, empty) -->
+	( { Args = [] } ->
+		[]
+	;
+		{ error("unify_gen: reserved_address constant has args") }
+	),
+	code_info__assign_const_to_var(Var,
+		unify_gen__generate_reserved_address(RA)).
+unify_gen__generate_construction_2(
+		shared_with_reserved_addresses(_RAs, ThisTag),
+		Var, Args, Modes, AditiInfo, GoalInfo, Code) -->
+	% For shared_with_reserved_address, the sharing is only
+	% important for tag tests, not for constructions,
+	% so here we just recurse on the real representation.
+	unify_gen__generate_construction_2(ThisTag,
+		Var, Args, Modes, AditiInfo, GoalInfo, Code).
 unify_gen__generate_construction_2(
 		pred_closure_tag(PredId, ProcId, EvalMethod),
 		Var, Args, _Modes, _AditiInfo, GoalInfo, Code) -->
@@ -711,6 +756,14 @@
 
 unify_gen__generate_det_deconstruction(Var, Cons, Args, Modes, Code) -->
 	code_info__cons_id_to_tag(Var, Cons, Tag),
+	unify_gen__generate_det_deconstruction_2(Var, Cons, Args, Modes,
+		Tag, Code).
+
+:- pred unify_gen__generate_det_deconstruction_2(prog_var::in, cons_id::in,
+	list(prog_var)::in, list(uni_mode)::in, cons_tag::in,
+	code_tree::out, code_info::in, code_info::out) is det.
+
+unify_gen__generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code) -->
 	% For constants, if the deconstruction is det, then we already know
 	% the value of the constant, so Code = empty.
 	(
@@ -768,6 +821,16 @@
 	;
 		{ Tag = shared_local_tag(_Ptag, _Sectag2) },
 		{ Code = empty } % if this is det, then nothing happens
+	;
+		{ Tag = reserved_address(_RA) },
+		{ Code = empty } % if this is det, then nothing happens
+	;
+		% For shared_with_reserved_address, the sharing is only
+		% important for tag tests, not for det deconstructions,
+		% so here we just recurse on the real representation.
+		{ Tag = shared_with_reserved_addresses(_RAs, ThisTag) },
+		unify_gen__generate_det_deconstruction_2(Var, Cons, Args, Modes,
+			ThisTag, Code)
 	).
 
 %---------------------------------------------------------------------------%
@@ -924,6 +987,11 @@
 	;
 		error("type is still a type variable in var_type_msg")
 	).
+
+%---------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "unify_gen.m".
 
 %---------------------------------------------------------------------------%
 %---------------------------------------------------------------------------%
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.273
diff -u -d -r1.273 user_guide.texi
--- doc/user_guide.texi	3 Oct 2001 11:37:56 -0000	1.273
+++ doc/user_guide.texi	23 Oct 2001 09:03:48 -0000
@@ -4495,6 +4495,7 @@
 @item @code{--tags @{none, low, high@}}
 @findex --tags
 @cindex Tags
+ at cindex Data representation
 (This option is not intended for general use.)@*
 Specify whether to use the low bits or the high bits of
 each word as tag bits (default: low).
@@ -4503,6 +4504,7 @@
 @item @code{--num-tag-bits @var{n}}
 @findex --num-tag-bits
 @cindex Tags
+ at cindex Data representation
 (This option is not intended for general use.)@*
 Use @var{n} tag bits.  This option is required if you specify
 @samp{--tags high}.
@@ -4510,9 +4512,37 @@
 is determined by the auto-configuration script.
 
 @sp 1
+ at item @code{--num-reserved-addresses @var{n}}
+ at findex --reserved-addresses
+ at cindex Reserved addresses
+ at cindex Addresses, reserved
+ at cindex Data representation
+(This option is not intended for general use.)@*
+Treat the integer values from 0 up to @var{n} - 1 as reserved
+addresses that can be used to represent nullary constructors
+(constants) of discriminated union types.
+
+ at sp 1
+ at item @code{--num-reserved-objects @var{n}}
+ at findex --reserved-addresses
+ at cindex Reserved addresses
+ at cindex Reserved objects
+ at cindex Addresses, reserved
+ at cindex Objects, reserved
+ at cindex Data representation
+(This option is not intended for general use.)@*
+Allocate up to @var{n} - 1 global objects for representing nullary
+constructors (constants) of discriminated union types.
+
+Note that reserved objects will only be used if reserved addresses
+(see @code{--num-reserved-addresses}) are not available, since the
+latter are more efficient.
+
+ at sp 1
 @item @code{--reserve-tag} (grades: any grade containing @samp{.rt})
 @findex --reserve-tag
 @cindex Tags
+ at cindex Data representation
 Reserve a tag in the data representation of the generated 
 code. This tag is intended to be used to give an explicit
 representation to free variables.
-- 
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