[m-rev.] for review: Add foreign type assertion `word_aligned_pointer'.
Peter Wang
novalazy at gmail.com
Wed Sep 30 10:46:48 AEST 2015
[Feel free to suggest an alternative name for the assertion.]
Add a new foreign type assertion `word_aligned_pointer' that asserts the
necessary conditions for the compiler to use the direct argument functor
representation on constructors of a single argument of that foreign type.
The conditions on the values of the foreign type are
- the values must fit in a single word
- the values must be clear in the tag bits ("word-aligned")
The first condition is the same as that asserted by
`can_pass_as_mercury_type' so we let `word_aligned_pointer' imply
`can_pass_as_mercury_type'.
compiler/prog_data.m:
Add `foreign_type_word_aligned_pointer' option.
Wrap list(foreign_type_assertions) in a new type to dissuade
direct checks for individual list members.
compiler/prog_io_pragma.m:
Parse `word_aligned_pointer' as a foreign type assertion.
compiler/hlds_data.m:
Add predicates for checking foreign type assertions. The
implication word_aligned_pointer => can_pass_as_mercury_type is
implemented in a single place.
compiler/make_tags.m:
Take `word_aligned_pointer' assertions into consideration when
deciding if a constructor can use the direct argument functor
representation.
Clarify the code.
compiler/foreign.m:
compiler/llds.m:
compiler/llds_out_instr.m:
compiler/ml_foreign_proc_gen.m:
compiler/parse_tree_out.m:
compiler/type_ctor_info.m:
Conform to changes.
doc/reference_manual.texi:
Add documentation.
tests/hard_coded/Mmakefile:
tests/hard_coded/word_aligned_pointer.exp:
tests/hard_coded/word_aligned_pointer.m:
tests/hard_coded/word_aligned_pointer_2.m:
Add test case.
NEWS:
Announce change.
diff --git a/NEWS b/NEWS
index 0431759..823b465 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,8 @@ Changes to the Mercury language:
* We have added an extension to include external files
in pragma foreign_decl and pragma foreign_code declarations.
+* We have added a foreign type assertion `word_aligned_pointer'.
+
Changes to the Mercury standard library:
* We have added variants of the process_options predicates to the getopt
diff --git a/compiler/foreign.m b/compiler/foreign.m
index 80ef788..fdf6a3c 100644
--- a/compiler/foreign.m
+++ b/compiler/foreign.m
@@ -72,13 +72,13 @@
%
:- pred foreign_type_body_to_exported_type(module_info::in,
foreign_type_body::in, sym_name::out, maybe(unify_compare)::out,
- list(foreign_type_assertion)::out) is det.
+ foreign_type_assertions::out) is det.
% Given the exported_type representation for a type, determine
% whether or not it is a foreign type, and if yes, return the foreign
% type's assertions.
%
-:- func is_foreign_type(exported_type) = maybe(list(foreign_type_assertion)).
+:- func is_foreign_type(exported_type) = maybe(foreign_type_assertions).
% Given a representation of a type, determine the string which
% corresponds to that type in the specified foreign language,
@@ -268,7 +268,7 @@ have_foreign_type_for_backend(Target, ForeignTypeBody, Have) :-
).
:- type exported_type
- ---> exported_type_foreign(sym_name, list(foreign_type_assertion))
+ ---> exported_type_foreign(sym_name, foreign_type_assertions)
% A type defined by a pragma foreign_type, and the assertions
% on that foreign_type.
diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m
index cccbae6..ab120fe 100644
--- a/compiler/hlds_data.m
+++ b/compiler/hlds_data.m
@@ -549,7 +549,7 @@ cons_table_optimize(!ConsTable) :-
---> foreign_type_lang_data(
T,
maybe(unify_compare),
- list(foreign_type_assertion)
+ foreign_type_assertions
).
% The `cons_tag_values' type stores the information on how a discriminated
@@ -763,6 +763,13 @@ cons_table_optimize(!ConsTable) :-
---> may_use_atomic_alloc
; may_not_use_atomic_alloc.
+ % Check asserted properties of a foreign type.
+ %
+:- pred asserted_can_pass_as_mercury_type(foreign_type_assertions::in)
+ is semidet.
+:- pred asserted_stable(foreign_type_assertions::in) is semidet.
+:- pred asserted_word_aligned_pointer(foreign_type_assertions::in) is semidet.
+
:- implementation.
project_tagged_cons_id_tag(TaggedConsId) = Tag :-
@@ -853,6 +860,21 @@ get_maybe_cheaper_tag_test(TypeBody) = CheaperTagTest :-
CheaperTagTest = no_cheaper_tag_test
).
+asserted_can_pass_as_mercury_type(foreign_type_assertions(List)) :-
+ (
+ list.member(foreign_type_can_pass_as_mercury_type, List)
+ ;
+ list.member(foreign_type_word_aligned_pointer, List)
+ ).
+
+asserted_stable(Assertions) :-
+ Assertions = foreign_type_assertions(List),
+ list.member(foreign_type_stable, List),
+ asserted_can_pass_as_mercury_type(Assertions).
+
+asserted_word_aligned_pointer(foreign_type_assertions(List)) :-
+ list.member(foreign_type_word_aligned_pointer, List).
+
%---------------------------------------------------------------------------%
:- type type_table == map(string, type_ctor_table).
diff --git a/compiler/llds.m b/compiler/llds.m
index 0be5b12..9b13685 100644
--- a/compiler/llds.m
+++ b/compiler/llds.m
@@ -829,7 +829,7 @@
:- type foreign_proc_type
---> foreign_proc_type(
string, % The C type name.
- list(foreign_type_assertion)
+ foreign_type_assertions
% The assertions on the foreign_type
% declarations that the C type name came from.
).
diff --git a/compiler/llds_out_instr.m b/compiler/llds_out_instr.m
index ea46018..21850b6 100644
--- a/compiler/llds_out_instr.m
+++ b/compiler/llds_out_instr.m
@@ -1949,8 +1949,7 @@ output_foreign_proc_input(Info, Input, !IO) :-
(
c_type_is_word_sized_int_or_ptr(ForeignType)
;
- list.member(foreign_type_can_pass_as_mercury_type,
- Assertions)
+ asserted_can_pass_as_mercury_type(Assertions)
)
then
% Note that for this cast to be correct the foreign
@@ -2037,9 +2036,7 @@ output_foreign_proc_output(Info, Output, !IO) :-
(
MaybeForeignType = yes(ForeignTypeInfo),
ForeignTypeInfo = foreign_proc_type(ForeignType, Assertions),
- ( if
- list.member(foreign_type_can_pass_as_mercury_type, Assertions)
- then
+ ( if asserted_can_pass_as_mercury_type(Assertions) then
output_lval_as_word(Info, Lval, !IO),
io.write_string(" = ", !IO),
output_llds_type_cast(lt_word, !IO),
diff --git a/compiler/make_tags.m b/compiler/make_tags.m
index cfefb58..98f5827 100644
--- a/compiler/make_tags.m
+++ b/compiler/make_tags.m
@@ -444,8 +444,8 @@ post_process_type_defns(!HLDS, Specs) :-
globals.lookup_int_option(Globals, num_tag_bits, NumTagBits),
globals.lookup_bool_option(Globals, debug_type_rep, DebugTypeRep),
MaxTag = max_num_tags(NumTagBits) - 1,
- convert_direct_arg_functors(ModuleName, DebugTypeRep, MaxTag,
- TypeCtorsDefns, TypeTable0, TypeTable, [], Specs),
+ convert_direct_arg_functors(Target, ModuleName, DebugTypeRep,
+ MaxTag, TypeCtorsDefns, TypeTable0, TypeTable, [], Specs),
module_info_set_type_table(TypeTable, !HLDS)
;
% We cannot use direct arg functors in term size grades.
@@ -460,26 +460,27 @@ post_process_type_defns(!HLDS, Specs) :-
Specs = []
).
-:- pred convert_direct_arg_functors(module_name::in, bool::in, int::in,
- assoc_list(type_ctor, hlds_type_defn)::in, type_table::in, type_table::out,
+:- pred convert_direct_arg_functors(compilation_target::in, module_name::in,
+ bool::in, int::in, assoc_list(type_ctor, hlds_type_defn)::in,
+ type_table::in, type_table::out,
list(error_spec)::in, list(error_spec)::out) is det.
-convert_direct_arg_functors(_, _, _, [], !TypeTable, !Specs).
-convert_direct_arg_functors(ModuleName, DebugTypeRep, MaxTag,
+convert_direct_arg_functors(_, _, _, _, [], !TypeTable, !Specs).
+convert_direct_arg_functors(Target, ModuleName, DebugTypeRep, MaxTag,
[TypeCtorDefn | TypeCtorsDefns], !TypeTable, !Specs) :-
TypeCtorDefn = TypeCtor - TypeDefn,
- convert_direct_arg_functors_if_suitable(ModuleName, DebugTypeRep, MaxTag,
- TypeCtor, TypeDefn, !TypeTable, !Specs),
- convert_direct_arg_functors(ModuleName, DebugTypeRep, MaxTag,
+ convert_direct_arg_functors_if_suitable(Target, ModuleName, DebugTypeRep,
+ MaxTag, TypeCtor, TypeDefn, !TypeTable, !Specs),
+ convert_direct_arg_functors(Target, ModuleName, DebugTypeRep, MaxTag,
TypeCtorsDefns, !TypeTable, !Specs).
-:- pred convert_direct_arg_functors_if_suitable(module_name::in, bool::in,
- int::in, type_ctor::in, hlds_type_defn::in,
+:- pred convert_direct_arg_functors_if_suitable(compilation_target::in,
+ module_name::in, bool::in, int::in, type_ctor::in, hlds_type_defn::in,
type_table::in, type_table::out,
list(error_spec)::in, list(error_spec)::out) is det.
-convert_direct_arg_functors_if_suitable(ModuleName, DebugTypeRep, MaxTag,
- TypeCtor, TypeDefn, !TypeTable, !Specs) :-
+convert_direct_arg_functors_if_suitable(Target, ModuleName, DebugTypeRep,
+ MaxTag, TypeCtor, TypeDefn, !TypeTable, !Specs) :-
get_type_defn_body(TypeDefn, Body),
(
Body = hlds_du_type(Ctors, _ConsTagValues, _MaybeCheaperTagTest,
@@ -502,7 +503,7 @@ convert_direct_arg_functors_if_suitable(ModuleName, DebugTypeRep, MaxTag,
AssertedDirectArgFunctors = []
),
separate_out_constants(Ctors, Constants, Functors),
- list.filter(is_direct_arg_ctor(!.TypeTable, TypeCtorModule,
+ list.filter(is_direct_arg_ctor(!.TypeTable, Target, TypeCtorModule,
TypeStatus, AssertedDirectArgFunctors),
Functors, DirectArgFunctors, NonDirectArgFunctors),
(
@@ -570,10 +571,11 @@ convert_direct_arg_functors_if_suitable(ModuleName, DebugTypeRep, MaxTag,
% Leave these types alone.
).
-:- pred is_direct_arg_ctor(type_table::in, module_name::in, type_status::in,
- list(sym_name_and_arity)::in, constructor::in) is semidet.
+:- pred is_direct_arg_ctor(type_table::in, compilation_target::in,
+ module_name::in, type_status::in, list(sym_name_and_arity)::in,
+ constructor::in) is semidet.
-is_direct_arg_ctor(TypeTable, TypeCtorModule, TypeStatus,
+is_direct_arg_ctor(TypeTable, Target, TypeCtorModule, TypeStatus,
AssertedDirectArgCtors, Ctor) :-
Ctor = ctor(ExistQTVars, ExistConstraints, ConsName, ConsArgs, Arity,
_CtorContext),
@@ -596,18 +598,27 @@ is_direct_arg_ctor(TypeTable, TypeCtorModule, TypeStatus,
% Strings are *not* always word-aligned (yet) so are not acceptable.
type_ctor_is_tuple(ArgTypeCtor)
->
- ArgCond = direct_arg_builtin_type
+ ArgCond = arg_type_is_suitable_builtin_type
+ ;
+ search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn),
+ get_type_defn_body(ArgTypeDefn, ArgBody),
+ ( is_foreign_type_for_target(ArgBody, Target, Assertions) ->
+ % Foreign types are acceptable arguments if asserted that their
+ % values are word-aligned pointers.
+ asserted_word_aligned_pointer(Assertions),
+ ArgCond = arg_type_is_word_aligned_pointer
;
+ % The argument type is not a foreign type.
+
ArgTypeCtorArgTypes = [],
- % XXX We could let this be a subset of the type params, but that would
- % require the runtime system to be able to handle variables in the
- % argument type, during unification and comparison
+ % XXX We could let this be a subset of the type params, but that
+ % would require the runtime system to be able to handle variables
+ % in the argument type, during unification and comparison
% (mercury_unify_compare_body.h) during deconstruction
% (mercury_ml_expand_body.h), during deep copying
- % (mercury_deep_copy_body.h), and maybe during some other operations.
+ % (mercury_deep_copy_body.h), and maybe during some other
+ % operations.
- search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn),
- get_type_defn_body(ArgTypeDefn, ArgBody),
ArgBody = hlds_du_type(ArgCtors, ArgConsTagValues,
ArgMaybeCheaperTagTest, ArgDuKind, _ArgMaybeUserEqComp,
ArgDirectArgCtors, ArgReservedTag, ArgReservedAddr,
@@ -634,31 +645,51 @@ is_direct_arg_ctor(TypeTable, TypeCtorModule, TypeStatus,
sym_name_get_module_name(ArgTypeCtorSymName, ArgTypeCtorModule),
( TypeCtorModule = ArgTypeCtorModule ->
get_type_defn_status(ArgTypeDefn, ArgTypeStatus),
- ArgCond = direct_arg_same_module(ArgTypeStatus)
+ ArgCond = arg_type_defined_in_same_module(ArgTypeStatus)
;
- ArgCond = direct_arg_different_module
+ ArgCond = arg_type_defined_in_different_module
+ )
)
)
),
check_direct_arg_cond(TypeStatus, ArgCond).
:- type direct_arg_cond
- ---> direct_arg_builtin_type
- % The argument is of a builtin type that is represented with an
- % untagged pointer.
-
- ; direct_arg_asserted
- % A `where direct_arg' attribute asserts that the direct arg
+ ---> direct_arg_asserted
+ % The constructor being checked has a single argument, and a
+ % `where direct_arg' attribute asserts that the direct arg
% representation may be used for the constructor.
- ; direct_arg_same_module(type_status)
- % The argument type is defined in the same module as the outer
- % type, and has the given import status.
-
- ; direct_arg_different_module.
- % The argument type is defined in a different module to the outer
- % type.
+ ; arg_type_is_suitable_builtin_type
+ % The constructor being checked has a single argument, and the
+ % argument is of a builtin type that is represented with an
+ % untagged pointer.
+ ; arg_type_is_word_aligned_pointer
+ % The constructor being checked has a single argument, and the
+ % argument is of a foreign type with the `word_aligned_pointer'
+ % assertion.
+
+ ; arg_type_defined_in_same_module(type_status)
+ % The constructor being checked has a single argument, and the type
+ % of the argument is defined in the same module as the constructor.
+ % The argument type has the given import status.
+
+ ; arg_type_defined_in_different_module.
+ % The constructor being checked has a single argument, and the type
+ % of the argument is defined in a different module from the
+ % constructor.
+
+ % At this point we have checked that the constructor has a single argument,
+ % and the argument has a suitable type such that the direct arg functor
+ % representation may apply to the constructor. We still need to check that
+ % other modules would infer the same type representation for the same
+ % constructor, given that they may not have the same knowledge of the
+ % constructor's type or the argument type.
+ %
+ % TypeStatus is the import status of the type of the constructor being
+ % checked.
+ %
:- pred check_direct_arg_cond(type_status::in, direct_arg_cond::in) is semidet.
check_direct_arg_cond(TypeStatus, ArgCond) :-
@@ -688,32 +719,37 @@ check_direct_arg_cond(TypeStatus, ArgCond) :-
( OldImportStatus = status_exported
; OldImportStatus = status_exported_to_submodules
),
- ( ArgCond = direct_arg_builtin_type
- ; ArgCond = direct_arg_asserted
- ; ArgCond = direct_arg_same_module(type_status(status_exported))
+ ( ArgCond = direct_arg_asserted
+ ; ArgCond = arg_type_is_suitable_builtin_type
+ ; ArgCond = arg_type_is_word_aligned_pointer
+ ; ArgCond =
+ arg_type_defined_in_same_module(type_status(status_exported))
)
;
% If the outer type is exported to sub-modules only, the argument
% type only needs to be exported to sub-modules as well.
OldImportStatus = status_exported_to_submodules,
- ( ArgCond =
- direct_arg_same_module(type_status(status_exported_to_submodules))
- ; ArgCond =
- direct_arg_same_module(type_status(status_abstract_exported))
+ ArgCond = arg_type_defined_in_same_module(ArgTypeStatus),
+ ( ArgTypeStatus = type_status(status_exported_to_submodules)
+ ; ArgTypeStatus = type_status(status_abstract_exported)
)
;
- % The direct arg representation is required if the outer type is
- % imported, and:
+ % The direct arg representation is required if the type of the
+ % constructor being checked is imported, and:
+ % - if a `where direct_arg' attribute says so
% - if the argument type is an acceptable builtin type
- % - a `where direct_arg' attribute says so
+ % - if the argument type is a foreign type with assertion
+ % `word_aligned_pointer'
% - if the argument type is imported from the same module
OldImportStatus = status_imported(TypeImportLocn),
(
- ArgCond = direct_arg_builtin_type
- ;
ArgCond = direct_arg_asserted
;
- ArgCond = direct_arg_same_module(
+ ArgCond = arg_type_is_suitable_builtin_type
+ ;
+ ArgCond = arg_type_is_word_aligned_pointer
+ ;
+ ArgCond = arg_type_defined_in_same_module(
type_status(status_imported(ArgImportLocn))),
% If the argument type is only exported by an ancestor to its
% sub-modules (of which we are one), the outer type must also only
@@ -741,6 +777,29 @@ check_direct_arg_cond(TypeStatus, ArgCond) :-
unexpected($module, $pred, "inappropriate status for type")
).
+:- pred is_foreign_type_for_target(hlds_type_body::in, compilation_target::in,
+ foreign_type_assertions::out) is semidet.
+
+is_foreign_type_for_target(TypeBody, Target, Assertions) :-
+ (
+ TypeBody ^ du_type_is_foreign_type = yes(ForeignType)
+ ;
+ TypeBody = hlds_foreign_type(ForeignType)
+ ),
+ (
+ Target = target_c,
+ ForeignType ^ c = yes(foreign_type_lang_data(_, _, Assertions))
+ ;
+ Target = target_java,
+ ForeignType ^ java = yes(foreign_type_lang_data(_, _, Assertions))
+ ;
+ Target = target_csharp,
+ ForeignType ^ csharp = yes(foreign_type_lang_data(_, _, Assertions))
+ ;
+ Target = target_erlang,
+ ForeignType ^ erlang = yes(foreign_type_lang_data(_, _, Assertions))
+ ).
+
:- pred assign_direct_arg_tags(type_ctor::in, list(constructor)::in,
int::in, int::out, int::in, list(constructor)::out,
cons_tag_values::in, cons_tag_values::out) is det.
diff --git a/compiler/ml_foreign_proc_gen.m b/compiler/ml_foreign_proc_gen.m
index 3daa9fa..8e0529e 100644
--- a/compiler/ml_foreign_proc_gen.m
+++ b/compiler/ml_foreign_proc_gen.m
@@ -42,6 +42,7 @@
:- import_module backend_libs.foreign. % XXX needed for pragma foreign code
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
:- import_module libs.globals.
:- import_module libs.options.
@@ -829,7 +830,7 @@ input_arg_assignable_with_cast(Lang, HighLevelData, OrigType, ExportedType,
IsForeign = foreign.is_foreign_type(ExportedType),
(
IsForeign = yes(Assertions),
- list.member(foreign_type_can_pass_as_mercury_type, Assertions)
+ asserted_can_pass_as_mercury_type(Assertions)
;
IsForeign = no
),
@@ -850,7 +851,7 @@ input_arg_assignable_with_cast(Lang, HighLevelData, OrigType, ExportedType,
IsForeign = foreign.is_foreign_type(ExportedType),
(
IsForeign = yes(Assertions),
- list.member(foreign_type_can_pass_as_mercury_type, Assertions),
+ asserted_can_pass_as_mercury_type(Assertions),
Cast = "(" ++ TypeString ++ ")"
;
IsForeign = no,
@@ -1011,7 +1012,7 @@ ml_gen_pragma_c_gen_output_arg(Var, ArgName, OrigType, BoxPolicy,
Cast = no
;
IsForeign = yes(Assertions),
- list.member(foreign_type_can_pass_as_mercury_type, Assertions),
+ asserted_can_pass_as_mercury_type(Assertions),
Cast = yes
)
then
diff --git a/compiler/parse_tree_out.m b/compiler/parse_tree_out.m
index af187af..ae6e286 100644
--- a/compiler/parse_tree_out.m
+++ b/compiler/parse_tree_out.m
@@ -644,7 +644,7 @@ mercury_output_item_type_defn(Info, ItemTypeDefn, !IO) :-
io.write_string(".\n", !IO)
;
TypeDefn = parse_tree_foreign_type(ForeignType, MaybeUserEqComp,
- Assertions),
+ foreign_type_assertions(Assertions)),
io.write_string(":- pragma foreign_type(", !IO),
(
ForeignType = c(_),
@@ -953,6 +953,9 @@ mercury_output_foreign_type_assertion(Assertion, !IO) :-
;
Assertion = foreign_type_stable,
io.write_string("stable", !IO)
+ ;
+ Assertion = foreign_type_word_aligned_pointer,
+ io.write_string("word_aligned_pointer", !IO)
).
%---------------------------------------------------------------------------%
diff --git a/compiler/prog_data.m b/compiler/prog_data.m
index ef49ba3..5ae6a6c 100644
--- a/compiler/prog_data.m
+++ b/compiler/prog_data.m
@@ -1650,7 +1650,7 @@ cons_id_is_const_struct(ConsId, ConstNum) :-
; parse_tree_foreign_type(
foreign_lang_type :: foreign_language_type,
foreign_user_uc :: maybe(unify_compare),
- foreign_assertions :: list(foreign_type_assertion)
+ foreign_assertions :: foreign_type_assertions
).
:- type abstract_type_details
@@ -1674,9 +1674,13 @@ cons_id_is_const_struct(ConsId, ConstNum) :-
% (i.e. the type was declared with
% `:- solver type ...').
+:- type foreign_type_assertions
+ ---> foreign_type_assertions(list(foreign_type_assertion)).
+
:- type foreign_type_assertion
---> foreign_type_can_pass_as_mercury_type
- ; foreign_type_stable.
+ ; foreign_type_stable
+ ; foreign_type_word_aligned_pointer.
:- type constructor
---> ctor(
diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m
index ed8e65d..2bf0953 100644
--- a/compiler/prog_io_pragma.m
+++ b/compiler/prog_io_pragma.m
@@ -1578,11 +1578,17 @@ parse_foreign_language_type(InputTerm, VarSet, Language,
).
:- pred parse_maybe_foreign_type_assertions(maybe(term)::in,
- list(foreign_type_assertion)::out) is semidet.
+ foreign_type_assertions::out) is semidet.
-parse_maybe_foreign_type_assertions(no, []).
-parse_maybe_foreign_type_assertions(yes(Term), Assertions) :-
- parse_foreign_type_assertions(Term, Assertions).
+parse_maybe_foreign_type_assertions(MaybeTerm, Assertions) :-
+ (
+ MaybeTerm = no,
+ Assertions = foreign_type_assertions([])
+ ;
+ MaybeTerm = yes(Term),
+ parse_foreign_type_assertions(Term, AssertionsList),
+ Assertions = foreign_type_assertions(AssertionsList)
+ ).
:- pred parse_foreign_type_assertions(term::in,
list(foreign_type_assertion)::out) is semidet.
@@ -1602,12 +1608,16 @@ parse_foreign_type_assertions(Term, Assertions) :-
parse_foreign_type_assertion(Term, Assertion) :-
Term = term.functor(term.atom(Constant), [], _),
+ (
Constant = "can_pass_as_mercury_type",
- Assertion = foreign_type_can_pass_as_mercury_type.
-parse_foreign_type_assertion(Term, Assertion) :-
- Term = term.functor(term.atom(Constant), [], _),
+ Assertion = foreign_type_can_pass_as_mercury_type
+ ;
Constant = "stable",
- Assertion = foreign_type_stable.
+ Assertion = foreign_type_stable
+ ;
+ Constant = "word_aligned_pointer",
+ Assertion = foreign_type_word_aligned_pointer
+ ).
% This predicate parses foreign_decl pragmas.
%
diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m
index 8b2e51c..c88a359 100644
--- a/compiler/type_ctor_info.m
+++ b/compiler/type_ctor_info.m
@@ -356,10 +356,7 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
TypeBody = hlds_foreign_type(ForeignBody),
foreign_type_body_to_exported_type(ModuleInfo, ForeignBody, _, _,
Assertions),
- (
- list.member(foreign_type_can_pass_as_mercury_type, Assertions),
- list.member(foreign_type_stable, Assertions)
- ->
+ ( asserted_stable(Assertions) ->
IsStable = is_stable
;
IsStable = is_not_stable
diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi
index 89ee1cd..5feee36 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -7319,7 +7319,8 @@ using the following syntax:
[@var{ForeignTypeAssertion}, @dots{}]).
@end example
-Currently, two kinds of assertions are supported.
+Currently, three kinds of assertions are supported.
+
The @samp{can_pass_as_mercury_type} assertion
states that on the C backends, values of the given type
can be passed to and from Mercury code without boxing,
@@ -7332,8 +7333,18 @@ and violations are very likely to result in
the generated executable silently doing the wrong thing,
we do not recommend the use of assertions
unless you are an implementor of the Mercury system.
+
+The @samp{word_aligned_pointer} assertion implies
+ at samp{can_pass_as_mercury_type} and additionally states that values of the
+given type are pointer values clear in the tag bits.
+It allows the Mercury implementation to avoid boxing values of the given type
+when the type appears as the sole argument of a data constructor.
+We do not recommend use of the assertion without a specific need or knowledge
+of the Mercury implementation.
+
The @samp{stable} assertion is meaningful
-only in the presence of the @samp{can_pass_as_mercury_type} assertion.
+only in the presence of the @samp{can_pass_as_mercury_type}
+or @samp{word_aligned_pointer} assertions.
It states that either the C type is an integer type,
or it is a pointer type pointing to memory that will never change.
Together, these assertions are sufficient to allow tabling
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 0d1f507..4e3092c 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -359,6 +359,7 @@ ORDINARY_PROGS = \
user_defined_equality2 \
utf8_io \
value_enum \
+ word_aligned_pointer \
words_separator \
write \
write_float_special \
diff --git a/tests/hard_coded/word_aligned_pointer.exp b/tests/hard_coded/word_aligned_pointer.exp
new file mode 100644
index 0000000..c114778
--- /dev/null
+++ b/tests/hard_coded/word_aligned_pointer.exp
@@ -0,0 +1,4 @@
+yes(0xcafe)
+yes(0xcafe)
+yes(0xcafe)
+yes(0xcafe)
diff --git a/tests/hard_coded/word_aligned_pointer.m b/tests/hard_coded/word_aligned_pointer.m
new file mode 100644
index 0000000..6b07198
--- /dev/null
+++ b/tests/hard_coded/word_aligned_pointer.m
@@ -0,0 +1,52 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+% Test foreign type assertion `word_aligned_pointer'.
+%---------------------------------------------------------------------------%
+
+:- module word_aligned_pointer.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+:- import_module string.
+
+:- import_module word_aligned_pointer_2.
+
+%---------------------------------------------------------------------------%
+
+main(!IO) :-
+ % Construct values in different modules.
+ X = yes(make_foo),
+ Y = word_aligned_pointer_2.make_bar,
+
+ % Deconstruct in this module.
+ word_aligned_pointer.write_bar(X, !IO),
+ word_aligned_pointer.write_bar(Y, !IO),
+
+ % Deconstruct in the other module.
+ word_aligned_pointer_2.write_bar(X, !IO),
+ word_aligned_pointer_2.write_bar(Y, !IO).
+
+%---------------------------------------------------------------------------%
+
+:- pred write_bar(bar::in, io::di, io::uo) is det.
+
+write_bar(Bar, !IO) :-
+ (
+ Bar = yes(Foo),
+ format("yes(0x%x)\n", [i(get_foo(Foo))], !IO)
+ ;
+ Bar = no,
+ write_string("no", !IO)
+ ).
+
+%---------------------------------------------------------------------------%
diff --git a/tests/hard_coded/word_aligned_pointer_2.m b/tests/hard_coded/word_aligned_pointer_2.m
new file mode 100644
index 0000000..8c8b444
--- /dev/null
+++ b/tests/hard_coded/word_aligned_pointer_2.m
@@ -0,0 +1,82 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+
+:- module word_aligned_pointer_2.
+:- interface.
+
+:- import_module io.
+
+ % abstract exported foreign type with `word_aligned_pointer' assertion
+:- type foo.
+
+:- type bar
+ ---> yes(foo) % direct argument functor
+ ; no.
+
+:- func make_foo = foo.
+
+:- func get_foo(foo) = int.
+
+:- func make_bar = bar.
+
+:- pred write_bar(bar::in, io::di, io::uo) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+:- import_module string.
+
+:- type foo
+ ---> foo(int).
+
+:- pragma foreign_type("C", foo, "MR_Word", [word_aligned_pointer]).
+
+%---------------------------------------------------------------------------%
+
+:- pragma no_inline(make_foo/0).
+
+:- pragma foreign_proc("C",
+ make_foo = (X::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ X = MR_mkbody(0xcafe);
+").
+
+make_foo = foo(0xcafe).
+
+%---------------------------------------------------------------------------%
+
+:- pragma foreign_proc("C",
+ get_foo(X::in) = (Int::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ assert(X == MR_strip_tag(X));
+ Int = MR_unmkbody(X);
+").
+
+get_foo(foo(I)) = I.
+
+%---------------------------------------------------------------------------%
+
+:- pragma no_inline(make_bar/0).
+
+make_bar = yes(make_foo).
+
+%---------------------------------------------------------------------------%
+
+:- pragma no_inline(write_bar/3).
+
+write_bar(Bar, !IO) :-
+ (
+ Bar = yes(Foo),
+ format("yes(0x%x)\n", [i(get_foo(Foo))], !IO)
+ ;
+ Bar = no,
+ write_string("no", !IO)
+ ).
+
+%---------------------------------------------------------------------------%
--
2.1.2
More information about the reviews
mailing list