[m-rev.] for review: direct argument functor type representation
Peter Wang
novalazy at gmail.com
Fri May 20 10:26:58 AEST 2011
Branches: main
Implement a type representation optimisation ("direct argument functors"),
where a functor with exactly one argument can be represented by a tagged
pointer to the argument value, which itself does not require the tag bits,
e.g.
:- type maybe_foo ---> yes(foo) ; no.
:- type foo ---> foo(int, int). % aligned pointer
To ensure that all modules which could construct or deconstruct the functor
agree on the type representation, I had planned to automatically generate
pragmas in .int files, to notify importing modules about functors using
the optimised representation:
:- pragma direct_arg(maybe_foo/0, [yes/1]).
However, the compiler does not perform enough (or any) semantic analysis
while making interface files. The fallback solution is to only use the
optimised representation when all importing modules can be guaranteed to
import both the top-level type and the argument type, namely, when both
types are exported from the same module. We also allow certain built-in
argument types; currently this only includes tuples.
The pragmas are necessarily generated for any local types written out to
.opt files. They may also be added manually to source files by Mercury
programmers. The pragmas will be copied into .int files by the compiler
without any analysis, and only checked when the module is actually compiled.
The compiler shows a speedup of 1.3% due to this change, when generating
high-level C code. There was no significant difference when generating
low-level code. The compiler was built in asm_fast.gc
with -O5 --intermodule-optimisation.
mercury_compile.new average of 6 with ignore=1 9.55
mercury_compile.old average of 6 with ignore=1 9.68
compiler/hlds_data.m:
Add an argument to the `unshared_tag' option of `cons_tag' to
indicate whether the optimisation applies.
compiler/add_pragma.m:
compiler/add_type.m:
compiler/make_hlds_passes.m:
At the end of pass 2 of `do_parse_tree_to_hlds', conservatively
convert `unshared_tag' tags to use the optimised representation
where possible.
Later, further convert `unshared_tag' tags as directed by
`direct_arg' pragmas.
compiler/type_util.m:
Add the predicate which decides whether a functor can or must use
the optimised representation.
compiler/ml_unify_gen.m:
compiler/unify_gen.m:
Generate different code to construct/deconstruct direct argument
functors.
compiler/prog_item.m:
Add `pragma_direct_arg' items.
compiler/module_qual.m:
Module qualify type names in `pragma direct_arg'.
compiler/mercury_to_mercury.m:
Write out `pragma direct_arg'.
compiler/intermod.m:
Write `direct_arg' pragmas to .opt files for any type which is
opt-exported and has functors which use the optimised
representation.
compiler/prog_io_pragma.m:
Parse `direct_arg' pragmas.
compiler/rtti.m:
compiler/rtti_out.m:
Add a field to the types which describe the location of secondary
tag options. The functors which can use the optimised representation
are a subset of those which require no secondary tag.
Output "MR_SECTAG_NONE_DIRECT_ARG" instead of "MR_SECTAG_NONE" in
RTTI structures when applicable.
compiler/bytecode_gen.m:
compiler/equiv_type.m:
compiler/export.m:
compiler/hlds_code_util.m:
compiler/hlds_pred.m:
compiler/lco.m:
compiler/make_tags.m:
compiler/ml_switch_gen.m:
compiler/ml_tag_switch.m:
compiler/ml_type_gen.m:
compiler/modules.m:
compiler/recompilation.version.m:
compiler/rtti_to_mlds.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/tag_switch.m:
compiler/type_ctor_info.m:
Conform to changes.
compiler/code_info.m:
Fix formatting.
doc/reference_manual.texi:
Add commented out documentation for `:- pragma direct_arg'.
library/construct.m:
Handle MR_SECTAG_NONE_DIRECT_ARG in construct.construct/3.
runtime/mercury_deconstruct.c:
runtime/mercury_deep_copy_body.h:
runtime/mercury_ml_expand_body.h:
runtime/mercury_table_type_body.h:
runtime/mercury_term_size.c:
runtime/mercury_type_info.h:
runtime/mercury_unify_compare_body.h:
Add MR_SECTAG_NONE_DIRECT_ARG.
Handle MR_SECTAG_NONE_DIRECT_ARG in RTTI code.
runtime/mercury_grade.h:
Bump binary compatibility version number.
tests/hard_coded/Mercury.options:
tests/hard_coded/Mmakefile:
tests/hard_coded/construct_test.exp:
tests/hard_coded/construct_test.m:
tests/hard_coded/direct_arg_intermod1.exp:
tests/hard_coded/direct_arg_intermod1.m:
tests/hard_coded/direct_arg_intermod2.m:
tests/hard_coded/direct_arg_intermod3.m:
tests/hard_coded/direct_arg_parent.exp:
tests/hard_coded/direct_arg_parent.m:
tests/hard_coded/direct_arg_sub.m:
Add test cases.
diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m
index 111bb66..8842aca 100644
--- a/compiler/add_pragma.m
+++ b/compiler/add_pragma.m
@@ -38,6 +38,11 @@
prog_context::in, module_info::in, module_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
+:- pred add_pragma_direct_arg(sym_name::in, arity::in,
+ list(sym_name_and_arity)::in, import_status::in,
+ prog_context::in, module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
:- pred add_pragma_foreign_export_enum(foreign_language::in, sym_name::in,
arity::in, export_enum_attributes::in, assoc_list(sym_name, string)::in,
import_status::in, prog_context::in, module_info::in, module_info::out,
@@ -126,6 +131,7 @@
:- import_module backend_libs.foreign.
:- import_module backend_libs.rtti.
:- import_module check_hlds.mode_util.
+:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.hlds_args.
:- import_module hlds.hlds_data.
@@ -312,6 +318,11 @@ add_pragma(ItemPragma, !Status, !ModuleInfo, !Specs) :-
% have been added).
Pragma = pragma_reserve_tag(_, _)
;
+ % Handle pragma direct_arg decls later on (when we process clauses
+ % -- they need to be handled after the type definitions
+ % have been added).
+ Pragma = pragma_direct_arg(_, _, _)
+ ;
Pragma = pragma_promise_pure(Name, Arity),
add_pred_marker("promise_pure", Name, Arity, ImportStatus,
Context, marker_promised_pure, [], !ModuleInfo, !Specs)
@@ -545,7 +556,7 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
;
(
TypeBody0 = hlds_du_type(Body, _CtorTags0, _CheaperTagTest,
- _IsEnum0, MaybeUserEqComp, ReservedTag0, _ReservedAddr,
+ _DuTypeKind, MaybeUserEqComp, ReservedTag0, _ReservedAddr,
IsForeign),
(
ReservedTag0 = uses_reserved_tag,
@@ -569,9 +580,9 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
ReservedTag = uses_reserved_tag,
module_info_get_globals(!.ModuleInfo, Globals),
assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor,
- ReservedTag, Globals, CtorTags, ReservedAddr, EnumDummy),
+ ReservedTag, Globals, CtorTags, ReservedAddr, DuTypeKind),
TypeBody = hlds_du_type(Body, CtorTags, no_cheaper_tag_test,
- EnumDummy, MaybeUserEqComp, ReservedTag, ReservedAddr,
+ DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr,
IsForeign),
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
replace_type_ctor_defn(TypeCtor, TypeDefn,
@@ -614,6 +625,154 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
%-----------------------------------------------------------------------------%
+add_pragma_direct_arg(TypeName, TypeArity, PragmaCtors, PragmaStatus, Context,
+ !ModuleInfo, !Specs) :-
+ TypeCtor = type_ctor(TypeName, TypeArity),
+ module_info_get_type_table(!.ModuleInfo, TypeTable0),
+ ContextPieces = [
+ words("In"), quote("pragma direct_arg"), words("declaration for"),
+ sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
+ ],
+ ( search_type_ctor_defn(TypeTable0, TypeCtor, TypeDefn0) ->
+ hlds_data.get_type_defn_body(TypeDefn0, TypeBody0),
+ hlds_data.get_type_defn_status(TypeDefn0, TypeStatus),
+ (
+ not (
+ TypeStatus = PragmaStatus
+ ;
+ TypeStatus = status_abstract_exported,
+ ( PragmaStatus = status_local
+ ; PragmaStatus = status_exported_to_submodules
+ )
+ ;
+ % Don't issue an error for pragmas imported from .opt files for
+ % types which may have been imported by or from the parent
+ % module.
+ PragmaStatus = status_opt_imported,
+ TypeStatus = status_imported(_)
+ )
+ ->
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error:"), quote("pragma direct_arg"),
+ words("declaration must have"),
+ words("the same visibility as the type definition.")
+ ]
+ ;
+ (
+ TypeBody0 = hlds_du_type(Body, CtorTags0, CheaperTagTest,
+ DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr,
+ IsForeign),
+ list.map_foldl(apply_direct_args(!.ModuleInfo, TypeCtor, Body,
+ PragmaStatus),
+ PragmaCtors, ErrorPieces0, CtorTags0, CtorTags),
+ list.condense(ErrorPieces0, ErrorPieces),
+ (
+ ErrorPieces = [],
+ MaybeSeverity = no,
+ TypeBody = hlds_du_type(Body, CtorTags, CheaperTagTest,
+ DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr,
+ IsForeign),
+ hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
+ replace_type_ctor_defn(TypeCtor, TypeDefn,
+ TypeTable0, TypeTable),
+ module_info_set_type_table(TypeTable, !ModuleInfo)
+ ;
+ ErrorPieces = [_ | _],
+ MaybeSeverity = yes(severity_error)
+ )
+ ;
+ ( TypeBody0 = hlds_eqv_type(_)
+ ; TypeBody0 = hlds_foreign_type(_)
+ ; TypeBody0 = hlds_solver_type(_, _)
+ ; TypeBody0 = hlds_abstract_type(_)
+ ),
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error:"), sym_name_and_arity(TypeName / TypeArity),
+ words("is not a discriminated union type."), nl
+ ]
+ )
+ )
+ ;
+ MaybeSeverity = yes(severity_error),
+ ErrorPieces = [
+ words("error: undefined type"),
+ sym_name_and_arity(TypeName / TypeArity), suffix("."), nl
+ ]
+ ),
+ (
+ ErrorPieces = []
+ ;
+ ErrorPieces = [_ | _],
+ (
+ MaybeSeverity = yes(Severity)
+ ;
+ MaybeSeverity = no,
+ unexpected(this_file, "add_pragma_direct_arg: no severity")
+ ),
+ Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
+ Spec = error_spec(Severity, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ ).
+
+:- pred apply_direct_args(module_info::in, type_ctor::in,
+ list(constructor)::in, import_status::in, sym_name_and_arity::in,
+ format_components::out, cons_tag_values::in, cons_tag_values::out) is det.
+
+apply_direct_args(ModuleInfo, TypeCtor, Ctors, PragmaStatus, PragmaCtor,
+ ErrorPieces, !ConsTagValues) :-
+ PragmaCtor = SymName / Arity,
+ ConsId = cons(SymName, Arity, TypeCtor),
+ (
+ map.search(!.ConsTagValues, ConsId, ConsTag0),
+ find_constructor(Ctors, SymName, Arity, Ctor)
+ ->
+ (
+ ConsTag0 = unshared_tag(Ptag, _),
+ can_be_direct_arg_functor(ModuleInfo, TypeCtor, Ctor,
+ yes(PragmaStatus))
+ ->
+ ConsTag = unshared_tag(Ptag, is_direct_arg_functor),
+ map.det_update(ConsId, ConsTag, !ConsTagValues),
+ ErrorPieces = []
+ ;
+ ConsTag0 = shared_remote_tag(_, _),
+ can_be_direct_arg_functor(ModuleInfo, TypeCtor, Ctor,
+ yes(PragmaStatus))
+ ->
+ % Ignore the pragma; it may be applicable on other architectures
+ % with more tag bits.
+ ErrorPieces = []
+ ;
+ ErrorPieces = [
+ sym_name_and_arity(SymName / Arity),
+ words("cannot be represented as a direct pointer to its"),
+ words("sole argument.")
+ ]
+ )
+ ;
+ ErrorPieces = [
+ sym_name_and_arity(SymName / Arity),
+ words("does not match any constructor.")
+ ]
+ ).
+
+:- pred find_constructor(list(constructor)::in, sym_name::in, arity::in,
+ constructor::out) is semidet.
+
+find_constructor([H | T], SymName, Arity, Ctor) :-
+ (
+ H = ctor(_, _, SymName, Args, _),
+ list.length(Args, Arity)
+ ->
+ Ctor = H
+ ;
+ find_constructor(T, SymName, Arity, Ctor)
+ ).
+
+%-----------------------------------------------------------------------------%
+
add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
Overrides, _ImportStatus, Context, !ModuleInfo, !Specs) :-
TypeCtor = type_ctor(TypeName, TypeArity),
diff --git a/compiler/add_type.m b/compiler/add_type.m
index d866ab8..989ece7 100644
--- a/compiler/add_type.m
+++ b/compiler/add_type.m
@@ -56,6 +56,7 @@
:- import_module backend_libs.
:- import_module backend_libs.foreign.
+:- import_module check_hlds.type_util.
:- import_module hlds.make_hlds.add_special_pred.
:- import_module hlds.make_hlds.make_hlds_error.
:- import_module hlds.make_hlds.make_hlds_passes.
@@ -360,7 +361,8 @@ process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :-
get_type_defn_need_qualifier(TypeDefn, NeedQual),
module_info_get_globals(!.ModuleInfo, Globals),
(
- Body = hlds_du_type(ConsList, _, _, _, UserEqCmp, ReservedTag, _, _),
+ Body = hlds_du_type(ConsList, ConsTagValues0, _, _, UserEqCmp,
+ ReservedTag, _, _),
module_info_get_cons_table(!.ModuleInfo, Ctors0),
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0),
@@ -387,6 +389,22 @@ process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :-
!:Specs = CtorAddSpecs ++ !.Specs
),
+ % Figure out which functors can be represented as tagged pointers to
+ % their sole arguments.
+ list.foldl2(convert_direct_arg_functor(!.ModuleInfo, TypeCtor),
+ ConsList, ConsTagValues0, ConsTagValues, no, Changed),
+ (
+ Changed = yes,
+ DirectArgBody = Body ^ du_type_cons_tag_values := ConsTagValues,
+ set_type_defn_body(DirectArgBody, TypeDefn, DirectArgTypeDefn),
+ module_info_get_type_table(!.ModuleInfo, TypeTable0),
+ replace_type_ctor_defn(TypeCtor, DirectArgTypeDefn,
+ TypeTable0, TypeTable),
+ module_info_set_type_table(TypeTable, !ModuleInfo)
+ ;
+ Changed = no
+ ),
+
% XXX Why is this being done now, rather than *after* all the types
% have been added into the HLDS?
(
@@ -425,6 +443,35 @@ process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :-
!ModuleInfo)
).
+:- pred convert_direct_arg_functor(module_info::in, type_ctor::in,
+ constructor::in, cons_tag_values::in, cons_tag_values::out,
+ bool::in, bool::out) is det.
+
+convert_direct_arg_functor(ModuleInfo, TypeCtor, Ctor, !ConsTagValues,
+ !Changed) :-
+ Ctor = ctor(_ExistTVars, _Constraints, SymName, Args, _),
+ (
+ Args = [_],
+ Arity = 1,
+ ConsId = cons(SymName, Arity, TypeCtor),
+ map.lookup(!.ConsTagValues, ConsId, ConsTag0),
+ (
+ ConsTag0 = unshared_tag(TagBits, is_not_direct_arg_functor),
+ ExplicitPragma = no,
+ can_be_direct_arg_functor(ModuleInfo, TypeCtor, Ctor, ExplicitPragma)
+ ->
+ ConsTag = unshared_tag(TagBits, is_direct_arg_functor),
+ map.det_update(ConsId, ConsTag, !ConsTagValues),
+ !:Changed = yes
+ ;
+ true
+ )
+ ;
+ Args = []
+ ;
+ Args = [_, _| _]
+ ).
+
% Check_foreign_type ensures that if we are generating code for a specific
% backend that the foreign type has a representation on that backend.
%
diff --git a/compiler/bytecode_gen.m b/compiler/bytecode_gen.m
index 9bb49a5..c7c7032 100644
--- a/compiler/bytecode_gen.m
+++ b/compiler/bytecode_gen.m
@@ -778,7 +778,7 @@ map_cons_tag(no_tag, byte_no_tag).
% `single_functor' is just an optimized version of `unshared_tag(0)'
% this optimization is not important for the bytecode
map_cons_tag(single_functor_tag, byte_unshared_tag(0)).
-map_cons_tag(unshared_tag(Primary), byte_unshared_tag(Primary)).
+map_cons_tag(unshared_tag(Primary, _), byte_unshared_tag(Primary)).
map_cons_tag(shared_remote_tag(Primary, Secondary),
byte_shared_remote_tag(Primary, Secondary)).
map_cons_tag(shared_local_tag(Primary, Secondary),
diff --git a/compiler/code_info.m b/compiler/code_info.m
index 14dd15e..9193fe5 100644
--- a/compiler/code_info.m
+++ b/compiler/code_info.m
@@ -3811,7 +3811,7 @@ assign_expr_to_var(Var, Rval, Code, !CI) :-
(
Lvals = [],
var_locn_assign_expr_to_var(Var, Rval, Code,
- VarLocnInfo0, VarLocnInfo)
+ VarLocnInfo0, VarLocnInfo)
;
Lvals = [_ | _],
unexpected(this_file, "assign_expr_to_var: non-var lvals")
diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m
index 60ba160..ad3a765 100644
--- a/compiler/equiv_type.m
+++ b/compiler/equiv_type.m
@@ -649,6 +649,7 @@ replace_in_pragma_info(ModuleName, Location, EqvMap, _EqvInstMap,
; Pragma0 = pragma_promise_semipure(_, _)
; Pragma0 = pragma_require_feature_set(_)
; Pragma0 = pragma_reserve_tag(_, _)
+ ; Pragma0 = pragma_direct_arg(_, _, _)
; Pragma0 = pragma_source_file(_)
; Pragma0 = pragma_structure_reuse(_, _, _, _, _, _)
; Pragma0 = pragma_structure_sharing(_, _, _, _, _, _)
diff --git a/compiler/export.m b/compiler/export.m
index fc1474d..9855a0b 100644
--- a/compiler/export.m
+++ b/compiler/export.m
@@ -905,7 +905,7 @@ foreign_const_name_and_tag(TypeCtor, Mapping, TagValues, Ctor,
; TagVal = deep_profiling_proc_layout_tag(_, _)
; TagVal = table_io_decl_tag(_, _)
; TagVal = single_functor_tag
- ; TagVal = unshared_tag(_)
+ ; TagVal = unshared_tag(_, _)
; TagVal = shared_remote_tag(_, _)
; TagVal = shared_local_tag(_, _)
; TagVal = no_tag
diff --git a/compiler/hlds_code_util.m b/compiler/hlds_code_util.m
index da888ba..b40bb76 100644
--- a/compiler/hlds_code_util.m
+++ b/compiler/hlds_code_util.m
@@ -90,7 +90,7 @@ cons_id_to_tag(ModuleInfo, ConsId) = Tag:-
( ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
),
- Tag = unshared_tag(0)
+ Tag = unshared_tag(0, is_not_direct_arg_functor)
;
ConsId = tabling_info_const(ShroudedPredProcId),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m
index 6ce6e20..195c7ef 100644
--- a/compiler/hlds_data.m
+++ b/compiler/hlds_data.m
@@ -378,13 +378,15 @@
% For these types, we don't need any tags. We just store a pointer
% to the argument vector.
- ; unshared_tag(tag_bits)
+ ; unshared_tag(tag_bits, maybe_direct_arg_functor)
% This is for constants or functors which can be distinguished
% with just a primary tag. An "unshared" tag is one which fits
% on the bottom of a pointer (i.e. two bits for 32-bit
% architectures, or three bits for 64-bit architectures), and is
% used for just one functor. For constants we store a tagged zero,
- % for functors we store a tagged pointer to the argument vector.
+ % for functors we store a tagged pointer to the argument vector,
+ % or a tagged pointer to the only argument (see
+ % maybe_direct_arg_functor).
; shared_remote_tag(tag_bits, int)
% This is for functors or constants which require more than just
@@ -420,6 +422,15 @@
% the value isn't any of the reserved addresses before testing
% for the constructor's own cons_tag.
+:- type maybe_direct_arg_functor
+ ---> is_not_direct_arg_functor
+ ; is_direct_arg_functor.
+ % This functor is represented as a tagged pointer directly to its
+ % only argument. This is possible when the representation of the
+ % argument type is known not to use the tag bits, and it can be
+ % guaranteed that all modules which could construct or deconstruct
+ % this functor will infer the same representation.
+
:- type reserved_address
---> null_pointer
% This is for constants which are represented as a null pointer.
@@ -504,7 +515,7 @@ get_primary_tag(Tag) = MaybePrimaryTag :-
Tag = single_functor_tag,
MaybePrimaryTag = yes(0)
;
- ( Tag = unshared_tag(PrimaryTag)
+ ( Tag = unshared_tag(PrimaryTag, _DirectArg)
; Tag = shared_remote_tag(PrimaryTag, _SecondaryTag)
; Tag = shared_local_tag(PrimaryTag, _SecondaryTag)
),
@@ -528,7 +539,7 @@ get_secondary_tag(Tag) = MaybeSecondaryTag :-
; Tag = table_io_decl_tag(_, _)
; Tag = no_tag
; Tag = reserved_address_tag(_)
- ; Tag = unshared_tag(_PrimaryTag)
+ ; Tag = unshared_tag(_PrimaryTag, _)
; Tag = single_functor_tag
),
MaybeSecondaryTag = no
diff --git a/compiler/intermod.m b/compiler/intermod.m
index 4cf1ebb..0835b97 100644
--- a/compiler/intermod.m
+++ b/compiler/intermod.m
@@ -1471,19 +1471,50 @@ write_type(OutInfo, TypeCtor - TypeDefn, !IO) :-
true
),
(
- Body = hlds_du_type(_, ConsTagVals, _, DuTypeKind, _, _, _, _),
+ Body = hlds_du_type(_, ConsTagValsA, _, _, _, _, _, _)
+ ->
+ map.foldl(gather_direct_arg_ctors, ConsTagValsA, [],
+ DirectArgCtors),
+ (
+ DirectArgCtors = []
+ ;
+ DirectArgCtors = [_ | _],
+ DirectArgPragma = pragma_direct_arg(Name, Arity, DirectArgCtors),
+ DirectArgItemPragma = item_pragma_info(user, DirectArgPragma,
+ Context, -1),
+ DirectArgItem = item_pragma(DirectArgItemPragma),
+ mercury_output_item(MercInfo, DirectArgItem, !IO)
+ )
+ ;
+ true
+ ),
+ (
+ Body = hlds_du_type(_, ConsTagValsB, _, DuTypeKind, _, _, _, _),
DuTypeKind = du_type_kind_foreign_enum(Lang)
->
- map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [],
+ map.foldl(gather_foreign_enum_value_pair, ConsTagValsB, [],
ForeignEnumVals),
- Pragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals),
- ForeignItemPragma = item_pragma_info(user, Pragma, Context, -1),
+ ForeignPragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals),
+ ForeignItemPragma = item_pragma_info(user, ForeignPragma, Context, -1),
ForeignItem = item_pragma(ForeignItemPragma),
mercury_output_item(MercInfo, ForeignItem, !IO)
;
true
).
+:- pred gather_direct_arg_ctors(cons_id::in, cons_tag::in,
+ list(sym_name_and_arity)::in, list(sym_name_and_arity)::out) is det.
+
+gather_direct_arg_ctors(ConsId, ConsTag, !DirectArgCtors) :-
+ (
+ ConsId = cons(SymName, Arity, _),
+ ConsTag = unshared_tag(_, is_direct_arg_functor)
+ ->
+ !:DirectArgCtors = [SymName / Arity | !.DirectArgCtors]
+ ;
+ true
+ ).
+
:- pred gather_foreign_enum_value_pair(cons_id::in, cons_tag::in,
assoc_list(sym_name, string)::in, assoc_list(sym_name, string)::out)
is det.
diff --git a/compiler/lco.m b/compiler/lco.m
index f6f149e..3c8bcb3 100644
--- a/compiler/lco.m
+++ b/compiler/lco.m
@@ -625,7 +625,7 @@ lco_in_conj([RevGoal | RevGoals], !.Unifies, !.UnifyInputVars, MaybeGoals,
(
ConsTag = single_functor_tag
;
- ConsTag = unshared_tag(_)
+ ConsTag = unshared_tag(_, is_not_direct_arg_functor)
;
ConsTag = shared_remote_tag(_, _)
)
diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m
index 190a4aa..c0a4ac9 100644
--- a/compiler/make_hlds_passes.m
+++ b/compiler/make_hlds_passes.m
@@ -1270,6 +1270,10 @@ add_pass_3_pragma(ItemPragma, !Status, !ModuleInfo, !QualInfo, !Specs) :-
add_pragma_reserve_tag(TypeName, TypeArity, !.Status, Context,
!ModuleInfo, !Specs)
;
+ Pragma = pragma_direct_arg(TypeName, TypeArity, Ctors),
+ add_pragma_direct_arg(TypeName, TypeArity, Ctors, !.Status, Context,
+ !ModuleInfo, !Specs)
+ ;
Pragma = pragma_foreign_export_enum(Lang, TypeName, TypeArity,
Attributes, Overrides),
add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
diff --git a/compiler/make_tags.m b/compiler/make_tags.m
index 11351f7..ea1fe56 100644
--- a/compiler/make_tags.m
+++ b/compiler/make_tags.m
@@ -319,7 +319,7 @@ assign_unshared_tags(TypeCtor, [Ctor | Ctors], Val, MaxTag, ReservedAddresses,
ReservedAddresses, !CtorTags)
;
Tag = maybe_add_reserved_addresses(ReservedAddresses,
- unshared_tag(Val)),
+ unshared_tag(Val, is_not_direct_arg_functor)),
% We call set instead of det_insert because we don't want types
% that erroneously contain more than one copy of a cons_id to crash
% the compiler.
diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m
index bdaada4..d986e1c 100644
--- a/compiler/mercury_to_mercury.m
+++ b/compiler/mercury_to_mercury.m
@@ -820,6 +820,16 @@ mercury_output_item_pragma(Info, ItemPragma, !IO) :-
add_int(TypeArity, !IO),
add_string(").\n", !IO)
;
+ Pragma = pragma_direct_arg(TypeName, TypeArity, Ctors),
+ add_string(":- pragma direct_arg(", !IO),
+ mercury_format_bracketed_sym_name(TypeName, next_to_graphic_token,
+ !IO),
+ add_string("/", !IO),
+ add_int(TypeArity, !IO),
+ add_string(", [", !IO),
+ io.write_list(Ctors, ", ", mercury_format_sym_name_and_arity, !IO),
+ add_string("]).\n", !IO)
+ ;
Pragma = pragma_promise_pure(Pred, Arity),
mercury_output_pragma_decl(Pred, Arity, pf_predicate,
"promise_pure", no, !IO)
@@ -4716,6 +4726,14 @@ mercury_format_sym_name(Name, NextToGraphicToken, !U) :-
mercury_format_quoted_atom(PredName, NextToGraphicToken, !U)
).
+:- pred mercury_format_sym_name_and_arity(sym_name_and_arity::in, U::di, U::uo)
+ is det <= output(U).
+
+mercury_format_sym_name_and_arity(Name / Arity, !U) :-
+ mercury_format_sym_name(Name, !U),
+ add_char('/', !U),
+ add_int(Arity, !U).
+
:- pred mercury_quote_atom(string::in, needs_quotes::in, io::di, io::uo)
is det.
diff --git a/compiler/ml_switch_gen.m b/compiler/ml_switch_gen.m
index 83aca91..5949bef 100644
--- a/compiler/ml_switch_gen.m
+++ b/compiler/ml_switch_gen.m
@@ -582,7 +582,7 @@ ml_tagged_cons_id_to_match_cond(MLDS_Type, TaggedConsId, MatchCond) :-
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
; Tag = single_functor_tag
- ; Tag = unshared_tag(_)
+ ; Tag = unshared_tag(_, _)
; Tag = shared_remote_tag(_, _)
; Tag = shared_local_tag(_, _)
; Tag = no_tag
diff --git a/compiler/ml_tag_switch.m b/compiler/ml_tag_switch.m
index 782771e..6438d60 100644
--- a/compiler/ml_tag_switch.m
+++ b/compiler/ml_tag_switch.m
@@ -169,7 +169,7 @@ gen_ptag_case(PtagCase, CodeMap, Var, CanFail, CodeModel, PtagCountMap,
"ml_tag_switch.m: secondary tag locations differ"),
map.to_assoc_list(GoalMap, GoalList),
(
- SecTagLocn = sectag_none,
+ SecTagLocn = sectag_none(_),
% There is no secondary tag, so there is no switch on it.
(
GoalList = [],
@@ -282,7 +282,7 @@ gen_stag_switch(Cases, CodeMap, PrimaryTag, StagLocn, Var, CodeModel,
STagRval = ml_gen_secondary_tag_rval(ModuleInfo, PrimaryTag, VarType,
VarRval)
;
- StagLocn = sectag_none,
+ StagLocn = sectag_none(_),
unexpected(this_file, "gen_stag_switch: no stag")
),
diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m
index e5a177e..e16ed45 100644
--- a/compiler/ml_type_gen.m
+++ b/compiler/ml_type_gen.m
@@ -324,7 +324,7 @@ ml_gen_enum_constant(Context, TypeCtor, ConsTagValues, MLDS_Type, Ctor)
; TagVal = deep_profiling_proc_layout_tag(_, _)
; TagVal = table_io_decl_tag(_, _)
; TagVal = single_functor_tag
- ; TagVal = unshared_tag(_)
+ ; TagVal = unshared_tag(_, _)
; TagVal = shared_remote_tag(_, _)
; TagVal = shared_local_tag(_, _)
; TagVal = no_tag
@@ -869,7 +869,7 @@ ml_tag_uses_base_class(Tag) = UsesBaseClass :-
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
- ; Tag = unshared_tag(_)
+ ; Tag = unshared_tag(_, _)
; Tag = shared_remote_tag(_, _)
; Tag = shared_local_tag(_, _)
; Tag = no_tag
@@ -1248,7 +1248,7 @@ generate_foreign_enum_constant(TypeCtor, Mapping, TagValues, MLDS_Type, Ctor,
; TagVal = deep_profiling_proc_layout_tag(_, _)
; TagVal = table_io_decl_tag(_, _)
; TagVal = single_functor_tag
- ; TagVal = unshared_tag(_)
+ ; TagVal = unshared_tag(_, _)
; TagVal = shared_remote_tag(_, _)
; TagVal = shared_local_tag(_, _)
; TagVal = no_tag
diff --git a/compiler/ml_unify_gen.m b/compiler/ml_unify_gen.m
index d43da38..99430a0 100644
--- a/compiler/ml_unify_gen.m
+++ b/compiler/ml_unify_gen.m
@@ -298,13 +298,19 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
ml_gen_construct_tag(ThisTag, Type, Var, ConsId, Args, ArgModes,
TakeAddr, HowToConstruct, Context, Statements, !Info)
;
- Tag = no_tag,
+ (
+ Tag = no_tag,
+ Ptag = 0
+ ;
+ Tag = unshared_tag(Ptag, is_direct_arg_functor)
+ ),
(
Args = [ArgVar],
ArgModes = [_ArgMode]
->
ml_gen_var(!.Info, Var, VarLval),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
( ml_gen_info_search_const_var(!.Info, ArgVar, ArgGroundTerm) ->
ArgGroundTerm = ml_ground_term(ArgRval, _ArgType,
MLDS_ArgType),
@@ -312,8 +318,7 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
ml_gen_box_const_rval(ModuleInfo, Context, MLDS_ArgType,
ArgRval, Rval0, GlobalData0, GlobalData),
ml_gen_info_set_global_data(GlobalData, !Info),
- MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
- Rval = ml_unop(cast(MLDS_Type), Rval0),
+ Rval = ml_cast_maybe_tag(MLDS_Type, Ptag, Rval0),
GroundTerm = ml_ground_term(Rval, Type, MLDS_Type),
ml_gen_info_set_const_var(Var, GroundTerm, !Info)
;
@@ -321,7 +326,8 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
ml_variable_type(!.Info, ArgVar, ArgType),
ArgRval = ml_lval(ArgVarLval),
ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, Type,
- native_if_possible, ArgRval, Rval)
+ native_if_possible, ArgRval, Rval1),
+ Rval = ml_cast_maybe_tag(MLDS_Type, Ptag, Rval1)
),
Statement = ml_gen_assign(VarLval, Rval, Context),
Statements = [Statement]
@@ -340,7 +346,7 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
Ptag = 0,
MaybeStag = no
;
- Tag = unshared_tag(Ptag),
+ Tag = unshared_tag(Ptag, is_not_direct_arg_functor),
MaybeStag = no
;
Tag = shared_remote_tag(Ptag, Stag),
@@ -468,7 +474,7 @@ ml_gen_constant(Tag, VarType, MLDS_VarType, Rval, !Info) :-
Tag = single_functor_tag,
unexpected(this_file, "ml_gen_constant: single_functor")
;
- Tag = unshared_tag(_),
+ Tag = unshared_tag(_, _),
unexpected(this_file, "ml_gen_constant: unshared_tag")
;
Tag = shared_remote_tag(_, _),
@@ -1103,6 +1109,15 @@ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :-
ml_gen_mktag(Tag) = ml_unop(std_unop(mktag), ml_const(mlconst_int(Tag))).
+:- func ml_cast_maybe_tag(mlds_type, mlds_tag, mlds_rval) = mlds_rval.
+
+ml_cast_maybe_tag(Type, Tag, Rval) = ml_unop(cast(Type), TagRval) :-
+ ( Tag = 0 ->
+ TagRval = Rval
+ ;
+ TagRval = ml_mkword(Tag, Rval)
+ ).
+
:- pred ml_gen_box_or_unbox_const_rval_list(module_info::in,
list(mer_type)::in, list(mer_type)::in, list(mlds_rval)::in,
prog_context::in, list(mlds_rval)::out,
@@ -1391,8 +1406,36 @@ ml_gen_det_deconstruct_tag(Tag, Type, Var, ConsId, Args, Modes, Context,
unexpected(this_file, "ml_code_gen: no_tag: arity != 1")
)
;
+ Tag = unshared_tag(Ptag, is_direct_arg_functor),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ (
+ Args = [Arg],
+ Modes = [Mode]
+ ->
+ ml_variable_type(!.Info, Arg, ArgType),
+ Mode = ((LI - RI) -> (LF - RF)),
+ mode_to_arg_mode(ModuleInfo, (LI -> LF), ArgType, LeftMode),
+ mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode),
+ (
+ LeftMode = top_in,
+ RightMode = top_out
+ ->
+ ml_gen_var(!.Info, Arg, ArgLval),
+ ml_gen_var(!.Info, Var, VarLval),
+ FieldRval = ml_binop(body, ml_lval(VarLval), ml_gen_mktag(Ptag)),
+ Statement = ml_gen_assign(ArgLval, FieldRval, Context),
+ Statements = [Statement]
+ ;
+ unexpected(this_file,
+ "ml_code_gen: is_direct_arg_functor: unexpected mode")
+ )
+ ;
+ unexpected(this_file,
+ "ml_code_gen: is_direct_arg_functor: arity != 1")
+ )
+ ;
( Tag = single_functor_tag
- ; Tag = unshared_tag(_UnsharedTag)
+ ; Tag = unshared_tag(_UnsharedTag, is_not_direct_arg_functor)
; Tag = shared_remote_tag(_PrimaryTag, _SecondaryTag)
),
ml_gen_var(!.Info, Var, VarLval),
@@ -1425,7 +1468,7 @@ ml_tag_offset_and_argnum(Tag, TagBits, OffSet, ArgNum) :-
OffSet = 0,
ArgNum = 1
;
- Tag = unshared_tag(UnsharedTag),
+ Tag = unshared_tag(UnsharedTag, _),
TagBits = UnsharedTag,
OffSet = 0,
ArgNum = 1
@@ -1811,7 +1854,7 @@ ml_gen_tag_test_rval(Tag, Type, ModuleInfo, Rval) = TagTestRval :-
Tag = single_functor_tag,
TagTestRval = ml_const(mlconst_true)
;
- Tag = unshared_tag(UnsharedTagNum),
+ Tag = unshared_tag(UnsharedTagNum, _DirectArg),
RvalTag = ml_unop(std_unop(tag), Rval),
UnsharedTag = ml_unop(std_unop(mktag),
ml_const(mlconst_int(UnsharedTagNum))),
@@ -2125,14 +2168,19 @@ ml_gen_ground_term_conjunct_tag(ModuleInfo, Target, HighLevelData, VarTypes,
VarTypes, Var, VarType, MLDS_Type, ConsId, ThisTag, Args, Context,
!GlobalData, !GroundTermMap)
;
- ConsTag = no_tag,
+ (
+ ConsTag = no_tag,
+ Ptag = 0
+ ;
+ ConsTag = unshared_tag(Ptag, is_direct_arg_functor)
+ ),
(
Args = [Arg],
map.det_remove(Arg, ArgGroundTerm, !GroundTermMap),
ArgGroundTerm = ml_ground_term(ArgRval, _ArgType, MLDS_ArgType),
ml_gen_box_const_rval(ModuleInfo, Context, MLDS_ArgType,
ArgRval, Rval0, !GlobalData),
- Rval = ml_unop(cast(MLDS_Type), Rval0),
+ Rval = ml_cast_maybe_tag(MLDS_Type, Ptag, Rval0),
GroundTerm = ml_ground_term(Rval, VarType, MLDS_Type),
map.det_insert(Var, GroundTerm, !GroundTermMap)
;
@@ -2157,7 +2205,7 @@ ml_gen_ground_term_conjunct_tag(ModuleInfo, Target, HighLevelData, VarTypes,
Ptag = 0,
ExtraInitializers = []
;
- ConsTag = unshared_tag(Ptag),
+ ConsTag = unshared_tag(Ptag, is_not_direct_arg_functor),
ExtraInitializers = []
;
ConsTag = shared_remote_tag(Ptag, Stag),
diff --git a/compiler/module_qual.m b/compiler/module_qual.m
index e1587ee..507cb9c 100644
--- a/compiler/module_qual.m
+++ b/compiler/module_qual.m
@@ -1446,6 +1446,11 @@ qualify_pragma(Pragma0, Pragma, !Info, !Specs) :-
qualify_mode_list(ModeList0, ModeList, !Info, !Specs),
Pragma = pragma_termination2_info(PredOrFunc, SymName, ModeList,
SuccessArgs, FailureArgs, Term)
+ ;
+ Pragma0 = pragma_direct_arg(TypeName0, TypeArity0, Ctors),
+ qualify_type_ctor(type_ctor(TypeName0, TypeArity0),
+ type_ctor(TypeName, TypeArity), !Info, !Specs),
+ Pragma = pragma_direct_arg(TypeName, TypeArity, Ctors)
).
:- pred qualify_pragma_vars(list(pragma_var)::in, list(pragma_var)::out,
diff --git a/compiler/modules.m b/compiler/modules.m
index a0fd5cb..5d73062 100644
--- a/compiler/modules.m
+++ b/compiler/modules.m
@@ -1590,13 +1590,15 @@ pragma_allowed_in_interface(Pragma) = Allowed :-
Allowed = no
;
% Note that the parser will strip out `source_file' pragmas anyway,
- % and that `reserve_tag' must be in the interface iff the corresponding
- % type definition is in the interface. This is checked in make_hlds.
+ % and that `reserve_tag' and `direct_arg' must be in the interface iff
+ % the corresponding type definition is in the interface. This is
+ % checked in make_hlds.
( Pragma = pragma_foreign_enum(_, _, _, _)
; Pragma = pragma_foreign_import_module(_, _)
; Pragma = pragma_obsolete(_, _)
; Pragma = pragma_source_file(_)
; Pragma = pragma_reserve_tag(_, _)
+ ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_type_spec(_, _, _, _, _, _, _, _)
; Pragma = pragma_termination_info(_, _, _, _, _)
; Pragma = pragma_termination2_info(_,_, _, _, _, _)
@@ -3784,6 +3786,7 @@ item_needs_foreign_imports(Item) = Langs :-
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_fact_table(_, _, _)
; Pragma = pragma_reserve_tag(_, _)
+ ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_promise_pure(_, _)
; Pragma = pragma_promise_semipure(_, _)
@@ -3882,6 +3885,7 @@ include_in_int_file_implementation(Item) = Include :-
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_fact_table(_, _, _)
; Pragma = pragma_reserve_tag(_, _)
+ ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_promise_pure(_, _)
; Pragma = pragma_promise_semipure(_, _)
@@ -4286,6 +4290,7 @@ reorderable_pragma_type(Pragma) = Reorderable :-
; Pragma = pragma_promise_semipure(_, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_reserve_tag(_, _)
+ ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_terminates(_, _)
; Pragma = pragma_termination_info(_, _, _, _, _)
@@ -4398,6 +4403,7 @@ chunkable_pragma_type(Pragma) = Reorderable :-
; Pragma = pragma_promise_semipure(_, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_reserve_tag(_, _)
+ ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_terminates(_, _)
; Pragma = pragma_termination_info(_, _, _, _, _)
diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m
index 3786833..c782e9c 100644
--- a/compiler/prog_io_pragma.m
+++ b/compiler/prog_io_pragma.m
@@ -215,6 +215,10 @@ parse_pragma_type(ModuleName, PragmaName, PragmaTerms, ErrorTerm, VarSet,
parse_simple_type_pragma(ModuleName, PragmaName, MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
+ PragmaName = "direct_arg",
+ parse_pragma_direct_arg(ModuleName, PragmaTerms, VarSet, ErrorTerm,
+ Context, SeqNum, MaybeItem)
+ ;
(
PragmaName = "memo",
EvalMethod = eval_memo
@@ -1278,6 +1282,60 @@ parse_pragma_require_feature_set(PragmaTerms, VarSet, ErrorTerm, Context,
MaybeItem = error1([Spec])
).
+:- pred parse_pragma_direct_arg(module_name::in, list(term)::in, varset::in,
+ term::in, prog_context::in, int::in, maybe1(item)::out) is det.
+
+parse_pragma_direct_arg(ModuleName, PragmaTerms, VarSet, ErrorTerm, Context,
+ SeqNum, MaybeItem) :-
+ ( PragmaTerms = [TypeTerm, FunctorsTerm] ->
+ ( parse_name_and_arity(TypeTerm, Name, Arity) ->
+ (
+ list_term_to_term_list(FunctorsTerm, FunctorsTerms),
+ map_parser(parse_direct_arg_functor(ModuleName, VarSet),
+ FunctorsTerms, MaybeFunctorsList),
+ MaybeFunctorsList = ok1(Functors)
+ ->
+ Pragma = pragma_direct_arg(Name, Arity, Functors),
+ ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
+ Item = item_pragma(ItemPragma),
+ MaybeItem = ok1(Item)
+ ;
+ Pieces = [words("Error: malformed functors in"),
+ quote(":- pragma direct_arg"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FunctorsTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: expected name/arity for type in"),
+ quote(":- pragma direct_arg"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(TypeTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ ;
+ Pieces = [words("Syntax error in"),
+ quote(":- pragma direct_arg"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ).
+
+:- pred parse_direct_arg_functor(module_name::in, varset::in, term::in,
+ maybe1(sym_name_and_arity)::out) is det.
+
+parse_direct_arg_functor(ModuleName, VarSet, Term, MaybeFunctor) :-
+ parse_simple_name_and_arity(ModuleName, "direct_arg", "functor",
+ Term, Term, VarSet, MaybeNameAndArity),
+ (
+ MaybeNameAndArity = ok2(Name, Arity),
+ MaybeFunctor = ok1(Name / Arity)
+ ;
+ MaybeNameAndArity = error2(Specs),
+ MaybeFunctor = error1(Specs)
+ ).
+
%----------------------------------------------------------------------------%
:- pred parse_foreign_decl_is_local(term::in, foreign_decl_is_local::out)
diff --git a/compiler/prog_item.m b/compiler/prog_item.m
index c1a3211..212d9c5 100644
--- a/compiler/prog_item.m
+++ b/compiler/prog_item.m
@@ -617,12 +617,20 @@
% Predname, Arity, Fact file name.
)
+ % Type representation pragmas.
+
; pragma_reserve_tag(
restag_type :: sym_name,
restag_arity :: arity
% Typename, Arity
)
+ ; pragma_direct_arg(
+ darg_type :: sym_name,
+ darg_arity :: arity,
+ darg_ctors :: list(sym_name_and_arity)
+ )
+
% Purity pragmas.
; pragma_promise_equivalent_clauses(
diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m
index c1aa1e4..393bb22 100644
--- a/compiler/recompilation.version.m
+++ b/compiler/recompilation.version.m
@@ -612,6 +612,7 @@ is_pred_pragma(PragmaType, MaybePredOrFuncId) :-
; PragmaType = pragma_foreign_enum(_, _, _, _)
; PragmaType = pragma_source_file(_)
; PragmaType = pragma_reserve_tag(_, _)
+ ; PragmaType = pragma_direct_arg(_, _, _)
; PragmaType = pragma_require_feature_set(_)
),
MaybePredOrFuncId = no
diff --git a/compiler/rtti.m b/compiler/rtti.m
index 265c791..054b8e3 100644
--- a/compiler/rtti.m
+++ b/compiler/rtti.m
@@ -380,7 +380,7 @@
% value in a given type.
%
:- type sectag_locn
- ---> sectag_none
+ ---> sectag_none(maybe_direct_arg_functor)
; sectag_local
; sectag_remote.
@@ -388,7 +388,7 @@
% given functor in a given type.
%
:- type sectag_and_locn
- ---> sectag_locn_none
+ ---> sectag_locn_none(maybe_direct_arg_functor)
; sectag_locn_local(int)
; sectag_locn_remote(int).
@@ -1512,13 +1512,35 @@ type_info_list_to_string(TypeInfoList) =
pred_or_func_to_string(pf_predicate, "MR_PREDICATE").
pred_or_func_to_string(pf_function, "MR_FUNCTION").
-sectag_locn_to_string(sectag_none, "MR_SECTAG_NONE").
-sectag_locn_to_string(sectag_local, "MR_SECTAG_LOCAL").
-sectag_locn_to_string(sectag_remote, "MR_SECTAG_REMOTE").
+sectag_locn_to_string(SecTag, String) :-
+ (
+ SecTag = sectag_none(is_not_direct_arg_functor),
+ String = "MR_SECTAG_NONE"
+ ;
+ SecTag = sectag_none(is_direct_arg_functor),
+ String = "MR_SECTAG_NONE_DIRECT_ARG"
+ ;
+ SecTag = sectag_local,
+ String = "MR_SECTAG_LOCAL"
+ ;
+ SecTag = sectag_remote,
+ String = "MR_SECTAG_REMOTE"
+ ).
-sectag_and_locn_to_locn_string(sectag_locn_none, "MR_SECTAG_NONE").
-sectag_and_locn_to_locn_string(sectag_locn_local(_), "MR_SECTAG_LOCAL").
-sectag_and_locn_to_locn_string(sectag_locn_remote(_), "MR_SECTAG_REMOTE").
+sectag_and_locn_to_locn_string(SecTag, String) :-
+ (
+ SecTag = sectag_locn_none(is_not_direct_arg_functor),
+ String = "MR_SECTAG_NONE"
+ ;
+ SecTag = sectag_locn_none(is_direct_arg_functor),
+ String = "MR_SECTAG_NONE_DIRECT_ARG"
+ ;
+ SecTag = sectag_locn_local(_),
+ String = "MR_SECTAG_LOCAL"
+ ;
+ SecTag = sectag_locn_remote(_),
+ String = "MR_SECTAG_REMOTE"
+ ).
type_ctor_rep_to_string(TypeCtorData, RepStr) :-
TypeCtorDetails = TypeCtorData ^ tcr_rep_details,
diff --git a/compiler/rtti_out.m b/compiler/rtti_out.m
index c4f11c5..252f0a1 100644
--- a/compiler/rtti_out.m
+++ b/compiler/rtti_out.m
@@ -914,10 +914,14 @@ output_du_functor_defn(Info, RttiTypeCtor, DuFunctor, !DeclSet, !IO) :-
unexpected(this_file, "output_du_functor_defn: du_hl_rep")
),
(
- SectagAndLocn = sectag_locn_none,
+ SectagAndLocn = sectag_locn_none(is_not_direct_arg_functor),
Locn = "MR_SECTAG_NONE",
Stag = -1
;
+ SectagAndLocn = sectag_locn_none(is_direct_arg_functor),
+ Locn = "MR_SECTAG_NONE_DIRECT_ARG",
+ Stag = -1
+ ;
SectagAndLocn = sectag_locn_local(Stag),
Locn = "MR_SECTAG_LOCAL"
;
diff --git a/compiler/rtti_to_mlds.m b/compiler/rtti_to_mlds.m
index 600cba8..52365ec 100644
--- a/compiler/rtti_to_mlds.m
+++ b/compiler/rtti_to_mlds.m
@@ -761,8 +761,8 @@ gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData) :-
unexpected(this_file, "output_du_functor_defn: du_hl_rep")
),
(
- SectagAndLocn = sectag_locn_none,
- Locn = sectag_none,
+ SectagAndLocn = sectag_locn_none(DirectArg),
+ Locn = sectag_none(DirectArg),
Stag = -1
;
SectagAndLocn = sectag_locn_local(Stag),
diff --git a/compiler/switch_gen.m b/compiler/switch_gen.m
index e3bf7b8..152be80 100644
--- a/compiler/switch_gen.m
+++ b/compiler/switch_gen.m
@@ -434,7 +434,7 @@ is_reserved_addr_tag(TaggedConsId) = IsReservedAddr :-
; ConsTag = table_io_decl_tag(_, _)
; ConsTag = tabling_info_tag(_, _)
; ConsTag = type_ctor_info_tag(_, _, _)
- ; ConsTag = unshared_tag(_)
+ ; ConsTag = unshared_tag(_, _)
),
IsReservedAddr = no
).
diff --git a/compiler/switch_util.m b/compiler/switch_util.m
index 1f14313..4d5c328 100644
--- a/compiler/switch_util.m
+++ b/compiler/switch_util.m
@@ -524,7 +524,7 @@ estimate_switch_tag_test_cost(Tag) = Cost :-
% of the scan over them.
Cost = 2
;
- Tag = unshared_tag(_),
+ Tag = unshared_tag(_, _),
% You need to compute the primary tag and compare it.
Cost = 2
;
@@ -1078,14 +1078,22 @@ get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap) :-
get_ptag_counts_2([], !MaxPrimary, !PtagCountMap).
get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :-
(
- ( Tag = single_functor_tag, Primary = 0
- ; Tag = unshared_tag(Primary)
+ (
+ Tag = single_functor_tag,
+ Primary = 0,
+ SecTag = sectag_none(is_not_direct_arg_functor)
+ ;
+ Tag = unshared_tag(Primary, is_not_direct_arg_functor),
+ SecTag = sectag_none(is_not_direct_arg_functor)
+ ;
+ Tag = unshared_tag(Primary, is_direct_arg_functor),
+ SecTag = sectag_none(is_direct_arg_functor)
),
int.max(Primary, !MaxPrimary),
( map.search(!.PtagCountMap, Primary, _) ->
unexpected(this_file, "unshared tag is shared")
;
- map.det_insert(Primary, sectag_none - (-1), !PtagCountMap)
+ map.det_insert(Primary, SecTag - (-1), !PtagCountMap)
)
;
Tag = shared_remote_tag(Primary, Secondary),
@@ -1096,7 +1104,7 @@ get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :-
TagType = sectag_remote
;
( TagType = sectag_local
- ; TagType = sectag_none
+ ; TagType = sectag_none(_)
),
unexpected(this_file, "remote tag is shared with non-remote")
),
@@ -1114,7 +1122,7 @@ get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :-
TagType = sectag_local
;
( TagType = sectag_remote
- ; TagType = sectag_none
+ ; TagType = sectag_none(_)
),
unexpected(this_file, "local tag is shared with non-local")
),
@@ -1178,14 +1186,22 @@ group_case_by_ptag(CaseNum, CaseRep, TaggedConsId,
!CaseNumPtagsMap, !PtagCaseMap) :-
TaggedConsId = tagged_cons_id(_ConsId, Tag),
(
- ( Tag = single_functor_tag, Primary = 0
- ; Tag = unshared_tag(Primary)
+ (
+ Tag = single_functor_tag,
+ Primary = 0,
+ SecTag = sectag_none(is_not_direct_arg_functor)
+ ;
+ Tag = unshared_tag(Primary, is_not_direct_arg_functor),
+ SecTag = sectag_none(is_not_direct_arg_functor)
+ ;
+ Tag = unshared_tag(Primary, is_direct_arg_functor),
+ SecTag = sectag_none(is_direct_arg_functor)
),
( map.search(!.PtagCaseMap, Primary, _Group) ->
unexpected(this_file, "unshared tag is shared")
;
StagGoalMap = map.singleton(-1, CaseRep),
- map.det_insert(Primary, ptag_case(sectag_none, StagGoalMap),
+ map.det_insert(Primary, ptag_case(SecTag, StagGoalMap),
!PtagCaseMap)
)
;
@@ -1288,7 +1304,7 @@ build_ptag_case_rev_map([Entry | Entries], PtagCountMap, !RevMap) :-
Entry = Ptag - Case,
map.lookup(PtagCountMap, Ptag, CountSecTagLocn - Count),
(
- CountSecTagLocn = sectag_none,
+ CountSecTagLocn = sectag_none(_),
( map.search(!.RevMap, Case, OldEntry) ->
OldEntry = ptag_case_rev_map_entry(OldCount,
OldFirstPtag, OldLaterPtags0, OldCase),
diff --git a/compiler/tag_switch.m b/compiler/tag_switch.m
index b12b81b..22f331c 100644
--- a/compiler/tag_switch.m
+++ b/compiler/tag_switch.m
@@ -668,7 +668,7 @@ generate_primary_tag_code(StagGoalMap, MainPtag, OtherPtags, MaxSecondary,
StagReg, StagLoc, Rval, MaybeFailLabel, Code, !CaseLabelMap, !CI) :-
map.to_assoc_list(StagGoalMap, StagGoalList),
(
- StagLoc = sectag_none,
+ StagLoc = sectag_none(_),
% There is no secondary tag, so there is no switch on it.
(
StagGoalList = [],
diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m
index 32c7aaa..3f8d7b1 100644
--- a/compiler/type_ctor_info.m
+++ b/compiler/type_ctor_info.m
@@ -713,7 +713,7 @@ make_foreign_enum_functors(TypeCtor, Lang, [Functor | Functors], NextOrdinal,
; ConsTag = deep_profiling_proc_layout_tag(_, _)
; ConsTag = table_io_decl_tag(_, _)
; ConsTag = single_functor_tag
- ; ConsTag = unshared_tag(_)
+ ; ConsTag = unshared_tag(_, _)
; ConsTag = shared_remote_tag(_, _)
; ConsTag = shared_local_tag(_, _)
; ConsTag = no_tag
@@ -821,7 +821,7 @@ make_maybe_res_functors(TypeCtor, [Functor | Functors], NextOrdinal,
FunctorName = unqualify_name(SymName),
ConsId = cons(SymName, list.length(ConstructorArgs), TypeCtor),
map.lookup(ConsTagMap, ConsId, ConsTag),
- process_cons_tag(ConsTag, ConsRep),
+ get_maybe_reserved_rep(ConsTag, ConsRep),
list.map(generate_du_arg_info(TypeArity, ExistTvars),
ConstructorArgs, ArgInfos),
(
@@ -852,16 +852,18 @@ make_maybe_res_functors(TypeCtor, [Functor | Functors], NextOrdinal,
make_maybe_res_functors(TypeCtor, Functors, NextOrdinal + 1, ConsTagMap,
TypeArity, ModuleInfo, MaybeResFunctors).
-:- pred process_cons_tag(cons_tag::in, maybe_reserved_rep::out) is det.
+:- pred get_maybe_reserved_rep(cons_tag::in, maybe_reserved_rep::out) is det.
-process_cons_tag(ConsTag, ConsRep) :-
+get_maybe_reserved_rep(ConsTag, ConsRep) :-
(
ConsTag = single_functor_tag,
ConsPtag = 0,
- ConsRep = du_rep(du_ll_rep(ConsPtag, sectag_locn_none))
+ SecTagLocn = sectag_locn_none(is_not_direct_arg_functor),
+ ConsRep = du_rep(du_ll_rep(ConsPtag, SecTagLocn))
;
- ConsTag = unshared_tag(ConsPtag),
- ConsRep = du_rep(du_ll_rep(ConsPtag, sectag_locn_none))
+ ConsTag = unshared_tag(ConsPtag, DirectArg),
+ SecTagLocn = sectag_locn_none(DirectArg),
+ ConsRep = du_rep(du_ll_rep(ConsPtag, SecTagLocn))
;
ConsTag = shared_local_tag(ConsPtag, ConsStag),
ConsRep = du_rep(du_ll_rep(ConsPtag, sectag_locn_local(ConsStag)))
@@ -875,7 +877,7 @@ process_cons_tag(ConsTag, ConsRep) :-
ConsTag = shared_with_reserved_addresses_tag(_RAs, ThisTag),
% Here we can just ignore the fact that this cons_tag is
% shared with reserved addresses.
- process_cons_tag(ThisTag, ConsRep)
+ get_maybe_reserved_rep(ThisTag, ConsRep)
;
( ConsTag = no_tag
; ConsTag = string_tag(_)
@@ -999,8 +1001,8 @@ make_du_ptag_ordered_table(DuFunctor, !PtagTable) :-
(
DuRep = du_ll_rep(Ptag, SectagAndLocn),
(
- SectagAndLocn = sectag_locn_none,
- SectagLocn = sectag_none,
+ SectagAndLocn = sectag_locn_none(DirectArg),
+ SectagLocn = sectag_none(DirectArg),
Sectag = 0
;
SectagAndLocn = sectag_locn_local(Sectag),
diff --git a/compiler/type_util.m b/compiler/type_util.m
index 684aa82..f298a2d 100644
--- a/compiler/type_util.m
+++ b/compiler/type_util.m
@@ -21,6 +21,7 @@
:- import_module hlds.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
@@ -146,6 +147,27 @@
%
:- func check_dummy_type(module_info, mer_type) = is_dummy_type.
+ % can_be_direct_arg_functor(ModuleInfo, TypeCtor, ImportStatus, Ctor,
+ % MaybePragmaStatus):
+ %
+ % A function symbol with exactly one argument may (but does not need to be)
+ % be represented as a tagged pointer to its sole argument, if the argument
+ % type is known not to require the tag bits for itself.
+ %
+ % A complication arises if a module could import a function symbol without
+ % importing the argument type: while compiling that module we could not
+ % infer that the optimisation applies. When a function symbol is visible
+ % outside the defining module, we restrict the optimisation to only apply
+ % if the argument type is also defined in the interface section of the same
+ % module.
+ %
+ % `:- pragma direct_arg' directives may be added by the user to assert that
+ % the optimised representation applies. These are checked when compiling
+ % the module which contains the pragma, but trusted by importing modules.
+ %
+:- pred can_be_direct_arg_functor(module_info::in, type_ctor::in,
+ constructor::in, maybe(import_status)::in) is semidet.
+
% A test for types that are defined in Mercury, but whose definitions
% are `lies', i.e. they are not sufficiently accurate for RTTI
% structures describing the types. Since the RTTI will be hand defined,
@@ -348,6 +370,7 @@
:- import_module backend_libs.
:- import_module backend_libs.foreign.
+:- import_module hlds.hlds_pred.
:- import_module libs.
:- import_module libs.globals.
:- import_module libs.options.
@@ -360,6 +383,7 @@
:- import_module char.
:- import_module int.
:- import_module map.
+:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module term.
@@ -678,6 +702,106 @@ check_dummy_type_2(ModuleInfo, Type, CoveredTypes) = IsDummy :-
IsDummy = is_not_dummy_type
).
+%-----------------------------------------------------------------------------%
+
+can_be_direct_arg_functor(ModuleInfo, TypeCtor, Ctor, MaybePragmaStatus) :-
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
+ get_type_defn_status(TypeDefn, TypeStatus),
+
+ % The functor must have exactly one argument, whose type representation is
+ % known to not require the tag bits of the top level type.
+ Ctor = ctor(ExistTVars, _Constraints, _SymName, [Arg], _),
+ ExistTVars = [],
+ Arg = ctor_arg(_FieldName, ArgType, _),
+ type_to_ctor(ArgType, ArgTypeCtor),
+ ( search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn) ->
+ get_type_defn_body(ArgTypeDefn, ArgTypeBody),
+ get_type_defn_status(ArgTypeDefn, ArgTypeStatus),
+ (
+ % The argument type must be represented by a single_functor_tag.
+ ArgTypeBody = hlds_du_type(_, ArgConsTagValues, _, _, _,
+ ArgReservedTag, ArgReservedAddr, _),
+ map.to_assoc_list(ArgConsTagValues, [_ - ArgConsTag]),
+ ArgConsTag = single_functor_tag,
+ ArgReservedTag = does_not_use_reserved_tag,
+ ArgReservedAddr = does_not_use_reserved_address
+ ;
+ % Trust an imported `:- pragma direct_arg' if the argument type is
+ % abstract imported.
+ ArgTypeStatus = status_abstract_imported,
+ MaybePragmaStatus = yes(PragmaStatus),
+ status_is_imported(PragmaStatus) = yes
+ ),
+ ArgTypeSafeBuiltin = no
+ ;
+ % We also know some builtin types are represented by aligned pointers.
+ % XXX string literals are currently not necessarily aligned
+ ArgTypeCtor = type_ctor(unqualified("{}"), _TupleArity),
+ ArgTypeStatus = status_imported(import_locn_interface),
+ ArgTypeSafeBuiltin = yes
+ ),
+
+ (
+ % If the top level type definition is not exported (even to
+ % sub-modules) then the optimisation is safe. Problems may arise if
+ % local types are opt-exported, but we handle that by adding
+ % appropriate `:- pragma direct_arg' directives for any local types
+ % written out to .opt files.
+ ( TypeStatus = status_local
+ ; TypeStatus = status_abstract_exported
+ ; TypeStatus = status_opt_exported
+ )
+ ;
+ % If the top level type is exported from this module, then the
+ % optimisation is safe only if all importing modules will infer the
+ % same optimisation. That will be true if:
+ TypeStatus = status_exported,
+ (
+ % the argument type is exported from the same interface; or
+ ArgTypeStatus = status_exported
+ ;
+ % there is an explicit `pragma direct_arg' in the interface
+ % section; or
+ MaybePragmaStatus = yes(status_exported)
+ ;
+ % the argument type is an acceptable builtin type.
+ ArgTypeSafeBuiltin = yes
+ )
+ ;
+ % Similarly, if the top level type is exported to sub-modules only.
+ % In that case, the argument type must be at least as visible.
+ TypeStatus = status_exported_to_submodules,
+ ( ArgTypeStatus = status_exported
+ ; ArgTypeStatus = status_exported_to_submodules
+ ; MaybePragmaStatus = yes(status_exported)
+ ; MaybePragmaStatus = yes(status_exported_to_submodules)
+ ; ArgTypeSafeBuiltin = yes
+ )
+ ;
+ % The optimisation is REQUIRED if the top level type is imported and:
+ TypeStatus = status_imported(_),
+ (
+ % if the argument type is imported from the same module; or
+ ArgTypeStatus = status_imported(_),
+ type_ctor_module(ModuleInfo, TypeCtor) = SameModule,
+ type_ctor_module(ModuleInfo, ArgTypeCtor) = SameModule
+ ;
+ % an imported `pragma direct_arg' says so; or
+ MaybePragmaStatus = yes(status_imported(_))
+ ;
+ % if the argument type is an acceptable builtin type.
+ ArgTypeSafeBuiltin = yes
+ )
+ ;
+ % For opt-imported types, a pragma will be present if the optimisation
+ % is required.
+ TypeStatus = status_opt_imported,
+ MaybePragmaStatus = yes(status_opt_imported)
+ ).
+
+%-----------------------------------------------------------------------------%
+
type_ctor_has_hand_defined_rtti(Type, Body) :-
Type = type_ctor(qualified(mercury_private_builtin_module, Name), 0),
( Name = "type_info"
diff --git a/compiler/unify_gen.m b/compiler/unify_gen.m
index 2aa7a95..32d012c 100644
--- a/compiler/unify_gen.m
+++ b/compiler/unify_gen.m
@@ -392,7 +392,7 @@ raw_tag_test(Rval, ConsTag, TestRval) :-
ConsTag = single_functor_tag,
TestRval = const(llconst_true)
;
- ConsTag = unshared_tag(UnsharedTag),
+ ConsTag = unshared_tag(UnsharedTag, _DirectArg),
VarPtag = unop(tag, Rval),
ConstPtag = unop(mktag, const(llconst_int(UnsharedTag))),
TestRval = binop(eq, VarPtag, ConstPtag)
@@ -506,7 +506,7 @@ generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct,
% Treat single_functor the same as unshared_tag(0).
Ptag = 0
;
- ConsTag = unshared_tag(Ptag)
+ ConsTag = unshared_tag(Ptag, is_not_direct_arg_functor)
),
var_types(!.CI, Args, ArgTypes),
generate_cons_args(Args, ArgTypes, Modes, 0, 1, TakeAddr, !.CI,
@@ -514,6 +514,17 @@ generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct,
construct_cell(Var, Ptag, MaybeRvals, HowToConstruct,
MaybeSize, FieldAddrs, MayUseAtomic, Code, !CI)
;
+ ConsTag = unshared_tag(Ptag, is_direct_arg_functor),
+ (
+ Args = [Arg],
+ TakeAddr = []
+ ->
+ assign_expr_to_var(Var, mkword(Ptag, var(Arg)), Code, !CI)
+ ;
+ unexpected($module, $pred,
+ "is_direct_arg_functor: arity != 1 or take_addr")
+ )
+ ;
ConsTag = shared_remote_tag(Ptag, Sectag),
var_types(!.CI, Args, ArgTypes),
generate_cons_args(Args, ArgTypes, Modes, 1, 1, TakeAddr, !.CI,
@@ -1093,15 +1104,35 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
;
Tag = single_functor_tag,
% Treat single_functor the same as unshared_tag(0).
- generate_det_deconstruction_2(Var, Cons, Args, Modes, unshared_tag(0),
- Code, !CI)
+ generate_det_deconstruction_2(Var, Cons, Args, Modes,
+ unshared_tag(0, is_not_direct_arg_functor), Code, !CI)
;
- Tag = unshared_tag(Ptag),
+ Tag = unshared_tag(Ptag, is_not_direct_arg_functor),
Rval = var(Var),
make_fields_and_argvars(Args, Rval, 0, Ptag, Fields, ArgVars),
var_types(!.CI, Args, ArgTypes),
generate_unify_args(Fields, ArgVars, Modes, ArgTypes, Code, !CI)
;
+ Tag = unshared_tag(Ptag, is_direct_arg_functor),
+ (
+ Args = [Arg],
+ Modes = [Mode]
+ ->
+ produce_variable(Var, VarCode, VarRval, !CI),
+ acquire_reg(reg_r, Reg, !CI),
+ ConstPtag = unop(mktag, const(llconst_int(Ptag))),
+ Rval = binop(body, VarRval, ConstPtag),
+ StripCode = singleton(llds_instr(assign(Reg, Rval), "strip tag")),
+ ArgType = variable_type(!.CI, Arg),
+ generate_sub_unify(lval(Reg), ref(Arg), Mode, ArgType, AssignCode,
+ !CI),
+ release_reg(Reg, !CI),
+ Code = VarCode ++ StripCode ++ AssignCode
+ ;
+ unexpected($module, $pred,
+ "is_direct_arg_functor: arity != 1")
+ )
+ ;
Tag = shared_remote_tag(Ptag, _Sectag1),
Rval = var(Var),
make_fields_and_argvars(Args, Rval, 1, Ptag, Fields, ArgVars),
@@ -1393,7 +1424,7 @@ generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
ConsTag = single_functor_tag,
Ptag = 0
;
- ConsTag = unshared_tag(Ptag)
+ ConsTag = unshared_tag(Ptag, is_not_direct_arg_functor)
),
generate_ground_term_args(Args, ArgRvalsTypes, !ActiveMap),
add_scalar_static_cell(ArgRvalsTypes, DataAddr, !StaticCellInfo),
@@ -1403,6 +1434,20 @@ generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
ActiveGroundTerm = Rval - lt_data_ptr,
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
+ ConsTag = unshared_tag(Ptag, is_direct_arg_functor),
+ (
+ Args = [Arg],
+ map.det_remove(Arg, ArgRval - _RvalType, !ActiveMap),
+ Rval = mkword(Ptag, ArgRval),
+ ActiveGroundTerm = Rval - lt_data_ptr,
+ map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
+ ;
+ ( Args = []
+ ; Args = [_, _ | _]
+ ),
+ unexpected($module, $pred, "is_direct_arg_functor arity != 1")
+ )
+ ;
ConsTag = shared_remote_tag(Ptag, Stag),
generate_ground_term_args(Args, ArgRvalsTypes, !ActiveMap),
StagRvalType = const(llconst_int(Stag)) - lt_integer,
diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi
index 1da72e2..7e0bccf 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -9504,6 +9504,11 @@ extensions to the Mercury language:
@c implementation-specific...
@c * Reserved tag:: Support for Herbrand constraint solvers.
+ at c XXX The `direct arg' pragma is not documented because it requires the user
+ at c has a detailed understanding of the type representation, and is very
+ at c implementation specific.
+ at c * Direct argument:: A type representation optimisation.
+
@node Fact tables
@section Fact tables
@@ -10042,6 +10047,38 @@ function then the compiler will quit with an error message.
@c compiler option will have any useful effect if the @samp{--high-level-data}
@c option is used (e.g. for the .NET or Java back-ends).
+ at c XXX The `direct arg' pragma is not documented because it requires the user
+ at c has a detailed understanding of the type representation, and is very
+ at c implementation specific.
+ at c @node Direct argument
+ at c @section Direct argument
+ at c
+ at c The @samp{direct_arg} pragma declaration has the following form:
+ at c
+ at c @example
+ at c :- pragma direct_arg(@var{type-name} / @var{type-arity}, @var{ctors}).
+ at c @end example
+ at c
+ at c @noindent
+ at c where @var{ctors} is a list of @var{functor-name} / @var{functor-arity}.
+ at c The type must be defined in the module containing the pragma, and the
+ at c functor arities must always be one.
+ at c
+ at c The pragma will become part of the module's interface, notifying importing
+ at c modules that each of the functors listed is to be represented as a tagged
+ at c pointer to its argument. The argument type must be known, when compiling the
+ at c module containing the @samp{:- pragma direct_arg}, to not require the use of
+ at c the tag bits. The compiler will emit an error message otherwise.
+ at c The compiler will silently ignore functors which require a secondary tag.
+ at c
+ at c The optimised type representation is usually only applied if the argument type
+ at c is defined in the interface section of the same module. This pragma allows the
+ at c programmer to also apply it when the argument type is known to the defining
+ at c module, but not necessarily modules which import the top-level type.
+ at c
+ at c Ideally, @samp{:- pragma direct_arg} would be automatically generated.
+ at c It is required because the compiler does not have enough information when
+ at c making the interface file for a module.
@c XXX TO DO!
@c @node Compile-time garbage collection
diff --git a/library/construct.m b/library/construct.m
index 672252a..dba0dc4 100644
--- a/library/construct.m
+++ b/library/construct.m
@@ -732,6 +732,16 @@ find_functor_2(TypeInfo, Functor, Arity, Num0, FunctorNumber, ArgTypes) :-
MR_define_size_slot(ptag, new_data, size);
break;
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ arity = functor_desc->MR_du_functor_orig_arity;
+ assert(arity == 1);
+ arg_data = MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_DATA);
+ new_data = (MR_Word) MR_tmkword(ptag, arg_data);
+ arg_list = MR_list_tail(arg_list);
+ break;
+
case MR_SECTAG_VARIABLE:
new_data = (MR_Word) 0; /* avoid a warning */
MR_fatal_error(""construct(): cannot construct variable"");
diff --git a/runtime/mercury_deconstruct.c b/runtime/mercury_deconstruct.c
index f62a54e..2d242f8 100644
--- a/runtime/mercury_deconstruct.c
+++ b/runtime/mercury_deconstruct.c
@@ -202,6 +202,7 @@ MR_named_arg_num(MR_TypeInfo type_info, MR_Word *term_ptr,
switch (ptag_layout->MR_sectag_locn) {
case MR_SECTAG_NONE:
+ case MR_SECTAG_NONE_DIRECT_ARG:
functor_desc = ptag_layout->MR_sectag_alternatives[0];
break;
case MR_SECTAG_LOCAL:
diff --git a/runtime/mercury_deep_copy_body.h b/runtime/mercury_deep_copy_body.h
index 90cd43e..669084d 100644
--- a/runtime/mercury_deep_copy_body.h
+++ b/runtime/mercury_deep_copy_body.h
@@ -178,6 +178,7 @@ try_again:
/* case MR_SECTAG_REMOTE: */
/* case MR_SECTAG_NONE: */
+ /* case MR_SECTAG_NONE_DIRECT_ARG: */
/*
** The code we want to execute for the MR_SECTAG_REMOTE
** and MR_SECTAG_NONE cases is very similar. However,
@@ -315,6 +316,29 @@ try_again:
MR_handle_sectag_remote_or_none(MR_FALSE);
return new_data;
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ {
+ const MR_DuFunctorDesc *functor_desc;
+ const MR_DuExistInfo *exist_info;
+ int arity;
+ MR_Word arg;
+
+ functor_desc = ptag_layout->MR_sectag_alternatives[0];
+ arity = functor_desc->MR_du_functor_orig_arity;
+ exist_info = functor_desc->MR_du_functor_exist_info;
+ assert(arity == 1);
+ assert(exist_info == NULL);
+
+ arg = MR_body(data, ptag);
+ RETURN_IF_OUT_OF_RANGE(data, (MR_Word *) arg, 0, MR_Word);
+ new_data = copy(arg,
+ MR_pseudo_type_info_is_ground(
+ functor_desc->MR_du_functor_arg_types[0]),
+ lower_limit, upper_limit);
+ new_data = (MR_Word) MR_mkword(ptag, new_data);
+ return new_data;
+ }
+
case MR_SECTAG_VARIABLE:
MR_fatal_error("copy(): attempt to copy variable");
diff --git a/runtime/mercury_grade.h b/runtime/mercury_grade.h
index 0934855..96b6586 100644
--- a/runtime/mercury_grade.h
+++ b/runtime/mercury_grade.h
@@ -64,7 +64,7 @@
** low-level C parallel grades respectively.
*/
-#define MR_GRADE_PART_0 v16_
+#define MR_GRADE_PART_0 v17_
#define MR_GRADE_EXEC_TRACE_VERSION_NO 9
#define MR_GRADE_DEEP_PROF_VERSION_NO 3
#define MR_GRADE_LLC_PAR_VERSION_NO 1
diff --git a/runtime/mercury_ml_expand_body.h b/runtime/mercury_ml_expand_body.h
index 6dc7d5b..2918cf1 100644
--- a/runtime/mercury_ml_expand_body.h
+++ b/runtime/mercury_ml_expand_body.h
@@ -482,6 +482,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
int ptag;
MR_Word sectag;
MR_Word *arg_vector;
+ MR_Word single_arg;
data = *data_word_ptr;
ptag = MR_tag(data);
@@ -492,6 +493,11 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
functor_desc = ptag_layout->MR_sectag_alternatives[0];
arg_vector = (MR_Word *) MR_body(data, ptag);
break;
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ functor_desc = ptag_layout->MR_sectag_alternatives[0];
+ single_arg = MR_body(data, ptag);
+ arg_vector = &single_arg;
+ break;
case MR_SECTAG_LOCAL:
sectag = MR_unmkbody(data);
functor_desc =
diff --git a/runtime/mercury_table_type_body.h b/runtime/mercury_table_type_body.h
index d2a4c7b..6980cd3 100644
--- a/runtime/mercury_table_type_body.h
+++ b/runtime/mercury_table_type_body.h
@@ -136,6 +136,7 @@
int ptag;
MR_Word sectag;
MR_Word *arg_vector;
+ MR_Word single_arg;
int meta_args;
int i;
@@ -149,6 +150,12 @@
arg_vector = (MR_Word *) MR_body(data, ptag);
break;
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ functor_desc = ptag_layout->MR_sectag_alternatives[0];
+ single_arg = MR_body(data, ptag);
+ arg_vector = &single_arg;
+ break;
+
case MR_SECTAG_LOCAL:
sectag = MR_unmkbody(data);
functor_desc =
diff --git a/runtime/mercury_term_size.c b/runtime/mercury_term_size.c
index 2542f25..5db4c39 100644
--- a/runtime/mercury_term_size.c
+++ b/runtime/mercury_term_size.c
@@ -86,6 +86,9 @@ try_again:
#endif
return MR_field(MR_mktag(ptag), term, -1);
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ return MR_mask_field(term, -1);
+
case MR_SECTAG_LOCAL:
#ifdef MR_DEBUG_TERM_SIZES
if (MR_heapdebug && MR_lld_print_enabled) {
diff --git a/runtime/mercury_type_info.h b/runtime/mercury_type_info.h
index 279e4f1..357e68c 100644
--- a/runtime/mercury_type_info.h
+++ b/runtime/mercury_type_info.h
@@ -839,6 +839,8 @@ typedef struct {
**
** The primary and secondary fields give the corresponding tag values, and
** the sectag_locn field gives the location of the secondary tag.
+** MR_SECTAG_NONE_DIRECT_ARG is a sub-case of MR_SECTAG_NONE, where the
+** function symbol is represented as a tagged pointer to its only argument.
**
** The ordinal field gives the position of the function symbol in the
** list of function symbols of the type; one function symbol compares
@@ -872,6 +874,7 @@ typedef struct {
typedef enum {
MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_NONE),
+ MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_NONE_DIRECT_ARG),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_LOCAL),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_REMOTE),
MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_VARIABLE)
@@ -969,9 +972,9 @@ typedef const MR_ReservedAddrFunctorDesc *MR_ReservedAddrFunctorDescPtr;
**
** The intention is that if you have a word in a DU type that you want to
** interpret, you compute its primary tag and find its MR_DuPtagLayout.
-** You then look at the locn field. If it is MR_SECTAG_NONE, you index
-** the alternatives field with zero; if it is MR_SECTAG_{LOCAL,REMOTE}, you
-** compute the secondary tag and index the alternatives field with that.
+** You then look at the locn field. If it is MR_SECTAG_NONE{,_UNBOXED_ARG}, you
+** index the alternatives field with zero; if it is MR_SECTAG_{LOCAL,REMOTE},
+** you compute the secondary tag and index the alternatives field with that.
**
** A value of type MR_DuTypeLayout points to an array of MR_DuPtagLayout
** structures. The element at index k gives information about primary tag
diff --git a/runtime/mercury_unify_compare_body.h b/runtime/mercury_unify_compare_body.h
index 1d9f2a0..b13496b 100644
--- a/runtime/mercury_unify_compare_body.h
+++ b/runtime/mercury_unify_compare_body.h
@@ -228,6 +228,7 @@ start_label:
sectag = data_value[0]; \
break; \
case MR_SECTAG_NONE: \
+ case MR_SECTAG_NONE_DIRECT_ARG: \
sectag = 0; \
break; \
case MR_SECTAG_VARIABLE: \
@@ -300,6 +301,7 @@ start_label:
break;
case MR_SECTAG_NONE:
+ case MR_SECTAG_NONE_DIRECT_ARG:
x_sectag = 0;
break;
diff --git a/tests/hard_coded/Mercury.options b/tests/hard_coded/Mercury.options
index 08f34dc..176d36b 100644
--- a/tests/hard_coded/Mercury.options
+++ b/tests/hard_coded/Mercury.options
@@ -18,6 +18,9 @@ MCFLAGS-constraint_order = --constraint-propagation --enable-termination
MCFLAGS-deforest_cc_bug = --deforestation
MCFLAGS-delay_partial_test = --delay-partial-instantiations
MCFLAGS-delay_partial_test2 = --delay-partial-instantiations
+MCFLAGS-direct_arg_intermod1 = --intermodule-optimization
+MCFLAGS-direct_arg_intermod2 = --intermodule-optimization
+MCFLAGS-direct_arg_intermod3 = --intermodule-optimization
MCFLAGS-lp = --intermodule-optimization -O3
MCFLAGS-elim_local_var_char = --eliminate-local-vars
MCFLAGS-float_consistency = --optimize-constant-propagation
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 6e0e604..24ffda4 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -59,6 +59,8 @@ ORDINARY_PROGS= \
dense_lookup_switch3 \
dense_lookup_switch_non \
det_in_semidet_cntxt \
+ direct_arg_intermod1 \
+ direct_arg_parent \
disjs_in_switch \
division_test \
dos \
diff --git a/tests/hard_coded/construct_test.exp b/tests/hard_coded/construct_test.exp
index 15f0004..cc7d8ee 100644
--- a/tests/hard_coded/construct_test.exp
+++ b/tests/hard_coded/construct_test.exp
@@ -184,6 +184,11 @@ TESTING OTHER TYPES
0 - dummy/0 [] ordinal: 0 lex: 0
+2 functors in this type
+1 - unboxed_arg/1 [_] ordinal: 1 lex: 1
+0 - no/0 [] ordinal: 0 lex: 0
+
+
1 functors in this type
0 - xyzzy/1 [f21name] ordinal: 0 lex: 0
@@ -218,6 +223,8 @@ About to construct zop/2
Constructed: zop(2.1, 2.1)
About to construct qwerty/1
Constructed: qwerty(1)
+About to construct unboxed_arg/1
+Constructed: unboxed_arg(unboxed_struct(12, 34))
About to construct poly_one/1
Constructed: poly_one(1)
About to construct poly_two/1
diff --git a/tests/hard_coded/construct_test.m b/tests/hard_coded/construct_test.m
index efbc86c..03ba1a5 100644
--- a/tests/hard_coded/construct_test.m
+++ b/tests/hard_coded/construct_test.m
@@ -31,6 +31,10 @@
:- type dummy ---> dummy.
+:- type unboxed_arg ---> no ; unboxed_arg(unboxed_struct).
+
+:- type unboxed_struct ---> unboxed_struct(int, int).
+
:- type exist_type ---> some [T] xyzzy(f21name :: T).
%----------------------------------------------------------------------------%
@@ -84,6 +88,11 @@ test_construct -->
% No-tag type:
test_construct_2(type_desc__type_of(qwerty(7)), "qwerty", 1, [One]),
+ % Functor with single unboxed argument.
+ { type_to_univ(unboxed_struct(12, 34), UnboxedStruct) },
+ test_construct_2(type_desc__type_of(_ : unboxed_arg), "unboxed_arg",
+ 1, [UnboxedStruct]),
+
{ type_to_univ("goodbye", Bye) },
test_construct_2(type_desc__type_of(poly_four(3, "hello")),
@@ -316,6 +325,9 @@ test_other -->
% a dummy type
test_all(dummy), newline,
+ % a functor with a single unboxed argument
+ test_all(unboxed_arg(unboxed_struct(12, 34))), newline,
+
% an existential type:
{ ExistVal = 'new xyzzy'(8) },
test_all(ExistVal), newline.
diff --git a/tests/hard_coded/direct_arg_intermod1.exp b/tests/hard_coded/direct_arg_intermod1.exp
new file mode 100644
index 0000000..047486d
--- /dev/null
+++ b/tests/hard_coded/direct_arg_intermod1.exp
@@ -0,0 +1,4 @@
+yes(foo(1, 1))
+yes(foo(1, 1))
+yes(foo(1, 2))
+yes(foo(1, 2))
diff --git a/tests/hard_coded/direct_arg_intermod1.m b/tests/hard_coded/direct_arg_intermod1.m
new file mode 100644
index 0000000..c9c7e40
--- /dev/null
+++ b/tests/hard_coded/direct_arg_intermod1.m
@@ -0,0 +1,34 @@
+% A tricky situation for the direct argument type representation optimisation.
+
+:- module direct_arg_intermod1.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module direct_arg_intermod2.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ M1 = mk_maybe_inline(one, 1),
+ write_maybe_inline(M1, !IO),
+ write_maybe_no_inline(M1, !IO),
+
+ M2 = mk_maybe_no_inline(one, 2),
+ write_maybe_inline(M2, !IO),
+ write_maybe_no_inline(M2, !IO).
+
+:- func one = int.
+:- pragma no_inline(one/0).
+
+one = 1.
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/direct_arg_intermod2.m b/tests/hard_coded/direct_arg_intermod2.m
new file mode 100644
index 0000000..64ac458
--- /dev/null
+++ b/tests/hard_coded/direct_arg_intermod2.m
@@ -0,0 +1,62 @@
+%-----------------------------------------------------------------------------%
+
+:- module direct_arg_intermod2.
+:- interface.
+
+:- import_module io.
+
+:- type maybe.
+
+:- func mk_maybe_inline(int, int) = maybe.
+
+:- func mk_maybe_no_inline(int, int) = maybe.
+
+:- pred write_maybe_inline(maybe::in, io::di, io::uo) is det.
+
+:- pred write_maybe_no_inline(maybe::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module direct_arg_intermod3.
+
+:- type maybe == inner_maybe.
+
+ % inner_maybe is local... or is it?
+ %
+:- type inner_maybe
+ ---> no
+ ; yes(foo).
+
+%-----------------------------------------------------------------------------%
+
+:- pragma inline(mk_maybe_inline/2).
+
+mk_maybe_inline(A, B) = yes(foo(A, B)).
+
+:- pragma no_inline(mk_maybe_no_inline/2).
+
+mk_maybe_no_inline(A, B) = mk_maybe_inline(A, B).
+
+:- pragma inline(write_maybe_inline/3).
+
+write_maybe_inline(M, !IO) :-
+ (
+ M = no,
+ write_string("no\n", !IO)
+ ;
+ M = yes(Foo),
+ write_string("yes(", !IO),
+ write(Foo, !IO),
+ write_string(")\n", !IO)
+ ).
+
+:- pragma no_inline(write_maybe_no_inline/3).
+
+write_maybe_no_inline(M, !IO) :-
+ write_maybe_inline(M, !IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/direct_arg_intermod3.m b/tests/hard_coded/direct_arg_intermod3.m
new file mode 100644
index 0000000..7eefd01
--- /dev/null
+++ b/tests/hard_coded/direct_arg_intermod3.m
@@ -0,0 +1,9 @@
+%-----------------------------------------------------------------------------%
+
+:- module direct_arg_intermod3.
+:- interface.
+
+:- type foo ---> foo(int, int).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/direct_arg_parent.exp b/tests/hard_coded/direct_arg_parent.exp
new file mode 100644
index 0000000..54a1bc3
--- /dev/null
+++ b/tests/hard_coded/direct_arg_parent.exp
@@ -0,0 +1,2 @@
+not_possible(foo(1, 1))
+forced(foo(1, 2))
diff --git a/tests/hard_coded/direct_arg_parent.m b/tests/hard_coded/direct_arg_parent.m
new file mode 100644
index 0000000..41cf84e
--- /dev/null
+++ b/tests/hard_coded/direct_arg_parent.m
@@ -0,0 +1,40 @@
+% Test potential problems with direct argument type representation and
+% sub-modules.
+
+:- module direct_arg_parent.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- include_module direct_arg_parent.direct_arg_sub.
+:- import_module direct_arg_parent.direct_arg_sub.
+
+:- type maybe_foo
+ ---> no
+ ; not_possible(foo)
+ ; forced(foo).
+
+ :- pragma direct_arg(maybe_foo/0, [forced/1]).
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ M1 = not_possible(foo(one, 1)),
+ M2 = forced(foo(one, 2)),
+ direct_arg_sub.write_maybe_foo(M1, !IO),
+ direct_arg_sub.write_maybe_foo(M2, !IO).
+
+:- func one = int.
+:- pragma no_inline(one/0).
+
+one = 1.
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/direct_arg_sub.m b/tests/hard_coded/direct_arg_sub.m
new file mode 100644
index 0000000..a11e94a
--- /dev/null
+++ b/tests/hard_coded/direct_arg_sub.m
@@ -0,0 +1,37 @@
+%-----------------------------------------------------------------------------%
+
+:- module direct_arg_parent.direct_arg_sub.
+:- interface.
+
+:- import_module io.
+
+:- type foo
+ ---> foo(int, int).
+
+:- pred write_maybe_foo(maybe_foo::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- pragma no_inline(write_maybe_foo/3).
+
+write_maybe_foo(M, !IO) :-
+ (
+ M = no,
+ write_string("no\n", !IO)
+ ;
+ M = not_possible(Foo),
+ write_string("not_possible(", !IO),
+ write(Foo, !IO),
+ write_string(")\n", !IO)
+ ;
+ M = forced(Foo),
+ write_string("forced(", !IO),
+ write(Foo, !IO),
+ write_string(")\n", !IO)
+ ).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list