[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