[m-rev.] for review: direct argument functor type representation
Peter Wang
novalazy at gmail.com
Thu May 26 12:41:01 AEST 2011
On 2011-05-20, Zoltan Somogyi <zs at csse.unimelb.edu.au> wrote:
> On 20-May-2011, Peter Wang <novalazy at gmail.com> wrote:
> > 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,
>
> I have another diff that does the same thing, WITHOUT requiring any pragmas.
> It is in /home/taura/workspaces/zs/ws7. I have not finished testing it yet.
> We should discuss this in person or on the phone, once we have looked at
> each other's work, say on monday.
This patch incorporates of those changes, in particular
preferring to assign primary tags to direct argument functors,
and more comprehensive sanity checking during code generation.
---
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.
Non-exported types may use the optimised representation, but when
intermodule optimisation is enabled, they may be written out to .opt files.
Then, we *do* add direct_arg pragmas to .opt files to ensure that importing
modules agree on the type representation. The pragmas may also be added by
Mercury programmers to source files, which will be copied directly into .int
files without analysis. They will be checked when the module is actually
compiled.
This patch includes work by Zoltan, who independently implemented a version
of this change.
compiler/hlds_data.m:
Add a new option to cons_tag.
Fix some comments.
compiler/hlds_module.m:
Add a slot to module_sub_info to record the
functors seen in `pragma direct_arg' items.
compiler/prog_io_pragma.m:
compiler/prog_item.m:
Parse `direct_arg' pragmas.
compiler/add_pragma.m:
compiler/make_hlds_passes.m:
Check and record `direct_arg' pragmas into the module_info.
compiler/make_tags.m:
compiler/mercury_compile_front_end.m:
Add a pass to convert suitable functors to use the direct argument
representation. The argument type must have been added to the type
table, so we do this after all type definitions have been added.
Move code to compute cheaper_tag_test here.
compiler/ml_unify_gen.m:
compiler/unify_gen.m:
Generate different code to construct/deconstruct direct argument
functors.
compiler/intermod.m:
Write `direct_arg' pragmas to .opt files for functors
using the direct argument representation.
compiler/mercury_to_mercury.m:
Write out `pragma direct_arg'.
compiler/module_qual.m:
Module qualify type names in `pragma direct_arg'.
compiler/rtti.m:
compiler/rtti_out.m:
compiler/rtti_to_mlds.m:
Add an option 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/add_type.m:
compiler/bytecode_gen.m:
compiler/equiv_type.m:
compiler/export.m:
compiler/ml_switch_gen.m:
compiler/ml_tag_switch.m:
compiler/ml_type_gen.m:
compiler/modules.m:
compiler/recompilation.version.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/tag_switch.m:
compiler/type_ctor_info.m:
Conform to changes.
Bump RTTI version number.
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.
library/private_builtin.m:
Add MR_SECTAG_NONE_DIRECT_ARG constant for Java for consistency,
though it won't be used.
runtime/mercury_grade.h:
Bump binary compatibility version number.
runtime/mercury_type_info.h:
Bump RTTI version number.
Add MR_SECTAG_NONE_DIRECT_ARG.
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_unify_compare_body.h:
Handle MR_SECTAG_NONE_DIRECT_ARG in RTTI code.
tests/debugger/Mmakefile:
tests/debugger/chooser_tag_test.exp:
tests/debugger/chooser_tag_test.inp:
tests/debugger/chooser_tag_test.m:
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:
tests/invalid/Mmakefile:
tests/invalid/pragma_direct_arg_bad.err_exp:
tests/invalid/pragma_direct_arg_bad.m:
Add test cases.
tests/invalid/ee_invalid.err_exp:
Update expected output.
diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m
index 111bb66..02fb297 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,
@@ -312,6 +317,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 +555,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 +579,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 +624,160 @@ 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, TypeTable),
+ ContextPieces = [
+ words("In"), quote("pragma direct_arg"), words("declaration for"),
+ sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
+ ],
+ ( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) ->
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
+ hlds_data.get_type_defn_status(TypeDefn, 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.")
+ ]
+ ;
+ (
+ TypeBody = hlds_du_type(Body, CtorTags, _CheaperTagTest,
+ _DuTypeKind, _MaybeUserEqComp, _ReservedTag, _ReservedAddr,
+ _IsForeign),
+ list.map_foldl(check_pragma_direct_arg_ctors(TypeTable,
+ TypeCtor, Body, CtorTags),
+ PragmaCtors, ErrorPieces0, set.init, PragmaConsIds),
+ list.condense(ErrorPieces0, ErrorPieces),
+ (
+ ErrorPieces = [],
+ MaybeSeverity = no,
+ module_info_get_pragma_direct_arg_functors(!.ModuleInfo,
+ DirectArgCtors0),
+ set.union(PragmaConsIds, DirectArgCtors0, DirectArgCtors),
+ module_info_set_pragma_direct_arg_functors(DirectArgCtors,
+ !ModuleInfo)
+ ;
+ ErrorPieces = [_ | _],
+ MaybeSeverity = yes(severity_error)
+ )
+ ;
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = 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 check_pragma_direct_arg_ctors(type_table::in, type_ctor::in,
+ list(constructor)::in, cons_tag_values::in, sym_name_and_arity::in,
+ format_components::out, set(cons_id)::in, set(cons_id)::out) is det.
+
+check_pragma_direct_arg_ctors(TypeTable, TypeCtor, ActualCtors, ConsTagValues,
+ PragmaCtor, ErrorPieces, !DirectArgCtors) :-
+ % NOTE: changes here may require corresponding changes in
+ % is_direct_arg_ctor.
+
+ PragmaCtor = SymName / Arity,
+ PragmaConsId = cons(SymName, Arity, TypeCtor),
+ (
+ map.search(ConsTagValues, PragmaConsId, ConsTag),
+ find_constructor(ActualCtors, SymName, Arity, MatchingCtor)
+ ->
+ (
+ % Don't warn if the constructor requires a secondary tag, as it
+ % may not on an architecture with more tag bits available.
+ ( ConsTag = unshared_tag(_)
+ ; ConsTag = shared_remote_tag(_, _)
+ ),
+ MatchingCtor = ctor(_, _, _, [CtorArg], _),
+ CtorArg = ctor_arg(_, ArgType, _),
+ type_to_ctor_and_args(ArgType, ArgTypeCtor, _),
+ (
+ type_ctor_is_tuple(ArgTypeCtor)
+ ;
+ search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn),
+ get_type_defn_body(ArgTypeDefn, ArgTypeBody),
+ ArgConsTagValues = ArgTypeBody ^ du_type_cons_tag_values,
+ map.to_assoc_list(ArgConsTagValues, [_ - ArgConsTag]),
+ ArgConsTag = single_functor_tag
+ )
+ ->
+ set.insert(PragmaConsId, !DirectArgCtors),
+ ErrorPieces = []
+ ;
+ ErrorPieces = [
+ sym_name_and_arity(SymName / Arity),
+ words("cannot be represented as a direct pointer to its"),
+ words("sole argument."), nl
+ ]
+ )
+ ;
+ ErrorPieces = [
+ sym_name_and_arity(SymName / Arity),
+ words("does not match any constructor."), nl
+ ]
+ ).
+
+:- 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),
@@ -709,7 +873,7 @@ add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
words("error: "),
sym_name_and_arity(TypeName / TypeArity),
words("is not an enumeration type."),
- words("It has one more non-zero arity"),
+ words("It has one or more non-zero arity"),
words("constructors.")
]
)
diff --git a/compiler/add_type.m b/compiler/add_type.m
index d866ab8..c3b78a0 100644
--- a/compiler/add_type.m
+++ b/compiler/add_type.m
@@ -616,28 +616,8 @@ convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp), TypeCtor, Globals,
assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, ReservedTagPragma,
Globals, CtorTagMap, ReservedAddr, IsEnum),
IsForeign = no,
- (
- ReservedAddr = does_not_use_reserved_address,
- map.to_assoc_list(CtorTagMap, CtorTagList),
- CtorTagList = [ConsIdA - ConsTagA, ConsIdB - ConsTagB],
- ConsIdA = cons(_, ArityA, _),
- ConsIdB = cons(_, ArityB, _)
- ->
- (
- ArityB = 0,
- ArityA > 0
- ->
- CheaperTagTest = cheaper_tag_test(ConsIdA, ConsTagA,
- ConsIdB, ConsTagB)
- ;
- ArityA = 0,
- ArityB > 0
- ->
- CheaperTagTest = cheaper_tag_test(ConsIdB, ConsTagB,
- ConsIdA, ConsTagA)
- ;
- CheaperTagTest = no_cheaper_tag_test
- )
+ ( ReservedAddr = does_not_use_reserved_address ->
+ compute_cheaper_tag_test(CtorTagMap, CheaperTagTest)
;
CheaperTagTest = no_cheaper_tag_test
),
diff --git a/compiler/bytecode_gen.m b/compiler/bytecode_gen.m
index 9bb49a5..d46a78e 100644
--- a/compiler/bytecode_gen.m
+++ b/compiler/bytecode_gen.m
@@ -779,6 +779,8 @@ map_cons_tag(no_tag, byte_no_tag).
% 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(direct_arg_tag(_), _) :-
+ sorry(this_file, "bytecode with direct_arg_tag").
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 fd49b7e..3e1e4f6 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..f65b452 100644
--- a/compiler/export.m
+++ b/compiler/export.m
@@ -906,6 +906,7 @@ foreign_const_name_and_tag(TypeCtor, Mapping, TagValues, Ctor,
; TagVal = table_io_decl_tag(_, _)
; TagVal = single_functor_tag
; TagVal = unshared_tag(_)
+ ; TagVal = direct_arg_tag(_)
; TagVal = shared_remote_tag(_, _)
; TagVal = shared_local_tag(_, _)
; TagVal = no_tag
diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m
index 6ce6e20..471a5bc 100644
--- a/compiler/hlds_data.m
+++ b/compiler/hlds_data.m
@@ -381,14 +381,22 @@
; unshared_tag(tag_bits)
% 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
+ % 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.
+ ; direct_arg_tag(tag_bits)
+ % This is for functors which can be distinguished with just a
+ % primary tag. The primary tag says which of the type's functors
+ % (which must all be arity-1) this word represents. However, the
+ % body of the word is not a pointer to a cell holding the argument;
+ % it IS the value of that argument, which must be an untagged
+ % pointer to a cell.
+
; shared_remote_tag(tag_bits, int)
% This is for functors or constants which require more than just
- % a two-bit tag. In this case, we use both a primary and a
+ % a primary tag. In this case, we use both a primary and a
% secondary tag. Several functors share the primary tag and are
% distinguished by the secondary tag. The secondary tag is stored
% as the first word of the argument vector. (If it is a constant,
@@ -505,6 +513,7 @@ get_primary_tag(Tag) = MaybePrimaryTag :-
MaybePrimaryTag = yes(0)
;
( Tag = unshared_tag(PrimaryTag)
+ ; Tag = direct_arg_tag(PrimaryTag)
; Tag = shared_remote_tag(PrimaryTag, _SecondaryTag)
; Tag = shared_local_tag(PrimaryTag, _SecondaryTag)
),
@@ -529,6 +538,7 @@ get_secondary_tag(Tag) = MaybeSecondaryTag :-
; Tag = no_tag
; Tag = reserved_address_tag(_)
; Tag = unshared_tag(_PrimaryTag)
+ ; Tag = direct_arg_tag(_PrimaryTag)
; Tag = single_functor_tag
),
MaybeSecondaryTag = no
diff --git a/compiler/hlds_module.m b/compiler/hlds_module.m
index a7ecb23..712f791 100644
--- a/compiler/hlds_module.m
+++ b/compiler/hlds_module.m
@@ -459,6 +459,12 @@
:- pred module_info_set_no_tag_types(no_tag_type_table::in,
module_info::in, module_info::out) is det.
+:- pred module_info_get_pragma_direct_arg_functors(module_info::in,
+ set(cons_id)::out) is det.
+
+:- pred module_info_set_pragma_direct_arg_functors(set(cons_id)::in,
+ module_info::in, module_info::out) is det.
+
:- pred module_info_get_analysis_info(module_info::in, analysis_info::out)
is det.
@@ -786,6 +792,10 @@
% faster.
msi_no_tag_type_table :: no_tag_type_table,
+ % The functors which are listed in `:- pragma direct_arg'
+ % directives.
+ msi_pragma_direct_arg_functors :: set(cons_id),
+
% Information about the procedures we are performing
% complexity experiments on.
msi_maybe_complexity_proc_map :: maybe(pair(int,
@@ -866,6 +876,7 @@ module_info_init(Name, DumpBaseFileName, Items, Globals, QualifierInfo,
SpecMap, PragmaMap),
map.init(NoTagTypes),
+ set.init(DirectArgFunctors),
MaybeComplexityMap = no,
ComplexityProcInfos = [],
@@ -890,7 +901,7 @@ module_info_init(Name, DumpBaseFileName, Items, Globals, QualifierInfo,
ExceptionInfo, TrailingInfo, TablingStructMap, MM_TablingInfo,
LambdasPerContext, AtomicsPerContext, ModelNonPragmaCounter,
ImportedModules,
- IndirectlyImportedModules, TypeSpecInfo, NoTagTypes,
+ IndirectlyImportedModules, TypeSpecInfo, NoTagTypes, DirectArgFunctors,
MaybeComplexityMap, ComplexityProcInfos,
AnalysisInfo, UserInitPredCNames, UserFinalPredCNames,
StructureReusePredIds, UsedModules, InterfaceModuleSpecs,
@@ -1015,6 +1026,8 @@ module_info_get_indirectly_imported_module_specifiers(MI,
MI ^ mi_sub_info ^ msi_indirectly_imported_module_specifiers).
module_info_get_type_spec_info(MI, MI ^ mi_sub_info ^ msi_type_spec_info).
module_info_get_no_tag_types(MI, MI ^ mi_sub_info ^ msi_no_tag_type_table).
+module_info_get_pragma_direct_arg_functors(MI,
+ MI ^ mi_sub_info ^ msi_pragma_direct_arg_functors).
module_info_get_analysis_info(MI, MI ^ mi_sub_info ^ msi_analysis_info).
module_info_get_maybe_complexity_proc_map(MI,
MI ^ mi_sub_info ^ msi_maybe_complexity_proc_map).
@@ -1172,6 +1185,8 @@ module_info_set_type_spec_info(NewVal, !MI) :-
!MI ^ mi_sub_info ^ msi_type_spec_info := NewVal.
module_info_set_no_tag_types(NewVal, !MI) :-
!MI ^ mi_sub_info ^ msi_no_tag_type_table := NewVal.
+module_info_set_pragma_direct_arg_functors(NewVal, !MI) :-
+ !MI ^ mi_sub_info ^ msi_pragma_direct_arg_functors := NewVal.
module_info_set_analysis_info(NewVal, !MI) :-
!MI ^ mi_sub_info ^ msi_analysis_info := NewVal.
module_info_set_maybe_complexity_proc_map(NewVal, !MI) :-
diff --git a/compiler/intermod.m b/compiler/intermod.m
index ede12cc..9fc424b 100644
--- a/compiler/intermod.m
+++ b/compiler/intermod.m
@@ -1471,19 +1471,49 @@ 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 = direct_arg_tag(_)
+ ->
+ !: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/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..5547f7e 100644
--- a/compiler/make_tags.m
+++ b/compiler/make_tags.m
@@ -65,6 +65,7 @@
:- import_module list.
:- import_module maybe.
+:- import_module set.
% assign_constructor_tags(Constructors, MaybeUserEq, TypeCtor,
% ReservedTagPragma, Globals, TagValues, IsEnum):
@@ -80,18 +81,37 @@
globals::in, cons_tag_values::out,
uses_reserved_address::out, du_type_kind::out) is det.
+ % For data types with exactly two alternatives, one of which is a constant,
+ % we can test against the constant (negating the result of the test, if
+ % needed), since a test against a constant is cheaper than a tag test.
+ %
+ % The type must not use reserved tags or reserved addresses.
+ %
+:- pred compute_cheaper_tag_test(cons_tag_values::in,
+ maybe_cheaper_tag_test::out) is det.
+
+ % Look for general du type definitions that can be converted into
+ % direct arg type definitions.
+ %
+:- pred post_process_type_defns(globals::in, set(cons_id)::in,
+ type_table::in, type_table::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
+:- import_module hlds.hlds_pred.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_type.
+:- import_module assoc_list.
:- import_module bool.
:- import_module int.
:- import_module map.
+:- import_module pair.
:- import_module require.
%-----------------------------------------------------------------------------%
@@ -185,8 +205,8 @@ assign_constructor_tags(Ctors, UserEqCmp, TypeCtor, ReservedTagPragma, Globals,
;
MaxTag = max_num_tags(NumTagBits) - 1,
separate_out_constants(Ctors, Constants, Functors),
- assign_constant_tags(TypeCtor, Constants, !CtorTags,
- InitTag, NextTag),
+ assign_constant_tags(TypeCtor, Constants, InitTag, NextTag,
+ !CtorTags),
assign_unshared_tags(TypeCtor, Functors, NextTag, MaxTag,
[], !CtorTags),
ReservedAddr = does_not_use_reserved_address
@@ -267,18 +287,17 @@ assign_reserved_symbolic_addresses(TypeCtor, [Ctor | Ctors], LeftOverConstants,
).
:- pred assign_constant_tags(type_ctor::in, list(constructor)::in,
- cons_tag_values::in, cons_tag_values::out, int::in, int::out) is det.
+ int::in, int::out, cons_tag_values::in, cons_tag_values::out) is det.
+assign_constant_tags(TypeCtor, Constants, InitTag, NextTag, !CtorTags) :-
% If there's no constants, don't do anything. Otherwise, allocate the
% first tag for the constants, and give them all shared local tags
% with that tag as the primary tag, and different secondary tags
% starting from zero.
%
- % Note that if there's a single constant, we still give it a
- % shared_local_tag rather than a unshared_tag. That's because
+ % Note that if there is a single constant, we still give it a
+ % shared_local_tag rather than a unshared_tag. That is because
% deconstruction of the shared_local_tag is more efficient.
- %
-assign_constant_tags(TypeCtor, Constants, !CtorTags, InitTag, NextTag) :-
(
Constants = [],
NextTag = InitTag
@@ -377,13 +396,321 @@ maybe_add_reserved_addresses(ReservedAddresses, Tag0) = Tag :-
%-----------------------------------------------------------------------------%
+compute_cheaper_tag_test(CtorTagMap, CheaperTagTest) :-
+ (
+ map.to_assoc_list(CtorTagMap, CtorTagList),
+ CtorTagList = [ConsIdA - ConsTagA, ConsIdB - ConsTagB],
+ ConsIdA = cons(_, ArityA, _),
+ ConsIdB = cons(_, ArityB, _)
+ ->
+ (
+ ArityB = 0,
+ ArityA > 0
+ ->
+ CheaperTagTest = cheaper_tag_test(ConsIdA, ConsTagA,
+ ConsIdB, ConsTagB)
+ ;
+ ArityA = 0,
+ ArityB > 0
+ ->
+ CheaperTagTest = cheaper_tag_test(ConsIdB, ConsTagB,
+ ConsIdA, ConsTagA)
+ ;
+ CheaperTagTest = no_cheaper_tag_test
+ )
+ ;
+ CheaperTagTest = no_cheaper_tag_test
+ ).
+
+%-----------------------------------------------------------------------------%
+
+post_process_type_defns(Globals, PragmaDirectArgFunctors, !TypeTable) :-
+ globals.get_target(Globals, Target),
+ (
+ Target = target_c,
+ globals.lookup_bool_option(Globals, record_term_sizes_as_words,
+ TermSizeWords),
+ globals.lookup_bool_option(Globals, record_term_sizes_as_cells,
+ TermSizeCells),
+ (
+ TermSizeWords = no,
+ TermSizeCells = no
+ ->
+ get_all_type_ctor_defns(!.TypeTable, TypeCtorsDefns),
+ globals.lookup_int_option(Globals, num_tag_bits, NumTagBits),
+ MaxTag = max_num_tags(NumTagBits) - 1,
+ convert_direct_arg_functors(MaxTag, TypeCtorsDefns,
+ PragmaDirectArgFunctors, !TypeTable)
+ ;
+ % We cannot use direct arg functors in term size grades.
+ true
+ )
+ ;
+ ( Target = target_il
+ ; Target = target_csharp
+ ; Target = target_java
+ ; Target = target_erlang
+ ; Target = target_asm
+ ; Target = target_x86_64
+ )
+ % Direct arg functors have not (yet) been implemented on these targets.
+ ).
+
+:- pred convert_direct_arg_functors(int::in,
+ assoc_list(type_ctor, hlds_type_defn)::in,
+ set(cons_id)::in, type_table::in, type_table::out) is det.
+
+convert_direct_arg_functors(_, [], _, !TypeTable).
+convert_direct_arg_functors(MaxTag,
+ [TypeCtor - TypeDefn | TypeCtorsDefns], PragmaDirectArgFunctors,
+ !TypeTable) :-
+ convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn,
+ PragmaDirectArgFunctors, !TypeTable),
+ convert_direct_arg_functors(MaxTag, TypeCtorsDefns,
+ PragmaDirectArgFunctors, !TypeTable).
+
+:- pred convert_direct_arg_functors_if_suitable(int::in,
+ type_ctor::in, hlds_type_defn::in,
+ set(cons_id)::in, type_table::in, type_table::out) is det.
+
+convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn,
+ PragmaDirectArgFunctors, !TypeTable) :-
+ get_type_defn_body(TypeDefn, Body),
+ (
+ Body = hlds_du_type(Ctors, _ConsTagValues, _MaybeCheaperTagTest,
+ DuKind, MaybeUserEqComp, ReservedTag, ReservedAddr, MaybeForeign),
+ (
+ Ctors = [_, _ | _],
+ DuKind = du_type_kind_general,
+ ReservedTag = does_not_use_reserved_tag,
+ ReservedAddr = does_not_use_reserved_address,
+ MaybeForeign = no,
+
+ TypeCtor = type_ctor(TypeCtorSymName, _TypeCtorArity),
+ sym_name_get_module_name(TypeCtorSymName, TypeCtorModule)
+ ->
+ get_type_defn_status(TypeDefn, TypeStatus),
+ separate_out_constants(Ctors, Constants, Functors),
+ list.filter(
+ is_direct_arg_ctor(!.TypeTable, TypeCtor, TypeCtorModule,
+ TypeStatus, PragmaDirectArgFunctors),
+ Functors, DirectArgFunctors, NonDirectArgFunctors),
+ (
+ DirectArgFunctors = []
+ % We cannot use the direct argument representation for any
+ % functors.
+ ;
+ DirectArgFunctors = [_ | _],
+ some [!NextTag, !CtorTags] (
+ !:NextTag = 0,
+ map.init(!:CtorTags),
+ assign_constant_tags(TypeCtor, Constants,
+ !NextTag, !CtorTags),
+ % We prefer to allocate primary tags to direct argument
+ % functors.
+ assign_direct_arg_tags(TypeCtor, DirectArgFunctors,
+ !NextTag, MaxTag, LeftOverDirectArgFunctors, !CtorTags),
+ assign_unshared_tags(TypeCtor,
+ LeftOverDirectArgFunctors ++ NonDirectArgFunctors,
+ !.NextTag, MaxTag, [], !CtorTags),
+ DirectArgConsTagValues = !.CtorTags
+ ),
+ compute_cheaper_tag_test(DirectArgConsTagValues,
+ MaybeCheaperTagTest),
+ DirectArgBody = hlds_du_type(Ctors, DirectArgConsTagValues,
+ MaybeCheaperTagTest, DuKind, MaybeUserEqComp, ReservedTag,
+ ReservedAddr, MaybeForeign),
+ set_type_defn_body(DirectArgBody, TypeDefn, DirectArgTypeDefn),
+ replace_type_ctor_defn(TypeCtor, DirectArgTypeDefn, !TypeTable)
+ )
+ ;
+ % We cannot use the direct argument representation for any
+ % functors.
+ true
+ )
+ ;
+ ( Body = hlds_eqv_type(_)
+ ; Body = hlds_foreign_type(_)
+ ; Body = hlds_solver_type(_, _)
+ ; Body = hlds_abstract_type(_)
+ )
+ % Leave these types alone.
+ ).
+
+:- pred is_direct_arg_ctor(type_table::in, type_ctor::in, module_name::in,
+ import_status::in, set(cons_id)::in, constructor::in) is semidet.
+
+is_direct_arg_ctor(TypeTable, TypeCtor, TypeCtorModule, TypeStatus,
+ PragmaDirectArgConsIds, Ctor) :-
+ % NOTE: changes here may require corresponding changes in
+ % check_pragma_direct_arg_ctors.
+
+ Ctor = ctor(ExistQTVars, ExistConstraints, ConsName, ConsArgs,
+ _CtorContext),
+ ExistQTVars = [],
+ ExistConstraints = [],
+ ConsArgs = [ConsArg],
+ ConsArg = ctor_arg(_MaybeFieldName, ArgType, _ArgContext),
+ type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeCtorArgTypes),
+ 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 (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.
+
+ ArgTypeCtor = type_ctor(ArgTypeCtorSymName, _ArgTypeCtorArity),
+ sym_name_get_module_name(ArgTypeCtorSymName, ArgTypeCtorModule),
+
+ (
+ Arity = 1,
+ set.contains(PragmaDirectArgConsIds, cons(ConsName, Arity, TypeCtor))
+ ->
+ ArgCond = direct_arg_have_pragma
+ ;
+ search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn)
+ ->
+ get_type_defn_body(ArgTypeDefn, ArgBody),
+ ArgBody = hlds_du_type(ArgCtors, ArgConsTagValues, ArgMaybeCheaperTagTest,
+ ArgDuKind, _ArgMaybeUserEqComp, ArgReservedTag, ArgReservedAddr,
+ ArgMaybeForeign),
+ ArgCtors = [_],
+ ArgMaybeCheaperTagTest = no_cheaper_tag_test,
+ ArgDuKind = du_type_kind_general,
+ ArgReservedTag = does_not_use_reserved_tag,
+ ArgReservedAddr = does_not_use_reserved_address,
+ ArgMaybeForeign = no,
+
+ map.to_assoc_list(ArgConsTagValues, ArgConsTagValueList),
+ ArgConsTagValueList = [ArgConsTagValue],
+ ArgConsTagValue = _ConsId - single_functor_tag,
+
+ ( TypeCtorModule = ArgTypeCtorModule ->
+ get_type_defn_status(ArgTypeDefn, ArgTypeStatus),
+ ArgCond = direct_arg_same_module(ArgTypeStatus)
+ ;
+ ArgCond = direct_arg_different_module
+ )
+ ;
+ % Tuples are always acceptable argument types as they are represented
+ % by word-aligned vector pointers.
+ % Strings are *not* always word-aligned (yet) so are not acceptable.
+ ArgTypeCtorSymName = unqualified("{}"),
+ ArgCond = direct_arg_builtin_type
+ ),
+
+ 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_have_pragma
+ % A `:- pragma direct_arg' specifies that the direct arg
+ % representation may be used for the constructor.
+
+ ; direct_arg_same_module(import_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.
+
+:- pred check_direct_arg_cond(import_status::in, direct_arg_cond::in)
+ is semidet.
+
+check_direct_arg_cond(TypeStatus, ArgCond) :-
+ (
+ % If the outer type _definition_ is not exported from this module then
+ % the direct arg representation may be used. In the absence of
+ % intermodule optimisation, only this module can [de]construct values
+ % of this type.
+ ( TypeStatus = status_local
+ ; TypeStatus = status_abstract_exported
+ )
+ ;
+ % If the outer type is opt-exported, another module may opt-import this
+ % type, but abstract-import the argument type. It could not then infer
+ % if the direct arg representation is required for any functors of the
+ % outer type. The problem is overcome by adding `:- pragma direct_arg'
+ % directives to .opt files alongside the opt-exported outer type, which
+ % state which functors require the direct arg representation.
+ TypeStatus = status_opt_exported
+ ;
+ % If the outer type is exported from this module, then the direct arg
+ % representation may be used, so long as any importing modules will
+ % infer the same thing. That will be so if:
+ % - if the argument is of an acceptable builtin type
+ % - there is a `:- pragma direct_arg' for the constructor
+ % - the argument type is exported from the same module as the outer
+ % type. If the outer type is exported to sub-modules only, the argument
+ % type only needs to be exported to sub-modules as well.
+ ( TypeStatus = status_exported
+ ; TypeStatus = status_exported_to_submodules
+ ),
+ ( ArgCond = direct_arg_builtin_type
+ ; ArgCond = direct_arg_have_pragma
+ ; ArgCond = direct_arg_same_module(status_exported)
+ ; ArgCond = direct_arg_same_module(TypeStatus)
+ )
+ ;
+ % The direct arg representation is required if the outer type is
+ % imported, and:
+ % - if the argument type is an acceptable builtin type
+ % - a `pragma direct_arg' says so
+ % - if the argument type is imported from the same module
+ TypeStatus = status_imported(_),
+ ( ArgCond = direct_arg_builtin_type
+ ; ArgCond = direct_arg_have_pragma
+ ; ArgCond = direct_arg_same_module(status_imported(_))
+ )
+ ;
+ % If the outer type is opt-imported, there will always be a
+ % `:- pragma direct_arg' in the same .opt file which states
+ % if the direct argument representation must be used.
+ TypeStatus = status_opt_imported,
+ ArgCond = direct_arg_have_pragma
+ ).
+
+:- 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.
+
+assign_direct_arg_tags(_, [], !Val, _, [], !CtorTags).
+assign_direct_arg_tags(TypeCtor, [Ctor | Ctors], !Val, MaxTag, LeftOverCtors,
+ !CtorTags) :-
+ Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
+ ConsId = cons(Name, list.length(Args), TypeCtor),
+ (
+ % If we are about to run out of unshared tags, stop, and return
+ % the leftovers.
+ !.Val = MaxTag,
+ Ctors = [_ | _]
+ ->
+ LeftOverCtors = [Ctor | Ctors]
+ ;
+ Tag = direct_arg_tag(!.Val),
+ % 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.
+ map.set(ConsId, Tag, !CtorTags),
+ !:Val = !.Val + 1,
+ assign_direct_arg_tags(TypeCtor, Ctors, !Val, MaxTag, LeftOverCtors,
+ !CtorTags)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Auxiliary functions and predicates.
+%
+
:- func max_num_tags(int) = int.
max_num_tags(NumTagBits) = MaxTags :-
int.pow(2, NumTagBits, MaxTags).
-%-----------------------------------------------------------------------------%
-
:- pred ctors_are_all_constants(list(constructor)::in) is semidet.
ctors_are_all_constants([]).
@@ -392,8 +719,6 @@ ctors_are_all_constants([Ctor | Rest]) :-
Args = [],
ctors_are_all_constants(Rest).
-%-----------------------------------------------------------------------------%
-
:- pred separate_out_constants(list(constructor)::in,
list(constructor)::out, list(constructor)::out) is det.
@@ -412,4 +737,5 @@ separate_out_constants([Ctor | Ctors], Constants, Functors) :-
).
%-----------------------------------------------------------------------------%
+:- end_module hlds.make_tags.
%-----------------------------------------------------------------------------%
diff --git a/compiler/mercury_compile_front_end.m b/compiler/mercury_compile_front_end.m
index 14c95f4..f61c6de 100644
--- a/compiler/mercury_compile_front_end.m
+++ b/compiler/mercury_compile_front_end.m
@@ -92,6 +92,7 @@
:- import_module check_hlds.unused_imports.
:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_statistics.
+:- import_module hlds.make_tags.
:- import_module libs.file_util.
:- import_module libs.globals.
:- import_module libs.options.
@@ -131,6 +132,17 @@ frontend_pass(QualInfo0, FoundUndefTypeError, FoundUndefModeError, !FoundError,
;
FoundUndefTypeError = no,
maybe_write_out_errors(Verbose, Globals, !HLDS, !Specs, !IO),
+
+ maybe_write_string(Verbose,
+ "% Post-processing type definitions...\n", !IO),
+ module_info_get_type_table(!.HLDS, TypeTable0),
+ module_info_get_pragma_direct_arg_functors(!.HLDS,
+ PragmaDirectArgFunctors),
+ post_process_type_defns(Globals, PragmaDirectArgFunctors,
+ TypeTable0, TypeTable),
+ module_info_set_type_table(TypeTable, !HLDS),
+ maybe_dump_hlds(!.HLDS, 3, "typedefn", !DumpInfo, !IO),
+
maybe_write_string(Verbose, "% Checking typeclasses...\n", !IO),
check_typeclasses(!HLDS, QualInfo0, QualInfo, [], TypeClassSpecs),
!:Specs = TypeClassSpecs ++ !.Specs,
@@ -145,16 +157,16 @@ frontend_pass(QualInfo0, FoundUndefTypeError, FoundUndefModeError, !FoundError,
!:FoundError = yes
;
TypeClassErrors = no,
- frontend_pass_after_typecheck(FoundUndefModeError,
+ frontend_pass_after_typeclass_check(FoundUndefModeError,
!FoundError, !HLDS, !DumpInfo, !Specs, !IO)
)
).
-:- pred frontend_pass_after_typecheck(bool::in, bool::in, bool::out,
+:- pred frontend_pass_after_typeclass_check(bool::in, bool::in, bool::out,
module_info::in, module_info::out, dump_info::in, dump_info::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
-frontend_pass_after_typecheck(FoundUndefModeError, !FoundError,
+frontend_pass_after_typeclass_check(FoundUndefModeError, !FoundError,
!HLDS, !DumpInfo, !Specs, !IO) :-
module_info_get_globals(!.HLDS, Globals),
globals.lookup_bool_option(Globals, verbose, Verbose),
diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m
index aeda650..44310d9 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..665e9e9 100644
--- a/compiler/ml_switch_gen.m
+++ b/compiler/ml_switch_gen.m
@@ -583,6 +583,7 @@ ml_tagged_cons_id_to_match_cond(MLDS_Type, TaggedConsId, MatchCond) :-
; Tag = table_io_decl_tag(_, _)
; Tag = single_functor_tag
; Tag = unshared_tag(_)
+ ; Tag = direct_arg_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..89a90fd 100644
--- a/compiler/ml_tag_switch.m
+++ b/compiler/ml_tag_switch.m
@@ -169,7 +169,9 @@ 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
+ ; SecTagLocn = sectag_none_direct_arg
+ ),
% There is no secondary tag, so there is no switch on it.
(
GoalList = [],
@@ -282,7 +284,9 @@ 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
+ ; StagLocn = sectag_none_direct_arg
+ ),
unexpected(this_file, "gen_stag_switch: no stag")
),
diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m
index e5a177e..a7d9265 100644
--- a/compiler/ml_type_gen.m
+++ b/compiler/ml_type_gen.m
@@ -325,6 +325,7 @@ ml_gen_enum_constant(Context, TypeCtor, ConsTagValues, MLDS_Type, Ctor)
; TagVal = table_io_decl_tag(_, _)
; TagVal = single_functor_tag
; TagVal = unshared_tag(_)
+ ; TagVal = direct_arg_tag(_)
; TagVal = shared_remote_tag(_, _)
; TagVal = shared_local_tag(_, _)
; TagVal = no_tag
@@ -870,6 +871,7 @@ ml_tag_uses_base_class(Tag) = UsesBaseClass :-
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
; Tag = unshared_tag(_)
+ ; Tag = direct_arg_tag(_)
; Tag = shared_remote_tag(_, _)
; Tag = shared_local_tag(_, _)
; Tag = no_tag
@@ -1249,6 +1251,7 @@ generate_foreign_enum_constant(TypeCtor, Mapping, TagValues, MLDS_Type, Ctor,
; TagVal = table_io_decl_tag(_, _)
; TagVal = single_functor_tag
; TagVal = unshared_tag(_)
+ ; TagVal = direct_arg_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..68f8adc 100644
--- a/compiler/ml_unify_gen.m
+++ b/compiler/ml_unify_gen.m
@@ -149,6 +149,10 @@
:- import_module term.
:- import_module varset.
+:- inst no_or_direct_arg_tag
+ ---> no_tag
+ ; direct_arg_tag(ground).
+
%-----------------------------------------------------------------------------%
ml_gen_unification(Unification, CodeModel, Context, Statements, !Info) :-
@@ -298,13 +302,16 @@ 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
+ ; Tag = direct_arg_tag(_)
+ ),
(
Args = [ArgVar],
- ArgModes = [_ArgMode]
+ 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,28 +319,36 @@ 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_cons_tag(MLDS_Type, Tag, Rval0),
GroundTerm = ml_ground_term(Rval, Type, MLDS_Type),
- ml_gen_info_set_const_var(Var, GroundTerm, !Info)
+ ml_gen_info_set_const_var(Var, GroundTerm, !Info),
+ Statement = ml_gen_assign(VarLval, Rval, Context),
+ Statements = [Statement]
;
- ml_gen_var(!.Info, ArgVar, ArgVarLval),
+ ml_gen_var(!.Info, ArgVar, ArgLval),
ml_variable_type(!.Info, ArgVar, ArgType),
- ArgRval = ml_lval(ArgVarLval),
- ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, Type,
- native_if_possible, ArgRval, Rval)
- ),
- Statement = ml_gen_assign(VarLval, Rval, Context),
- Statements = [Statement]
+ (
+ Tag = no_tag,
+ ArgRval = ml_lval(ArgLval),
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, Type,
+ native_if_possible, ArgRval, Rval),
+ Statement = ml_gen_assign(VarLval, Rval, Context),
+ Statements = [Statement]
+ ;
+ Tag = direct_arg_tag(Ptag),
+ ml_variable_type(!.Info, Var, VarType),
+ ml_gen_direct_arg_construct(ModuleInfo, ArgMode, Ptag,
+ ArgLval, ArgType, VarLval, VarType, Context, Statements)
+ )
+ )
+ ;
+ Tag = no_tag,
+ unexpected($module, $pred, "no_tag: arity != 1")
;
- unexpected(this_file, "ml_gen_construct_tag: no_tag: arity != 1")
+ Tag = direct_arg_tag(_),
+ unexpected($module, $pred, "direct_arg_tag: arity != 1")
)
;
- % Lambda expressions.
- Tag = closure_tag(PredId, ProcId, _EvalMethod),
- ml_gen_closure(PredId, ProcId, Var, Args, ArgModes, HowToConstruct,
- Context, Statements, !Info)
- ;
% Ordinary compound terms.
(
Tag = single_functor_tag,
@@ -351,6 +366,11 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
Args, ArgModes, TakeAddr, HowToConstruct, Context,
Statements, !Info)
;
+ % Lambda expressions.
+ Tag = closure_tag(PredId, ProcId, _EvalMethod),
+ ml_gen_closure(PredId, ProcId, Var, Args, ArgModes, HowToConstruct,
+ Context, Statements, !Info)
+ ;
% Constants.
( Tag = int_tag(_)
; Tag = foreign_tag(_, _)
@@ -471,6 +491,9 @@ ml_gen_constant(Tag, VarType, MLDS_VarType, Rval, !Info) :-
Tag = unshared_tag(_),
unexpected(this_file, "ml_gen_constant: unshared_tag")
;
+ Tag = direct_arg_tag(_),
+ unexpected(this_file, "ml_gen_constant: direct_arg_tag")
+ ;
Tag = shared_remote_tag(_, _),
unexpected(this_file, "ml_gen_constant: shared_remote_tag")
;
@@ -1103,6 +1126,19 @@ 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_cons_tag(mlds_type::in, cons_tag::in(no_or_direct_arg_tag),
+ mlds_rval::in) = (mlds_rval::out) is det.
+
+ml_cast_cons_tag(Type, Tag, Rval) = CastRval :-
+ (
+ Tag = no_tag,
+ TagRval = Rval
+ ;
+ Tag = direct_arg_tag(Ptag),
+ TagRval = ml_mkword(Ptag, Rval)
+ ),
+ CastRval = ml_unop(cast(Type), TagRval).
+
:- 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,6 +1427,22 @@ ml_gen_det_deconstruct_tag(Tag, Type, Var, ConsId, Args, Modes, Context,
unexpected(this_file, "ml_code_gen: no_tag: arity != 1")
)
;
+ Tag = direct_arg_tag(Ptag),
+ (
+ Args = [Arg],
+ Modes = [Mode]
+ ->
+ ml_variable_type(!.Info, Arg, ArgType),
+ ml_gen_var(!.Info, Arg, ArgLval),
+ ml_gen_var(!.Info, Var, VarLval),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ ml_gen_direct_arg_deconstruct(ModuleInfo, Mode, Ptag,
+ ArgLval, ArgType, VarLval, Type, Context, Statements)
+ ;
+ unexpected(this_file,
+ "ml_code_gen: direct_arg_tag: arity != 1")
+ )
+ ;
( Tag = single_functor_tag
; Tag = unshared_tag(_UnsharedTag)
; Tag = shared_remote_tag(_PrimaryTag, _SecondaryTag)
@@ -1425,7 +1477,9 @@ ml_tag_offset_and_argnum(Tag, TagBits, OffSet, ArgNum) :-
OffSet = 0,
ArgNum = 1
;
- Tag = unshared_tag(UnsharedTag),
+ ( Tag = unshared_tag(UnsharedTag)
+ ; Tag = direct_arg_tag(UnsharedTag)
+ ),
TagBits = UnsharedTag,
OffSet = 0,
ArgNum = 1
@@ -1700,6 +1754,112 @@ ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval, FieldType,
unexpected(this_file, "ml_gen_sub_unify: some strange unify")
).
+:- pred ml_gen_direct_arg_construct(module_info::in, uni_mode::in, int::in,
+ mlds_lval::in, mer_type::in, mlds_lval::in, mer_type::in, prog_context::in,
+ list(statement)::out) is det.
+
+ml_gen_direct_arg_construct(ModuleInfo, Mode, Ptag,
+ ArgLval, ArgType, VarLval, VarType, Context, Statements) :-
+ Mode = ((LI - RI) -> (LF - RF)),
+ mode_to_arg_mode(ModuleInfo, (LI -> LF), ArgType, LeftMode),
+ mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode),
+ (
+ % Skip dummy argument types, since they will not have been declared.
+ ( check_dummy_type(ModuleInfo, ArgType) = is_dummy_type
+ ; check_dummy_type(ModuleInfo, VarType) = is_dummy_type
+ )
+ ->
+ unexpected($module, $pred, "dummy unify")
+ ;
+ % Both input: it's a test unification.
+ LeftMode = top_in,
+ RightMode = top_in
+ ->
+ % This shouldn't happen, since mode analysis should avoid creating
+ % any tests in the arguments of a construction or deconstruction
+ % unification.
+ unexpected($module, $pred, "test in arg of [de]construction")
+ ;
+ % Input - output: it's an assignment to the RHS.
+ LeftMode = top_in,
+ RightMode = top_out
+ ->
+ unexpected($module, $pred, "left-to-right data flow in construction")
+ ;
+ % Output - input: it's an assignment to the LHS.
+ LeftMode = top_out,
+ RightMode = top_in
+ ->
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, VarType,
+ native_if_possible, ml_lval(ArgLval), ArgRval),
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, VarType),
+ CastRval = ml_unop(cast(MLDS_Type), ml_mkword(Ptag, ArgRval)),
+ Statement = ml_gen_assign(VarLval, CastRval, Context),
+ Statements = [Statement]
+ ;
+ % Unused - unused: the unification has no effect.
+ LeftMode = top_unused,
+ RightMode = top_unused
+ ->
+ Statements = []
+ ;
+ unexpected($module, $pred, "some strange unify")
+ ).
+
+:- pred ml_gen_direct_arg_deconstruct(module_info::in, uni_mode::in, int::in,
+ mlds_lval::in, mer_type::in, mlds_lval::in, mer_type::in, prog_context::in,
+ list(statement)::out) is det.
+
+ml_gen_direct_arg_deconstruct(ModuleInfo, Mode, Ptag,
+ ArgLval, ArgType, VarLval, VarType, Context, Statements) :-
+ Mode = ((LI - RI) -> (LF - RF)),
+ mode_to_arg_mode(ModuleInfo, (LI -> LF), ArgType, LeftMode),
+ mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode),
+ (
+ % Skip dummy argument types, since they will not have been declared.
+ ( check_dummy_type(ModuleInfo, ArgType) = is_dummy_type
+ ; check_dummy_type(ModuleInfo, VarType) = is_dummy_type
+ )
+ ->
+ unexpected($module, $pred, "dummy unify")
+ ;
+ % Both input: it's a test unification.
+ LeftMode = top_in,
+ RightMode = top_in
+ ->
+ % This shouldn't happen, since mode analysis should avoid creating
+ % any tests in the arguments of a construction or deconstruction
+ % unification.
+ unexpected($module, $pred, "test in arg of [de]construction")
+ ;
+ % Input - output: it's an assignment to the RHS.
+ LeftMode = top_in,
+ RightMode = top_out
+ ->
+ ml_gen_box_or_unbox_rval(ModuleInfo, VarType, ArgType,
+ native_if_possible, ml_lval(VarLval), VarRval),
+ Statement = ml_gen_assign(ArgLval,
+ ml_binop(body, VarRval, ml_const(mlconst_int(Ptag))), Context),
+ Statements = [Statement]
+ ;
+ % Output - input: it's an assignment to the LHS.
+ LeftMode = top_out,
+ RightMode = top_in
+ ->
+ ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, VarType,
+ native_if_possible, ml_lval(ArgLval), ArgRval),
+ Statement = ml_gen_assign(VarLval, ml_mkword(Ptag, ArgRval), Context),
+ Statements = [Statement]
+ ;
+ % Unused - unused: the unification has no effect.
+ LeftMode = top_unused,
+ RightMode = top_unused
+ ->
+ Statements = []
+ ;
+ unexpected($module, $pred, "some strange unify")
+ ).
+
%-----------------------------------------------------------------------------%
% Generate a semidet deconstruction. A semidet deconstruction unification
@@ -1811,7 +1971,9 @@ 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)
+ ; Tag = direct_arg_tag(UnsharedTagNum)
+ ),
RvalTag = ml_unop(std_unop(tag), Rval),
UnsharedTag = ml_unop(std_unop(mktag),
ml_const(mlconst_int(UnsharedTagNum))),
@@ -2125,14 +2287,16 @@ 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
+ ; ConsTag = direct_arg_tag(_)
+ ),
(
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_cons_tag(MLDS_Type, ConsTag, Rval0),
GroundTerm = ml_ground_term(Rval, VarType, MLDS_Type),
map.det_insert(Var, GroundTerm, !GroundTermMap)
;
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 d2967b4..07a95d0 100644
--- a/compiler/rtti.m
+++ b/compiler/rtti.m
@@ -381,6 +381,7 @@
%
:- type sectag_locn
---> sectag_none
+ ; sectag_none_direct_arg
; sectag_local
; sectag_remote.
@@ -389,6 +390,7 @@
%
:- type sectag_and_locn
---> sectag_locn_none
+ ; sectag_locn_none_direct_arg
; sectag_locn_local(int)
; sectag_locn_remote(int).
@@ -1512,13 +1514,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,
+ String = "MR_SECTAG_NONE"
+ ;
+ SecTag = sectag_none_direct_arg,
+ 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,
+ String = "MR_SECTAG_NONE"
+ ;
+ SecTag = sectag_locn_none_direct_arg,
+ 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..4cbb9e7 100644
--- a/compiler/rtti_out.m
+++ b/compiler/rtti_out.m
@@ -918,6 +918,10 @@ output_du_functor_defn(Info, RttiTypeCtor, DuFunctor, !DeclSet, !IO) :-
Locn = "MR_SECTAG_NONE",
Stag = -1
;
+ SectagAndLocn = sectag_locn_none_direct_arg,
+ 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..e194d10 100644
--- a/compiler/rtti_to_mlds.m
+++ b/compiler/rtti_to_mlds.m
@@ -765,6 +765,10 @@ gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData) :-
Locn = sectag_none,
Stag = -1
;
+ SectagAndLocn = sectag_locn_none_direct_arg,
+ Locn = sectag_none_direct_arg,
+ Stag = -1
+ ;
SectagAndLocn = sectag_locn_local(Stag),
Locn = sectag_local
;
diff --git a/compiler/switch_gen.m b/compiler/switch_gen.m
index e3bf7b8..b574f1d 100644
--- a/compiler/switch_gen.m
+++ b/compiler/switch_gen.m
@@ -435,6 +435,7 @@ is_reserved_addr_tag(TaggedConsId) = IsReservedAddr :-
; ConsTag = tabling_info_tag(_, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = unshared_tag(_)
+ ; ConsTag = direct_arg_tag(_)
),
IsReservedAddr = no
).
diff --git a/compiler/switch_util.m b/compiler/switch_util.m
index ab01d49..dddafd6 100644
--- a/compiler/switch_util.m
+++ b/compiler/switch_util.m
@@ -524,7 +524,9 @@ estimate_switch_tag_test_cost(Tag) = Cost :-
% of the scan over them.
Cost = 2
;
- Tag = unshared_tag(_),
+ ( Tag = unshared_tag(_)
+ ; Tag = direct_arg_tag(_)
+ ),
% You need to compute the primary tag and compare it.
Cost = 2
;
@@ -1079,14 +1081,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
+ ;
+ Tag = unshared_tag(Primary),
+ SecTag = sectag_none
+ ;
+ Tag = direct_arg_tag(Primary),
+ SecTag = sectag_none_direct_arg
),
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),
@@ -1098,6 +1108,7 @@ get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :-
;
( TagType = sectag_local
; TagType = sectag_none
+ ; TagType = sectag_none_direct_arg
),
unexpected(this_file, "remote tag is shared with non-remote")
),
@@ -1116,6 +1127,7 @@ get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :-
;
( TagType = sectag_remote
; TagType = sectag_none
+ ; TagType = sectag_none_direct_arg
),
unexpected(this_file, "local tag is shared with non-local")
),
@@ -1179,14 +1191,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
+ ;
+ Tag = unshared_tag(Primary),
+ SecTag = sectag_none
+ ;
+ Tag = direct_arg_tag(Primary),
+ SecTag = sectag_none_direct_arg
),
( 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)
)
;
@@ -1289,7 +1309,9 @@ build_ptag_case_rev_map([Entry | Entries], PtagCountMap, !RevMap) :-
Entry = Ptag - Case,
map.lookup(PtagCountMap, Ptag, CountSecTagLocn - Count),
(
- CountSecTagLocn = sectag_none,
+ ( CountSecTagLocn = sectag_none
+ ; CountSecTagLocn = sectag_none_direct_arg
+ ),
( 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..51619c7 100644
--- a/compiler/tag_switch.m
+++ b/compiler/tag_switch.m
@@ -668,7 +668,9 @@ 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
+ ; StagLoc = sectag_none_direct_arg
+ ),
% 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..ef0f2a4 100644
--- a/compiler/type_ctor_info.m
+++ b/compiler/type_ctor_info.m
@@ -489,7 +489,7 @@ impl_type_ctor("table_builtin", "ml_subgoal", 0, impl_ctor_subgoal).
%
:- func type_ctor_info_rtti_version = int.
-type_ctor_info_rtti_version = 13.
+type_ctor_info_rtti_version = 14.
% Construct an rtti_data for a pseudo_type_info, and also construct
% rtti_data definitions for all of the pseudo_type_infos that it references
@@ -714,6 +714,7 @@ make_foreign_enum_functors(TypeCtor, Lang, [Functor | Functors], NextOrdinal,
; ConsTag = table_io_decl_tag(_, _)
; ConsTag = single_functor_tag
; ConsTag = unshared_tag(_)
+ ; ConsTag = direct_arg_tag(_)
; ConsTag = shared_remote_tag(_, _)
; ConsTag = shared_local_tag(_, _)
; ConsTag = no_tag
@@ -821,7 +822,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 +853,22 @@ 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,
+ ConsRep = du_rep(du_ll_rep(ConsPtag, SecTagLocn))
;
ConsTag = unshared_tag(ConsPtag),
- ConsRep = du_rep(du_ll_rep(ConsPtag, sectag_locn_none))
+ SecTagLocn = sectag_locn_none,
+ ConsRep = du_rep(du_ll_rep(ConsPtag, SecTagLocn))
+ ;
+ ConsTag = direct_arg_tag(ConsPtag),
+ SecTagLocn = sectag_locn_none_direct_arg,
+ 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 +882,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(_)
@@ -1003,6 +1010,10 @@ make_du_ptag_ordered_table(DuFunctor, !PtagTable) :-
SectagLocn = sectag_none,
Sectag = 0
;
+ SectagAndLocn = sectag_locn_none_direct_arg,
+ SectagLocn = sectag_none_direct_arg,
+ Sectag = 0
+ ;
SectagAndLocn = sectag_locn_local(Sectag),
SectagLocn = sectag_local
;
diff --git a/compiler/unify_gen.m b/compiler/unify_gen.m
index 2aa7a95..4c03a05 100644
--- a/compiler/unify_gen.m
+++ b/compiler/unify_gen.m
@@ -392,7 +392,9 @@ raw_tag_test(Rval, ConsTag, TestRval) :-
ConsTag = single_functor_tag,
TestRval = const(llconst_true)
;
- ConsTag = unshared_tag(UnsharedTag),
+ ( ConsTag = unshared_tag(UnsharedTag)
+ ; ConsTag = direct_arg_tag(UnsharedTag)
+ ),
VarPtag = unop(tag, Rval),
ConstPtag = unop(mktag, const(llconst_int(UnsharedTag))),
TestRval = binop(eq, VarPtag, ConstPtag)
@@ -514,6 +516,24 @@ generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct,
construct_cell(Var, Ptag, MaybeRvals, HowToConstruct,
MaybeSize, FieldAddrs, MayUseAtomic, Code, !CI)
;
+ ConsTag = direct_arg_tag(Ptag),
+ (
+ Args = [Arg],
+ Modes = [Mode]
+ ->
+ (
+ TakeAddr = [],
+ Type = variable_type(!.CI, Arg),
+ generate_direct_arg_construct(Var, Arg, Ptag, Mode, Type, Code,
+ !CI)
+ ;
+ TakeAddr = [_ | _],
+ unexpected($module, $pred, "direct_arg_tag: take_addr")
+ )
+ ;
+ unexpected($module, $pred, "direct_arg_tag: arity != 1")
+ )
+ ;
ConsTag = shared_remote_tag(Ptag, Sectag),
var_types(!.CI, Args, ArgTypes),
generate_cons_args(Args, ArgTypes, Modes, 1, 1, TakeAddr, !.CI,
@@ -1102,6 +1122,18 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
var_types(!.CI, Args, ArgTypes),
generate_unify_args(Fields, ArgVars, Modes, ArgTypes, Code, !CI)
;
+ Tag = direct_arg_tag(Ptag),
+ (
+ Args = [Arg],
+ Modes = [Mode]
+ ->
+ Type = variable_type(!.CI, Arg),
+ generate_direct_arg_deconstruct(Var, Arg, Ptag, Mode, Type, Code,
+ !CI)
+ ;
+ unexpected($module, $pred, "direct_arg_tag: arity != 1")
+ )
+ ;
Tag = shared_remote_tag(Ptag, _Sectag1),
Rval = var(Var),
make_fields_and_argvars(Args, Rval, 1, Ptag, Fields, ArgVars),
@@ -1208,8 +1240,6 @@ generate_sub_unify(L, R, Mode, Type, Code, !CI) :-
unexpected($module, $pred, "some strange unify")
).
-%---------------------------------------------------------------------------%
-
:- pred generate_sub_assign(uni_val::in, uni_val::in, llds_code::out,
code_info::in, code_info::out) is det.
@@ -1248,6 +1278,103 @@ generate_sub_assign(Left, Right, Code, !CI) :-
%---------------------------------------------------------------------------%
+ % Generate a direct arg unification between
+ % - the left-hand-side (the whole term), and
+ % - the right-hand-side (the one argument).
+ %
+:- pred generate_direct_arg_construct(prog_var::in, prog_var::in, tag_bits::in,
+ uni_mode::in, mer_type::in, llds_code::out,
+ code_info::in, code_info::out) is det.
+
+generate_direct_arg_construct(Var, Arg, Ptag, Mode, Type, Code, !CI) :-
+ Mode = ((LI - RI) -> (LF - RF)),
+ get_module_info(!.CI, ModuleInfo),
+ mode_to_arg_mode(ModuleInfo, (LI -> LF), Type, LeftMode),
+ mode_to_arg_mode(ModuleInfo, (RI -> RF), Type, RightMode),
+ (
+ % Input - input == test unification
+ LeftMode = top_in,
+ RightMode = top_in
+ ->
+ % This shouldn't happen, since mode analysis should avoid creating
+ % any tests in the arguments of a construction or deconstruction
+ % unification.
+ unexpected($module, $pred, "test in arg of [de]construction")
+ ;
+ % Input - Output == assignment ->
+ LeftMode = top_in,
+ RightMode = top_out
+ ->
+ unexpected($module, $pred, "left-to-right data flow in construction")
+ ;
+ % Output - Input == assignment <-
+ LeftMode = top_out,
+ RightMode = top_in
+ ->
+ assign_expr_to_var(Var, mkword(Ptag, var(Arg)), Code, !CI)
+ ;
+ LeftMode = top_unused,
+ RightMode = top_unused
+ ->
+ Code = empty
+ % free-free - ignore
+ % XXX I think this will have to change if we start to support aliasing.
+ ;
+ unexpected($module, $pred, "some strange unify")
+ ).
+
+ % Generate a direct arg unification between
+ % - the left-hand-side (the whole term), and
+ % - the right-hand-side (the one argument).
+ %
+:- pred generate_direct_arg_deconstruct(prog_var::in, prog_var::in,
+ tag_bits::in, uni_mode::in, mer_type::in, llds_code::out,
+ code_info::in, code_info::out) is det.
+
+generate_direct_arg_deconstruct(Var, Arg, Ptag, Mode, Type, Code, !CI) :-
+ Mode = ((LI - RI) -> (LF - RF)),
+ get_module_info(!.CI, ModuleInfo),
+ mode_to_arg_mode(ModuleInfo, (LI -> LF), Type, LeftMode),
+ mode_to_arg_mode(ModuleInfo, (RI -> RF), Type, RightMode),
+ (
+ % Input - input == test unification
+ LeftMode = top_in,
+ RightMode = top_in
+ ->
+ % This shouldn't happen, since mode analysis should avoid creating
+ % any tests in the arguments of a construction or deconstruction
+ % unification.
+ unexpected($module, $pred, "test in arg of [de]construction")
+ ;
+ % Input - Output == assignment ->
+ LeftMode = top_in,
+ RightMode = top_out
+ ->
+ ( variable_is_forward_live(!.CI, Arg) ->
+ assign_expr_to_var(Arg,
+ binop(body, var(Var), const(llconst_int(Ptag))), Code, !CI)
+ ;
+ Code = empty
+ )
+ ;
+ % Output - Input == assignment <-
+ LeftMode = top_out,
+ RightMode = top_in
+ ->
+ assign_expr_to_var(Var, mkword(Ptag, var(Arg)), Code, !CI)
+ ;
+ LeftMode = top_unused,
+ RightMode = top_unused
+ ->
+ Code = empty
+ % free-free - ignore
+ % XXX I think this will have to change if we start to support aliasing.
+ ;
+ unexpected($module, $pred, "some strange unify")
+ ).
+
+%---------------------------------------------------------------------------%
+
:- type active_ground_term == pair(rval, llds_type).
:- type active_ground_term_map == map(prog_var, active_ground_term).
@@ -1403,6 +1530,20 @@ generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
ActiveGroundTerm = Rval - lt_data_ptr,
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
+ ConsTag = direct_arg_tag(Ptag),
+ (
+ 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, "direct_arg_tag: 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 5279bc5..f2c7708 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -9510,6 +9510,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
@@ -10053,6 +10058,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..7e65790 100644
--- a/library/construct.m
+++ b/library/construct.m
@@ -732,6 +732,19 @@ 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;
+ if (arity != 1) {
+ MR_fatal_error(
+ ""construct(): direct_arg_tag arity != 1"");
+ }
+
+ arg_data = MR_field(MR_UNIV_TAG, MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_DATA);
+ new_data = MR_mkword(MR_mktag(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/library/private_builtin.m b/library/private_builtin.m
index e9d00ef..a4024a7 100644
--- a/library/private_builtin.m
+++ b/library/private_builtin.m
@@ -1722,10 +1722,11 @@ no_clauses(PredName) :-
public static final int MR_TYPECTOR_REP_UNKNOWN = 46;
public static final int MR_TYPECTOR_REP_MAX = 47;
- public static final int MR_SECTAG_NONE = 0;
- public static final int MR_SECTAG_LOCAL = 1;
- public static final int MR_SECTAG_REMOTE = 2;
- public static final int MR_SECTAG_VARIABLE = 3;
+ public static final int MR_SECTAG_NONE = 0;
+ public static final int MR_SECTAG_NONE_DIRECT_ARG = 1;
+ public static final int MR_SECTAG_LOCAL = 2;
+ public static final int MR_SECTAG_REMOTE = 3;
+ public static final int MR_SECTAG_VARIABLE = 4;
public static final int MR_PREDICATE = 0;
public static final int MR_FUNCTION = 1;
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..5a539f1 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,42 @@ try_again:
MR_handle_sectag_remote_or_none(MR_FALSE);
return new_data;
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ /*
+ ** This code is a cut-down and specialized version
+ ** of the code for MR_SECTAG_NONE.
+ */
+ data_value = (MR_Word *) MR_body(data, ptag);
+ RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
+ {
+ const MR_DuFunctorDesc *functor_desc;
+ const MR_DuExistInfo *exist_info;
+ int arity;
+
+ 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;
+ if (arity != 1) {
+ MR_fatal_error("arity != 1 in direct arg tag functor");
+ }
+ if (exist_info != NULL) {
+ MR_fatal_error("exist_info in direct arg tag functor");
+ }
+
+ new_data = copy((MR_Word) data_value,
+ 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);
+ /*
+ ** We cannot (and shouldn't need to) leave a forwarding
+ ** pointer for the whole term that is separate from the
+ ** forwarding pointer for the argument.
+ */
+ }
+ 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..c8b1144 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 direct_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];
+ direct_arg = MR_body(data, ptag);
+ arg_vector = &direct_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..5ec130b 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 direct_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];
+ direct_arg = MR_body(data, ptag);
+ arg_vector = &direct_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..df2ecbf 100644
--- a/runtime/mercury_term_size.c
+++ b/runtime/mercury_term_size.c
@@ -86,6 +86,13 @@ try_again:
#endif
return MR_field(MR_mktag(ptag), term, -1);
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ /*
+ ** The compiler should not generate direct arg tags
+ ** in term size recording grades.
+ */
+ MR_fatal_error("MR_term_size: DIRECT_ARG");
+
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..c12974e 100644
--- a/runtime/mercury_type_info.h
+++ b/runtime/mercury_type_info.h
@@ -72,7 +72,7 @@
** compiler/type_ctor_info.m.
*/
-#define MR_RTTI_VERSION MR_RTTI_VERSION__BITMAP
+#define MR_RTTI_VERSION MR_RTTI_VERSION__DIRECT_ARG
#define MR_RTTI_VERSION__INITIAL 2
#define MR_RTTI_VERSION__USEREQ 3
#define MR_RTTI_VERSION__CLEAN_LAYOUT 4
@@ -85,6 +85,7 @@
#define MR_RTTI_VERSION__DUMMY 11
#define MR_RTTI_VERSION__FUNCTOR_NUMBERS 12
#define MR_RTTI_VERSION__BITMAP 13
+#define MR_RTTI_VERSION__DIRECT_ARG 14
/*
** Check that the RTTI version is in a sensible range.
@@ -839,6 +840,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 +875,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 +973,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{,_DIRECT_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
@@ -1399,7 +1403,7 @@ typedef void MR_CALL MR_CompareFunc_5(MR_Mercury_Type_Info,
#define MR_DEFINE_TYPE_CTOR_INFO_BODY_FLAG(m, n, a, cr, u, c, f, fns) \
{ \
a, \
- MR_RTTI_VERSION__FUNCTOR_NUMBERS, \
+ MR_RTTI_VERSION__DIRECT_ARG, \
-1, \
MR_PASTE2(MR_TYPECTOR_REP_, cr), \
MR_DEFINE_TYPE_CTOR_INFO_CODE(u), \
diff --git a/runtime/mercury_unify_compare_body.h b/runtime/mercury_unify_compare_body.h
index 1d9f2a0..fa5eccc 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;
@@ -311,12 +313,52 @@ start_label:
functor_desc = ptaglayout->MR_sectag_alternatives[x_sectag];
#endif /* select_compare_code */
- if (functor_desc->MR_du_functor_sectag_locn ==
- MR_SECTAG_REMOTE)
- {
+ switch (functor_desc->MR_du_functor_sectag_locn) {
+
+ case MR_SECTAG_NONE_DIRECT_ARG:
+ /* the work is done in the switch */
+ {
+ MR_TypeInfo arg_type_info;
+
+ arg_type_info = (MR_TypeInfo)
+ functor_desc->MR_du_functor_arg_types[0];
+ MR_save_transient_registers();
+ #ifdef select_compare_code
+ #ifdef include_compare_rep_code
+ result = MR_generic_compare_representation(
+ arg_type_info,
+ (MR_Word) x_data_value, (MR_Word) y_data_value);
+ #else
+ result = MR_generic_compare(arg_type_info,
+ (MR_Word) x_data_value, (MR_Word) y_data_value);
+ #endif
+ #else
+ result = MR_generic_unify(arg_type_info,
+ (MR_Word) x_data_value, (MR_Word) y_data_value);
+ #endif
+ MR_restore_transient_registers();
+ }
+
+ #ifdef select_compare_code
+ return_compare_answer(builtin, user_by_rtti, 0, result);
+ #else
+ return_unify_answer(builtin, user_by_rtti, 0, result);
+ #endif
+ break;
+
+ case MR_SECTAG_REMOTE:
cur_slot = 1;
- } else {
+ /* the work is done after the switch */
+ break;
+
+ case MR_SECTAG_NONE:
+ case MR_SECTAG_LOCAL:
cur_slot = 0;
+ /* the work is done after the switch */
+ break;
+
+ default:
+ MR_fatal_error("bad sectag location in direct arg switch");
}
arity = functor_desc->MR_du_functor_orig_arity;
diff --git a/tests/debugger/Mmakefile b/tests/debugger/Mmakefile
index 58040ee..0aa945c 100644
--- a/tests/debugger/Mmakefile
+++ b/tests/debugger/Mmakefile
@@ -25,6 +25,7 @@ NONRETRY_PROGS = \
class_decl \
cmd_quote \
cond \
+ chooser_tag_test \
debugger_regs \
dice \
double_print \
@@ -284,7 +285,11 @@ cmd_quote.out: cmd_quote cmd_quote.inp
sed 's/io.m:[0-9]*/io.m:NNNN/g' > cmd_quote.out 2>&1
cond.out: cond cond.inp
- $(MDB_STD) ./cond < cond.inp 2>&1 > cond.out 2>&1
+ $(MDB_STD) ./cond < cond.inp > cond.out 2>&1
+
+chooser_tag_test.out: chooser_tag_test chooser_tag_test.inp
+ $(MDB_STD) ./chooser_tag_test < chooser_tag_test.inp \
+ > chooser_tag_test.out 2>&1
# Set up readline to make it easier to use completion non-interactively.
completion.out: completion completion.inp
diff --git a/tests/debugger/chooser_tag_test.exp b/tests/debugger/chooser_tag_test.exp
new file mode 100644
index 0000000..8824a76
--- /dev/null
+++ b/tests/debugger/chooser_tag_test.exp
@@ -0,0 +1,50 @@
+ E1: C1 CALL pred chooser_tag_test.main/2-0 (det) chooser_tag_test.m:53
+mdb> mdb> echo on
+Command echo enabled.
+mdb> context none
+Contexts will not be printed.
+mdb> table_io start
+I/O tabling started.
+mdb> break test_wraps
+ 0: + stop interface pred chooser_tag_test.test_wraps/2-0 (det)
+mdb> continue
+ E2: C2 CALL pred chooser_tag_test.test_wraps/2-0 (det)
+mdb> finish
+test_wrap_a: A0 = a(10, 11), X = xa(a(10, 11)), A1 = a(10, 11)
+test_wrap_a: A0 = a(12, 20), X = xa(a(12, 20)), A1 = a(12, 20)
+test_wrap_b: B0 = b(10, "eleven"), X = xb(b(10, "eleven")), B1 = b(10, "eleven")
+test_wrap_b: B0 = b(12, "twenty"), X = xb(b(12, "twenty")), B1 = b(12, "twenty")
+test_wrap_c: C0 = c("ten", 11), X = xc(c("ten", 11)), C1 = c("ten", 11)
+test_wrap_c: C0 = c("twelve", 20), X = xc(c("twelve", 20)), C1 = c("twelve", 20)
+ E3: C2 EXIT pred chooser_tag_test.test_wraps/2-0 (det)
+mdb> retry -f
+ E2: C2 CALL pred chooser_tag_test.test_wraps/2-0 (det)
+mdb> break wrap_a
+ 1: + stop interface pred chooser_tag_test.wrap_a/2-0 (det)
+mdb> continue
+ E4: C3 CALL pred chooser_tag_test.wrap_a/2-0 (det)
+mdb> print *
+ A (arg 1) a(10, 11)
+mdb> finish
+ E5: C3 EXIT pred chooser_tag_test.wrap_a/2-0 (det)
+mdb> print *
+ A (arg 1) a(10, 11)
+ HeadVar__2 xa(a(10, 11))
+mdb> delete *
+ 0: E stop interface pred chooser_tag_test.test_wraps/2-0 (det)
+ 1: E stop interface pred chooser_tag_test.wrap_a/2-0 (det)
+mdb> break unwrap_b
+ 0: + stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet)
+mdb> condition HeadVar__1 = xb(b(12, _))
+ 0: + stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet)
+ HeadVar__1 = xb(b(12, _))
+mdb> continue
+ E6: C4 CALL pred chooser_tag_test.unwrap_b/2-0 (semidet)
+mdb> print
+unwrap_b(xb(b(12, "twenty")), _)
+mdb> delete *
+ 0: E stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet)
+ HeadVar__1 = xb(b(12, _))
+mdb> continue
+solns for 30 = [xa(a(30, 30)), xa(a(31, 31)), xb(b(30, "b2")), xb(b(31, "b2")), xc(c("c1", 30)), xc(c("c1", 31))]
+solns for 130 = []
diff --git a/tests/debugger/chooser_tag_test.inp b/tests/debugger/chooser_tag_test.inp
new file mode 100644
index 0000000..8b9786d
--- /dev/null
+++ b/tests/debugger/chooser_tag_test.inp
@@ -0,0 +1,20 @@
+register --quiet
+echo on
+context none
+table_io start
+break test_wraps
+continue
+finish
+retry -f
+break wrap_a
+continue
+print *
+finish
+print *
+delete *
+break unwrap_b
+condition HeadVar__1 = xb(b(12, _))
+continue
+print
+delete *
+continue
diff --git a/tests/debugger/chooser_tag_test.m b/tests/debugger/chooser_tag_test.m
new file mode 100644
index 0000000..e7334f1
--- /dev/null
+++ b/tests/debugger/chooser_tag_test.m
@@ -0,0 +1,151 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4
+%-----------------------------------------------------------------------------%
+
+:- module chooser_tag_test.
+:- interface.
+
+:- import_module io.
+
+:- type a
+ ---> a(a1 :: int, a2 :: int).
+
+:- type b
+ ---> b(b1 :: int, b2 :: string).
+
+:- type c
+ ---> c(c1 :: string, c2 :: int).
+
+:- type x
+ ---> xa(xaf:: a)
+ ; xb(xbf:: b)
+ ; xc(xcf:: c)
+ ; xd
+ ; xe.
+
+:- pred wrap_a(a::in, x::out) is det.
+:- pred wrap_b(b::in, x::out) is det.
+:- pred wrap_c(c::in, x::out) is det.
+
+:- pred unwrap_a(x::in, a::out) is semidet.
+:- pred unwrap_b(x::in, b::out) is semidet.
+:- pred unwrap_c(x::in, c::out) is semidet.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+:- import_module solutions.
+:- import_module string.
+
+wrap_a(A, xa(A)).
+wrap_b(B, xb(B)).
+wrap_c(C, xc(C)).
+
+unwrap_a(xa(A), A).
+unwrap_b(xb(B), B).
+unwrap_c(xc(C), C).
+
+main(!IO) :-
+ test_wraps(!IO),
+ test_solutions(30, !IO),
+ test_solutions(130, !IO).
+
+:- pred test_wraps(io::di, io::uo) is det.
+
+test_wraps(!IO) :-
+ list.foldl(test_wrap_a, [a(10, 11), a(12, 20)], !IO),
+ list.foldl(test_wrap_b, [b(10, "eleven"), b(12, "twenty")], !IO),
+ list.foldl(test_wrap_c, [c("ten", 11), c("twelve", 20)], !IO).
+
+:- pred test_wrap_a(a::in, io::di, io::uo) is det.
+
+test_wrap_a(A0, !IO) :-
+ io.write_string("test_wrap_a: A0 = ", !IO),
+ io.write(A0, !IO),
+ io.write_string(", X = ", !IO),
+ wrap_a(A0, X),
+ io.write(X, !IO),
+ io.write_string(", A1 = ", !IO),
+ ( unwrap_a(X, A1) ->
+ io.write(A1, !IO)
+ ;
+ io.write_string("unwrap failed", !IO)
+ ),
+ io.nl(!IO).
+
+:- pred test_wrap_b(b::in, io::di, io::uo) is det.
+
+test_wrap_b(B0, !IO) :-
+ io.write_string("test_wrap_b: B0 = ", !IO),
+ io.write(B0, !IO),
+ io.write_string(", X = ", !IO),
+ wrap_b(B0, X),
+ io.write(X, !IO),
+ io.write_string(", B1 = ", !IO),
+ ( unwrap_b(X, B1) ->
+ io.write(B1, !IO)
+ ;
+ io.write_string("unwrap failed", !IO)
+ ),
+ io.nl(!IO).
+
+:- pred test_wrap_c(c::in, io::di, io::uo) is det.
+
+test_wrap_c(C0, !IO) :-
+ io.write_string("test_wrap_c: C0 = ", !IO),
+ io.write(C0, !IO),
+ io.write_string(", X = ", !IO),
+ wrap_c(C0, X),
+ io.write(X, !IO),
+ io.write_string(", C1 = ", !IO),
+ ( unwrap_c(X, C1) ->
+ io.write(C1, !IO)
+ ;
+ io.write_string("unwrap failed", !IO)
+ ),
+ io.nl(!IO).
+
+:- pred test_solutions(int::in, io::di, io::uo) is det.
+
+test_solutions(N, !IO) :-
+ solutions(get_solutions(N), Solns),
+ io.format("solns for %d = ", [i(N)], !IO),
+ io.write(Solns, !IO),
+ io.nl(!IO).
+
+:- pred get_solutions(int::in, x::out) is nondet.
+
+get_solutions(N, X) :-
+ ( get_solutions_a(N, X)
+ ; get_solutions_b(N, X)
+ ; get_solutions_c(N, X)
+ ).
+
+:- pred get_solutions_a(int::in, x::out) is nondet.
+
+get_solutions_a(N, X) :-
+ N < 100,
+ ( X = xa(a(N, N))
+ ; X = xa(a(N+1, N+1))
+ ).
+
+:- pred get_solutions_b(int::in, x::out) is nondet.
+
+get_solutions_b(N, X) :-
+ N < 100,
+ ( X = xb(b(N, "b2"))
+ ; X = xb(b(N+1, "b2"))
+ ).
+
+:- pred get_solutions_c(int::in, x::out) is nondet.
+
+get_solutions_c(N, X) :-
+ N < 100,
+ ( X = xc(c("c1", N))
+ ; X = xc(c("c1", N+1))
+ ).
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..9041b02
--- /dev/null
+++ b/tests/hard_coded/direct_arg_intermod2.m
@@ -0,0 +1,65 @@
+%-----------------------------------------------------------------------------%
+
+:- 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 not exported so the direct arg represention should be safe
+ % for yes/1. But when it is opt-exported, the importing module also needs
+ % to use the direct arg represention, without necessarily knowing the
+ % definition of foo.
+ %
+:- 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
diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile
index 74e24ea..3346004 100644
--- a/tests/invalid/Mmakefile
+++ b/tests/invalid/Mmakefile
@@ -168,6 +168,7 @@ SINGLEMODULE= \
polymorphic_unification \
pragma_c_code_dup_var \
pragma_c_code_no_det \
+ pragma_direct_arg_bad \
pragma_source_file \
predmode \
prog_io_erroneous \
diff --git a/tests/invalid/ee_invalid.err_exp b/tests/invalid/ee_invalid.err_exp
index ca0cc74..3a93fcc 100644
--- a/tests/invalid/ee_invalid.err_exp
+++ b/tests/invalid/ee_invalid.err_exp
@@ -5,7 +5,7 @@ ee_invalid.m:037: error: undefined type `undefined_type'/0.
ee_invalid.m:041: In `pragma foreign_export_enum' declaration for
ee_invalid.m:041: `ee_invalid.foo'/1:
ee_invalid.m:041: error: `ee_invalid.foo'/1 is not an enumeration type. It
-ee_invalid.m:041: has one more non-zero arity constructors.
+ee_invalid.m:041: has one or more non-zero arity constructors.
ee_invalid.m:045: In `pragma foreign_export_enum' declaration for
ee_invalid.m:045: `ee_invalid.bar'/0:
ee_invalid.m:045: error: `ee_invalid.bar'/0 is not an enumeration type.
diff --git a/tests/invalid/pragma_direct_arg_bad.err_exp b/tests/invalid/pragma_direct_arg_bad.err_exp
new file mode 100644
index 0000000..158a877
--- /dev/null
+++ b/tests/invalid/pragma_direct_arg_bad.err_exp
@@ -0,0 +1,29 @@
+pragma_direct_arg_bad.m:024: In `pragma direct_arg' declaration for
+pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.example'/0:
+pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.zero'/0 cannot be
+pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
+pragma_direct_arg_bad.m:024: argument.
+pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.two'/2 cannot be
+pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
+pragma_direct_arg_bad.m:024: argument.
+pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.string'/1 cannot be
+pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
+pragma_direct_arg_bad.m:024: argument.
+pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.int'/1 cannot be
+pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
+pragma_direct_arg_bad.m:024: argument.
+pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.nonexistent'/1 does not
+pragma_direct_arg_bad.m:024: match any constructor.
+pragma_direct_arg_bad.m:036: In `pragma direct_arg' declaration for
+pragma_direct_arg_bad.m:036: `nonexistent'/0:
+pragma_direct_arg_bad.m:036: error: undefined type `nonexistent'/0.
+pragma_direct_arg_bad.m:036: In pragma:
+pragma_direct_arg_bad.m:036: error: undefined type `nonexistent'/0.
+pragma_direct_arg_bad.m:038: In `pragma direct_arg' declaration for
+pragma_direct_arg_bad.m:038: `maybe.maybe'/1:
+pragma_direct_arg_bad.m:038: error: `pragma direct_arg' declaration must have
+pragma_direct_arg_bad.m:038: the same visibility as the type definition.
+pragma_direct_arg_bad.m:045: In `pragma direct_arg' declaration for
+pragma_direct_arg_bad.m:045: `pragma_direct_arg_bad.example2'/0:
+pragma_direct_arg_bad.m:045: error: `pragma direct_arg' declaration must have
+pragma_direct_arg_bad.m:045: the same visibility as the type definition.
diff --git a/tests/invalid/pragma_direct_arg_bad.m b/tests/invalid/pragma_direct_arg_bad.m
new file mode 100644
index 0000000..4a6e722
--- /dev/null
+++ b/tests/invalid/pragma_direct_arg_bad.m
@@ -0,0 +1,54 @@
+%-----------------------------------------------------------------------------%
+
+:- module pragma_direct_arg_bad.
+:- interface.
+
+:- import_module maybe.
+
+:- type example
+ ---> zero
+ ; two(int, int)
+ ; string(string)
+ ; int(int)
+ ; struct(struct)
+ ; eqv(eqv_struct)
+ ; tuple({int, int}).
+
+:- type example2
+ ---> nil
+ ; struct(struct).
+
+:- type struct ---> struct(int, int).
+:- type eqv_struct == struct.
+
+:- pragma direct_arg(example/0,
+ [
+ zero/0,
+ two/2,
+ string/1,
+ int/1,
+ struct/1,
+ eqv/1,
+ tuple/1,
+ nonexistent/1
+ ]).
+
+:- pragma direct_arg(nonexistent/0, [nonexistent/1]).
+
+:- pragma direct_arg(maybe/1, [yes/1]).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- pragma direct_arg(example2/0, [struct/1]).
+
+:- type example3
+ ---> nil
+ ; struct(struct).
+
+:- pragma direct_arg(example3/0, [struct/1]).
+
+%-----------------------------------------------------------------------------%
+% 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