[m-rev.] for review: enumeration argument packing
Peter Wang
novalazy at gmail.com
Mon Jun 27 15:52:39 AEST 2011
For review by anyone.
Branches: main
Pack consecutive enumeration arguments in discriminated union types into a
single word to reduce cell sizes. Argument packing is only enabled on C
back-ends, and reordering arguments to improve opportunities for packing is
not yet attempted. The RTTI implementations for other back-ends will need to
be updated, but that is best left until after any argument reordering change.
Modules which import abstract enumeration types are notified so by writing
declarations of the form:
:- type foo where type_is_abstract_enum(NumBits).
into the interface file for the module which defines the type.
compiler/prog_data.m:
Add an `arg_width' argument to constructor arguments.
Replace `is_solver_type' by `abstract_type_details', with an extra
option for abstract exported enumeration types.
compiler/handle_options.m:
compiler/options.m:
Add an internal option `--allow-argument-packing'.
compiler/make_hlds_passes.m:
Determine whether and how to pack enumeration arguments, updating the
`arg_width' fields of constructor arguments before constructors are
added to the HLDS.
compiler/mercury_to_mercury.m:
compiler/modules.m:
Write `where type_is_abstract_enum(NumBits)' to interface files
for abstract exported enumeration types.
compiler/prog_io_type_defn.m:
Parse `where type_is_abstract_enum(NumBits)' attributes on type
definitions.
compiler/arg_pack.m:
compiler/backend_libs.m:
Add a new module. This mainly contains a predicate which packs rvals
according to arg_widths, which is used by both LLDS and MLDS back-ends.
compiler/ml_unify_gen.m:
compiler/unify_gen.m:
Take argument packing into account when generating code for
constructions and deconstructions. Only a relatively small part of the
compiler actually needs to understand argument packing. The rest works
at the HLDS level with constructor arguments and variables, or at the
LLDS and MLDS levels with structure fields.
compiler/code_info.m:
compiler/var_locn.m:
Add assign_field_lval_expr_to_var and
var_locn_assign_field_lval_expr_to_var.
Allow more kinds of rvals in assign_cell_arg. I do not know why it was
previously restricted, except that the other kinds of rvals were not
encountered as cell arguments before.
compiler/mlds.m:
We can now rely on the compiler to pack arguments in the
mlds_decl_flags type instead of doing it manually. A slight downside
is that though the type is packed down to a single word cell, it will
still incur a memory allocation per cell. However, I did not notice
any difference in compiler speed.
compiler/rtti.m:
compiler/rtti_out.m:
Add and output a new field for MR_DuFunctorDesc instances, which, if
any arguments are packed, points to an array of MR_DuArgLocn. Each
array element describes the offset in the cell at which the argument's
value is held, and which bits of the word it occupies. In the more
common case where no arguments are packed, the new field is simply
null.
compiler/rtti_to_mlds.m:
Generate the new field to MR_DuFunctorDesc.
compiler/structure_reuse.direct.choose_reuse.m:
For now, prevent structure reuse reusing a dead cell which has a
different constructor to the new cell. The code to determine whether a
dead cell will hold the arguments of a new cell with a different
constructor will need to be updated to account for argument packing.
compiler/type_ctor_info.m:
Bump RTTI version number.
Conform to changes.
compiler/add_type.m:
compiler/check_typeclass.m:
compiler/equiv_type.m:
compiler/equiv_type_hlds.m:
compiler/erl_rtti.m:
compiler/hlds_data.m:
compiler/hlds_out_module.m:
compiler/intermod.m:
compiler/make_tags.m:
compiler/mlds_to_gcc.m:
compiler/opt_debug.m:
compiler/prog_type.m:
compiler/recompilation.check.m:
compiler/recompilation.version.m:
compiler/special_pred.m:
compiler/type_constraints.m:
compiler/type_util.m:
compiler/unify_proc.m:
compiler/xml_documentation.m:
Conform to changes.
Reduce code duplication in classify_type_defn.
compiler/hlds_goal.m:
Clarify a comment.
library/construct.m:
Make `construct' pack arguments when necessary.
Remove an old RTTI version number check as recommended in
mercury_grade.h.
library/store.m:
Deal with packed arguments in this module.
runtime/mercury_grade.h:
Bump binary compatibility version number.
runtime/mercury_type_info.c:
runtime/mercury_type_info.h:
Bump RTTI version number.
Add MR_DuArgLocn structure definition.
Add a macro to unpack an argument as described by MR_DuArgLocn.
Add a function to determine a cell's size, since the number of
arguments is no longer correct.
runtime/mercury_deconstruct.c:
runtime/mercury_deconstruct.h:
runtime/mercury_deconstruct_macros.h:
runtime/mercury_ml_arg_body.h:
runtime/mercury_ml_expand_body.h:
Deal with packed arguments when deconstructing.
Remove an old RTTI version number check as recommended in
mercury_grade.h.
runtime/mercury_deep_copy_body.h:
Deal with packed arguments when copying.
runtime/mercury_table_type_body.h:
Deal with packed arguments in tabling.
runtime/mercury_dotnet.cs.in:
Add DuArgLocn field to DuFunctorDesc. Argument packing is not enabled
for the C# back-end yet so this is unused.
trace/mercury_trace_vars.c:
Deal with packed arguments in MR_select_specified_subterm,
use for the `hold' command.
java/runtime/DuArgLocn.java:
java/runtime/DuFunctorDesc.java:
Add DuArgLocn field to DuFunctorDesc. Argument packing is not enabled
for the Java back-end yet so this is unused.
extras/trailed_update/tr_store.m:
Deal with packed arguments in this module (untested).
extras/trailed_update/samples/interpreter.m:
extras/trailed_update/tr_array.m:
Conform to argument reordering in the array, map and other modules in
previous changes.
tests/hard_coded/Mercury.options:
tests/hard_coded/Mmakefile:
tests/hard_coded/lco_pack_args.exp:
tests/hard_coded/lco_pack_args.m:
tests/hard_coded/pack_args.exp:
tests/hard_coded/pack_args.m:
tests/hard_coded/pack_args_copy.exp:
tests/hard_coded/pack_args_copy.m:
tests/hard_coded/pack_args_intermod1.exp:
tests/hard_coded/pack_args_intermod1.m:
tests/hard_coded/pack_args_intermod2.m:
tests/hard_coded/pack_args_reuse.exp:
tests/hard_coded/pack_args_reuse.m:
tests/hard_coded/store_ref.exp:
tests/hard_coded/store_ref.m:
tests/invalid/Mmakefile:
tests/invalid/where_abstract_enum.err_exp:
tests/invalid/where_abstract_enum.m:
tests/tabling/Mmakefile:
tests/tabling/pack_args_memo.exp:
tests/tabling/pack_args_memo.m:
Add new test cases.
tests/hard_coded/deconstruct_arg.exp:
tests/hard_coded/deconstruct_arg.exp2:
tests/hard_coded/deconstruct_arg.m:
Add constructors with packed arguments to these cases.
tests/invalid/where_direct_arg.err_exp:
Update expected output.
diff --git a/compiler/add_type.m b/compiler/add_type.m
index 6aa632d..0297f70 100644
--- a/compiler/add_type.m
+++ b/compiler/add_type.m
@@ -327,8 +327,18 @@ is_solver_type_is_inconsistent(OldBody, Body) :-
:- pred maybe_get_body_is_solver_type(hlds_type_body::in, is_solver_type::out)
is semidet.
-maybe_get_body_is_solver_type(hlds_abstract_type(IsSolverType), IsSolverType).
maybe_get_body_is_solver_type(hlds_solver_type(_, _), solver_type).
+maybe_get_body_is_solver_type(hlds_abstract_type(Details), IsSolverType) :-
+ (
+ Details = abstract_type_general,
+ IsSolverType = non_solver_type
+ ;
+ Details = abstract_enum_type(_),
+ IsSolverType = non_solver_type
+ ;
+ Details = abstract_solver_type,
+ IsSolverType = solver_type
+ ).
% check_foreign_type_visibility(OldStatus, NewDefnStatus).
%
@@ -627,8 +637,8 @@ convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp,
convert_type_defn(parse_tree_eqv_type(Body), _, _, hlds_eqv_type(Body)).
convert_type_defn(parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp),
_, _, hlds_solver_type(SolverTypeDetails, MaybeUserEqComp)).
-convert_type_defn(parse_tree_abstract_type(IsSolverType), _, _,
- hlds_abstract_type(IsSolverType)).
+convert_type_defn(parse_tree_abstract_type(Details), _, _,
+ hlds_abstract_type(Details)).
convert_type_defn(parse_tree_foreign_type(ForeignType, MaybeUserEqComp,
Assertions), _, _, hlds_foreign_type(Body)) :-
(
diff --git a/compiler/arg_pack.m b/compiler/arg_pack.m
new file mode 100644
index 0000000..0961005
--- /dev/null
+++ b/compiler/arg_pack.m
@@ -0,0 +1,170 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2011 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: arg_pack.m.
+% Main author: wangp.
+%
+% Utilities for argument packing.
+%
+%-----------------------------------------------------------------------------%
+
+:- module backend_libs.arg_pack.
+:- interface.
+
+:- import_module parse_tree.
+:- import_module parse_tree.prog_data.
+
+:- import_module list.
+:- import_module maybe.
+
+%-----------------------------------------------------------------------------%
+
+ % Packs an argument list such that consecutive arguments which should share
+ % the same word are converted to a single argument.
+ %
+ % The predicate ShiftCombine takes an argument `A' and shift count `Shift'
+ % (which may be zero). If it is also given the argument `yes(B)' then it
+ % should produce the combined value `(A << Shift) \/ B'.
+ % Otherwise, it should produce the value `(A << Shift)'.
+ %
+:- pred pack_args(pred(T, int, maybe(T), T, Acc1, Acc1, Acc2, Acc2)::in(
+ pred(in, in, in, out, in, out, in, out) is det), list(arg_width)::in,
+ list(T)::in, list(T)::out, Acc1::in, Acc1::out, Acc2::in, Acc2::out)
+ is det.
+
+ % Return the number of distinct words that would be required to hold the
+ % list of arguments.
+ %
+:- func count_distinct_words(list(arg_width)) = int.
+
+ % Chunk a list of elements into sub-lists according to the word boundaries
+ % implied by the list of argument widths.
+ %
+:- pred chunk_list_by_words(list(arg_width)::in, list(T)::in,
+ list(list(T))::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module require.
+
+%-----------------------------------------------------------------------------%
+
+pack_args(ShiftCombine, ArgWidths, !Args, !Acc1, !Acc2) :-
+ ( list.member(partial_word_first(_), ArgWidths) ->
+ do_pack_args(ShiftCombine, ArgWidths, !Args, !Acc1, !Acc2)
+ ;
+ true
+ ).
+
+:- pred do_pack_args(pred(T, int, maybe(T), T, Acc1, Acc1, Acc2, Acc2)::in(
+ pred(in, in, in, out, in, out, in, out) is det), list(arg_width)::in,
+ list(T)::in, list(T)::out, Acc1::in, Acc1::out, Acc2::in, Acc2::out)
+ is det.
+
+do_pack_args(_, [], [], [], !Acc1, !Acc2).
+do_pack_args(ShiftCombine, [Width | Widths], [Arg0 | Args0], [Arg | Args],
+ !Acc1, !Acc2) :-
+ (
+ Width = full_word,
+ Shift = 0
+ ;
+ Width = partial_word_first(_Mask),
+ Shift = 0
+ ;
+ Width = partial_word_shifted(Shift, _Mask)
+ ),
+ ( belongs_in_same_word(Width, Widths) ->
+ do_pack_args(ShiftCombine, Widths, Args0, Args1, !Acc1, !Acc2),
+ (
+ Args1 = [SecondArg | Args],
+ ShiftCombine(Arg0, Shift, yes(SecondArg), Arg, !Acc1, !Acc2)
+ ;
+ Args1 = [],
+ unexpected($module, $pred, "mismatched lists")
+ )
+ ;
+ ShiftCombine(Arg0, Shift, no, Arg, !Acc1, !Acc2),
+ do_pack_args(ShiftCombine, Widths, Args0, Args, !Acc1, !Acc2)
+ ).
+do_pack_args(_, [], [_ | _], _, !Acc1, !Acc2) :-
+ unexpected($module, $pred, "mismatched lists").
+do_pack_args(_, [_ | _], [], _, !Acc1, !Acc2) :-
+ unexpected($module, $pred, "mismatched lists").
+
+:- pred belongs_in_same_word(arg_width::in, list(arg_width)::in) is semidet.
+
+belongs_in_same_word(Prev, [Next | _]) :-
+ ( Prev = partial_word_first(_)
+ ; Prev = partial_word_shifted(_, _)
+ ),
+ Next = partial_word_shifted(_, _).
+
+%-----------------------------------------------------------------------------%
+
+count_distinct_words([]) = 0.
+count_distinct_words([H | T]) = Words :-
+ (
+ H = full_word,
+ Words = 1 + count_distinct_words(T)
+ ;
+ H = partial_word_first(_),
+ Words = 1 + count_distinct_words(T)
+ ;
+ H = partial_word_shifted(_, _),
+ Words = count_distinct_words(T)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+chunk_list_by_words([], [], []).
+chunk_list_by_words([W | Ws], [X | Xs], Xss) :-
+ (
+ W = full_word,
+ chunk_list_by_words(Ws, Xs, Xss0),
+ Xss = [[X] | Xss0]
+ ;
+ W = partial_word_first(_),
+ split_at_next_word(Ws, WsTail, Xs, XsHead, XsTail),
+ chunk_list_by_words(WsTail, XsTail, Xss0),
+ Xss = [[X | XsHead] | Xss0]
+ ;
+ W = partial_word_shifted(_, _),
+ unexpected($module, $pred, "partial_word_shifted")
+ ).
+chunk_list_by_words([], [_ | _], _) :-
+ unexpected($module, $pred, "mismatched lists").
+chunk_list_by_words([_ | _], [], []) :-
+ unexpected($module, $pred, "mismatched lists").
+
+:- pred split_at_next_word(list(arg_width)::in, list(arg_width)::out,
+ list(T)::in, list(T)::out, list(T)::out) is det.
+
+split_at_next_word([], [], XsTail, [], XsTail).
+split_at_next_word([W | Ws], WsTail, [X | Xs], XsHead, XsTail) :-
+ (
+ ( W = full_word
+ ; W = partial_word_first(_)
+ ),
+ WsTail = [W | Ws],
+ XsHead = [],
+ XsTail = [X | Xs]
+ ;
+ W = partial_word_shifted(_, _),
+ split_at_next_word(Ws, WsTail, Xs, XsHead0, XsTail),
+ XsHead = [X | XsHead0]
+ ).
+split_at_next_word([_ | _], _, [], _, _) :-
+ unexpected($module, $pred, "mismatched lists").
+
+%-----------------------------------------------------------------------------%
+:- end_module backend_libs.arg_pack.
+%-----------------------------------------------------------------------------%
diff --git a/compiler/backend_libs.m b/compiler/backend_libs.m
index 8162532..7edcc6a 100644
--- a/compiler/backend_libs.m
+++ b/compiler/backend_libs.m
@@ -15,6 +15,7 @@
:- interface.
% modules that provide functionality used by several different back-ends
+:- include_module arg_pack.
:- include_module base_typeclass_info.
:- include_module builtin_ops.
:- include_module bytecode_data.
diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m
index 0026424..ea88729 100644
--- a/compiler/check_typeclass.m
+++ b/compiler/check_typeclass.m
@@ -1618,7 +1618,7 @@ check_ctor_constraints(TypeCtor - TypeDefn, !ModuleInfo, !Specs) :-
check_ctor_type_ambiguities(TypeCtor, TypeDefn, Ctor, !ModuleInfo, !Specs) :-
Ctor = ctor(ExistQVars, Constraints, _, CtorArgs, _),
- ArgTypes = list.map(func(ctor_arg(_, T, _)) = T, CtorArgs),
+ ArgTypes = list.map(func(ctor_arg(_, T, _, _)) = T, CtorArgs),
type_vars_list(ArgTypes, ArgTVars),
list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)),
ArgTVars, ExistQArgTVars),
diff --git a/compiler/code_info.m b/compiler/code_info.m
index 9351292..c4eb066 100644
--- a/compiler/code_info.m
+++ b/compiler/code_info.m
@@ -3692,11 +3692,16 @@ should_add_region_ops(CodeInfo, _GoalInfo) = AddRegionOps :-
:- pred assign_expr_to_var(prog_var::in, rval::in, llds_code::out,
code_info::in, code_info::out) is det.
- % assign_cell_to_var(Var, ReserveWordAtStart, Ptag, MaybeRvals, MaybeSize,
- % FieldAddrs, TypeMsg, MayUseAtomic, Where, Code, !CI).
+:- pred assign_field_lval_expr_to_var(prog_var::in, lval::in, rval::in,
+ llds_code::out, code_info::in, code_info::out) is det.
+
+ % assign_cell_to_var(Var, ReserveWordAtStart, Ptag, MaybeRvals,
+ % AllFilled, MaybeSize, FieldAddrs, TypeMsg, MayUseAtomic, Where,
+ % Code, !CI).
%
:- pred assign_cell_to_var(prog_var::in, bool::in, tag::in,
- list(maybe(rval))::in, how_to_construct::in, maybe(term_size_value)::in,
+ list(maybe(rval))::in, bool::in, how_to_construct::in,
+ maybe(term_size_value)::in,
list(int)::in, maybe(alloc_site_id)::in, may_use_atomic_alloc::in,
llds_code::out, code_info::in, code_info::out) is det.
@@ -3840,17 +3845,29 @@ assign_expr_to_var(Var, Rval, Code, !CI) :-
),
set_var_locn_info(VarLocnInfo, !CI).
-assign_cell_to_var(Var, ReserveWordAtStart, Ptag, MaybeRvals, HowToConstruct,
- MaybeSize, FieldAddrs, MaybeAllocId, MayUseAtomic, Code, !CI) :-
+assign_field_lval_expr_to_var(Var, FieldLval, Rval, Code, !CI) :-
+ get_var_locn_info(!.CI, VarLocnInfo0),
+ Lvals = lvals_in_rval(Rval),
+ ( Lvals = [FieldLval] ->
+ var_locn_assign_field_lval_expr_to_var(Var, FieldLval, Rval, Code,
+ VarLocnInfo0, VarLocnInfo)
+ ;
+ unexpected($module, $pred, "rval contains unexpected lval")
+ ),
+ set_var_locn_info(VarLocnInfo, !CI).
+
+assign_cell_to_var(Var, ReserveWordAtStart, Ptag, MaybeRvals, AllFilled,
+ HowToConstruct, MaybeSize, FieldAddrs, MaybeAllocId, MayUseAtomic,
+ Code, !CI) :-
get_next_label(Label, !CI),
get_var_locn_info(!.CI, VarLocnInfo0),
get_static_cell_info(!.CI, StaticCellInfo0),
get_module_info(!.CI, ModuleInfo),
get_exprn_opts(!.CI, ExprnOpts),
var_locn_assign_cell_to_var(ModuleInfo, ExprnOpts, Var, ReserveWordAtStart,
- Ptag, MaybeRvals, HowToConstruct, MaybeSize, FieldAddrs, MaybeAllocId,
- MayUseAtomic, Label, Code, StaticCellInfo0, StaticCellInfo,
- VarLocnInfo0, VarLocnInfo),
+ Ptag, MaybeRvals, AllFilled, HowToConstruct, MaybeSize, FieldAddrs,
+ MaybeAllocId, MayUseAtomic, Label, Code,
+ StaticCellInfo0, StaticCellInfo, VarLocnInfo0, VarLocnInfo),
set_static_cell_info(StaticCellInfo, !CI),
set_var_locn_info(VarLocnInfo, !CI).
diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m
index a4802bf..20800aa 100644
--- a/compiler/equiv_type.m
+++ b/compiler/equiv_type.m
@@ -1047,13 +1047,27 @@ replace_in_ctor_arg_list(Location,
replace_in_ctor_arg_list_2(_Location, _EqvMap, _Seen, [], [],
!Circ, !VarSet, !EquivTypeInfo, !UsedModules).
replace_in_ctor_arg_list_2(Location, EqvMap, Seen,
- [ctor_arg(N, T0, C) | As0], [ctor_arg(N, T, C) | As],
+ [Arg0 | Args0], [Arg | Args],
!Circ, !VarSet, !EquivTypeInfo, !UsedModules) :-
- replace_in_type_location_2(Location, EqvMap, Seen, T0, T, _, ContainsCirc,
- !VarSet, !EquivTypeInfo, !UsedModules),
+ Arg0 = ctor_arg(Name, Type0, Width, Context),
+ replace_in_type_location_2(Location, EqvMap, Seen, Type0, Type, _,
+ ContainsCirc, !VarSet, !EquivTypeInfo, !UsedModules),
+ (
+ Width = full_word
+ ;
+ ( Width = partial_word_first(_)
+ ; Width = partial_word_shifted(_, _)
+ ),
+ ( Type = Type0 ->
+ true
+ ;
+ unexpected($module, $pred, "changed type of packed argument")
+ )
+ ),
+ Arg = ctor_arg(Name, Type, Width, Context),
!:Circ = !.Circ `or` ContainsCirc,
- replace_in_ctor_arg_list_2(Location, EqvMap,
- Seen, As0, As, !Circ, !VarSet, !EquivTypeInfo, !UsedModules).
+ replace_in_ctor_arg_list_2(Location, EqvMap, Seen, Args0, Args,
+ !Circ, !VarSet, !EquivTypeInfo, !UsedModules).
%-----------------------------------------------------------------------------%
diff --git a/compiler/equiv_type_hlds.m b/compiler/equiv_type_hlds.m
index 4a798d1..6842af7 100644
--- a/compiler/equiv_type_hlds.m
+++ b/compiler/equiv_type_hlds.m
@@ -326,9 +326,23 @@ replace_in_cons_defn(EqvMap, ConsDefn0, ConsDefn) :-
tvarset::in, tvarset::out) is det.
replace_in_constructor_arg(EqvMap, CtorArg0, CtorArg, !TVarSet) :-
- CtorArg0 = ctor_arg(MaybeFieldName, Type0, Context),
- replace_in_type(EqvMap, Type0, Type, _Changed, !TVarSet, no, _),
- CtorArg = ctor_arg(MaybeFieldName, Type, Context).
+ CtorArg0 = ctor_arg(MaybeFieldName, Type0, Width, Context),
+ replace_in_type(EqvMap, Type0, Type, Changed, !TVarSet, no, _),
+ (
+ Changed = yes,
+ (
+ Width = full_word,
+ CtorArg = ctor_arg(MaybeFieldName, Type, Width, Context)
+ ;
+ ( Width = partial_word_first(_)
+ ; Width = partial_word_shifted(_, _)
+ ),
+ unexpected($module, $pred, "changed type of packed argument")
+ )
+ ;
+ Changed = no,
+ CtorArg = CtorArg0
+ ).
%-----------------------------------------------------------------------------%
diff --git a/compiler/erl_rtti.m b/compiler/erl_rtti.m
index 39124af..58e3d46 100644
--- a/compiler/erl_rtti.m
+++ b/compiler/erl_rtti.m
@@ -156,7 +156,7 @@ erlang_type_ctor_details_2(CtorDetails) = Details :-
Ordinal = 0,
FunctorNum = 0,
ArgTypeInfo = convert_to_rtti_maybe_pseudo_type_info_or_self(TypeInfo),
- ArgInfos = [du_arg_info(ArgName, ArgTypeInfo)],
+ ArgInfos = [du_arg_info(ArgName, ArgTypeInfo, full_word)],
DUFunctor = erlang_du_functor(Name, OrigArity, Ordinal, FunctorNum,
erlang_atom_raw(Name), ArgInfos, no),
Details = erlang_du([DUFunctor])
diff --git a/compiler/handle_options.m b/compiler/handle_options.m
index 8ddf88c..1f44a24 100644
--- a/compiler/handle_options.m
+++ b/compiler/handle_options.m
@@ -1270,7 +1270,7 @@ convert_options_to_globals(OptionTable0, Target, GC_Method, TagsMethod0,
% Currently, multi-arm switches have been tested only for the LLDS
% backend (which always generates C) and for the MLDS backend when
- % it is generating C or Java code.
+ % it is generating C, C# or Java code.
(
( Target = target_c
; Target = target_csharp
@@ -1285,6 +1285,21 @@ convert_options_to_globals(OptionTable0, Target, GC_Method, TagsMethod0,
globals.set_option(allow_multi_arm_switches, bool(no), !Globals)
),
+ % Argument packing only works on C back-ends. The RTTI code for other
+ % back-ends will need to be updated to cope with packed arguments.
+ (
+ Target = target_c
+ ;
+ ( Target = target_csharp
+ ; Target = target_java
+ ; Target = target_x86_64
+ ; Target = target_asm
+ ; Target = target_il
+ ; Target = target_erlang
+ ),
+ globals.set_option(allow_argument_packing, bool(no), !Globals)
+ ),
+
option_implies(target_debug, strip, bool(no), !Globals),
% Profile for implicit parallelism implies a particular coverage
diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m
index c93b806..f1867b6 100644
--- a/compiler/hlds_data.m
+++ b/compiler/hlds_data.m
@@ -241,7 +241,7 @@
; hlds_eqv_type(mer_type)
; hlds_foreign_type(foreign_type_body)
; hlds_solver_type(solver_type_details, maybe(unify_compare))
- ; hlds_abstract_type(is_solver_type).
+ ; hlds_abstract_type(abstract_type_details).
:- type maybe_cheaper_tag_test
---> no_cheaper_tag_test
diff --git a/compiler/hlds_goal.m b/compiler/hlds_goal.m
index 106e4e8..a1eeb70 100644
--- a/compiler/hlds_goal.m
+++ b/compiler/hlds_goal.m
@@ -740,7 +740,8 @@
% This matters because a module has lots of construct unifications.
:- type construct_sub_info
---> construct_sub_info(
- take_address_fields :: maybe(list(int)),
+ % The argument numbers to take the address of.
+ take_address_args :: maybe(list(int)),
% The value `yes' tells the code generator to reserve an extra
% slot, at offset -1, to hold an integer giving the size of
diff --git a/compiler/hlds_out_module.m b/compiler/hlds_out_module.m
index f3bfa12..32e4d86 100644
--- a/compiler/hlds_out_module.m
+++ b/compiler/hlds_out_module.m
@@ -213,7 +213,7 @@ write_types_2(Info, Indent, [TypeCtor - TypeDefn | Types], !IO) :-
write_indent(Indent, !IO),
(
( TypeBody = hlds_solver_type(_, _)
- ; TypeBody = hlds_abstract_type(solver_type)
+ ; TypeBody = hlds_abstract_type(abstract_solver_type)
)
->
io.write_string(":- solver type ", !IO)
diff --git a/compiler/intermod.m b/compiler/intermod.m
index 567b4d2..3c15363 100644
--- a/compiler/intermod.m
+++ b/compiler/intermod.m
@@ -1371,11 +1371,11 @@ write_type(OutInfo, TypeCtor - TypeDefn, !IO) :-
Body = hlds_eqv_type(EqvType),
TypeBody = parse_tree_eqv_type(EqvType)
;
- Body = hlds_abstract_type(IsSolverType),
- TypeBody = parse_tree_abstract_type(IsSolverType)
+ Body = hlds_abstract_type(Details),
+ TypeBody = parse_tree_abstract_type(Details)
;
Body = hlds_foreign_type(_),
- TypeBody = parse_tree_abstract_type(non_solver_type)
+ TypeBody = parse_tree_abstract_type(abstract_type_general)
;
Body = hlds_solver_type(SolverTypeDetails, MaybeUserEqComp),
TypeBody = parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp)
diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m
index 7eaeb6d..ac8ae62 100644
--- a/compiler/make_hlds_passes.m
+++ b/compiler/make_hlds_passes.m
@@ -97,6 +97,7 @@
:- import_module backend_libs.
:- import_module backend_libs.foreign.
:- import_module check_hlds.clause_to_proc.
+:- import_module check_hlds.type_util.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_out.
@@ -126,6 +127,7 @@
:- import_module parse_tree.prog_util.
:- import_module recompilation.
+:- import_module int.
:- import_module map.
:- import_module pair.
:- import_module require.
@@ -166,15 +168,30 @@ do_parse_tree_to_hlds(Globals, DumpBaseFileName, unit_module(Name, Items),
),
!:Specs = Pass2Specs ++ !.Specs,
- % Add constructors and special preds to the HLDS. This must be done
- % after adding all type and `:- pragma foreign_type' declarations.
- % If there were errors in foreign type type declarations, doing this
- % may cause a compiler abort.
(
InvalidTypes1 = no,
- module_info_get_type_table(!.ModuleInfo, TypeTable),
- foldl3_over_type_ctor_defns(process_type_defn, TypeTable,
- no, InvalidTypes2, !ModuleInfo, !Specs)
+ some [!TypeTable] (
+ % Figure out how arguments should be packed into fields,
+ % before constructors are added to the HLDS.
+ globals.lookup_bool_option(Globals, allow_argument_packing,
+ ArgPacking),
+ module_info_get_type_table(!.ModuleInfo, !:TypeTable),
+ (
+ ArgPacking = yes,
+ foldl_over_type_ctor_defns(pack_du_type_args(!.ModuleInfo),
+ !.TypeTable, !TypeTable),
+ module_info_set_type_table(!.TypeTable, !ModuleInfo)
+ ;
+ ArgPacking = no
+ ),
+
+ % Add constructors and special preds to the HLDS. This must be done
+ % after adding all type and `:- pragma foreign_type' declarations.
+ % If there were errors in foreign type type declarations, doing this
+ % may cause a compiler abort.
+ foldl3_over_type_ctor_defns(process_type_defn, !.TypeTable,
+ no, InvalidTypes2, !ModuleInfo, !Specs)
+ )
;
InvalidTypes1 = yes,
InvalidTypes2 = yes
@@ -214,12 +231,161 @@ do_parse_tree_to_hlds(Globals, DumpBaseFileName, unit_module(Name, Items),
mq_info_get_mode_error_flag(MQInfo, InvalidModes1),
InvalidModes = InvalidModes0 `or` InvalidModes1.
+%-----------------------------------------------------------------------------%
+
+:- pred pack_du_type_args(module_info::in, type_ctor::in, hlds_type_defn::in,
+ type_table::in, type_table::out) is det.
+
+pack_du_type_args(ModuleInfo, TypeCtor, TypeDefn, !TypeTable) :-
+ get_type_defn_body(TypeDefn, Body0),
+ (
+ Body0 = hlds_du_type(Ctors0, ConsTagValues, MaybeCheaperTagTest,
+ DuKind, MaybeUserEqComp, DirectArgFunctors, ReservedTag,
+ ReservedAddr, MaybeForeign),
+ list.map(decide_du_ctor_packing(ModuleInfo), Ctors0, Ctors),
+ Body = hlds_du_type(Ctors, ConsTagValues, MaybeCheaperTagTest,
+ DuKind, MaybeUserEqComp, DirectArgFunctors, ReservedTag,
+ ReservedAddr, MaybeForeign),
+ set_type_defn_body(Body, TypeDefn, PackedTypeDefn),
+ replace_type_ctor_defn(TypeCtor, PackedTypeDefn, !TypeTable)
+ ;
+ ( Body0 = hlds_eqv_type(_)
+ ; Body0 = hlds_foreign_type(_)
+ ; Body0 = hlds_solver_type(_, _)
+ ; Body0 = hlds_abstract_type(_)
+ )
+ % Leave these types alone.
+ ).
+
+:- pred decide_du_ctor_packing(module_info::in,
+ constructor::in, constructor::out) is det.
+
+decide_du_ctor_packing(ModuleInfo, Ctor0, Ctor) :-
+ Ctor0 = ctor(ExistTVars, Constraints, Name, Args0, Context),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_int_option(Globals, bits_per_word, TargetWordBits),
+ pack_du_ctor_args(ModuleInfo, TargetWordBits, 0, Args0, Args, _),
+ list.length(Args0, UnpackedLength),
+ count_words(Args, 0, PackedLength),
+ (
+ (
+ PackedLength = UnpackedLength
+ ;
+ % Boehm GC will round up allocations (at least) to the next even
+ % number of words. There is no point saving a single word if that
+ % word will be allocated anyway.
+ int.even(UnpackedLength),
+ PackedLength = UnpackedLength - 1
+ )
+ ->
+ Ctor = Ctor0
+ ;
+ PackedLength < UnpackedLength
+ ->
+ Ctor = ctor(ExistTVars, Constraints, Name, Args, Context)
+ ;
+ unexpected($module, $pred, "packed length exceeds unpacked length")
+ ).
+
+:- pred pack_du_ctor_args(module_info::in, int::in, int::in,
+ list(constructor_arg)::in, list(constructor_arg)::out,
+ arg_width::out) is det.
+
+pack_du_ctor_args(_ModuleInfo, _TargetWordBits, _Shift, [], [],
+ full_word).
+pack_du_ctor_args(ModuleInfo, TargetWordBits, Shift,
+ [Arg0 | Args0], [Arg | Args], ArgWidth) :-
+ Arg0 = ctor_arg(Name, Type, _, Context),
+ ( type_is_enum_bits(ModuleInfo, Type, NumBits) ->
+ Mask = int.pow(2, NumBits) - 1,
+ % Try to place the argument in the current word, otherwise move on to
+ % the next word.
+ ( Shift + NumBits > TargetWordBits ->
+ ArgWidth0 = partial_word_first(Mask),
+ NextShift = NumBits
+ ; Shift = 0 ->
+ ArgWidth0 = partial_word_first(Mask),
+ NextShift = NumBits
+ ;
+ ArgWidth0 = partial_word_shifted(Shift, Mask),
+ NextShift = Shift + NumBits
+ ),
+ pack_du_ctor_args(ModuleInfo, TargetWordBits, NextShift, Args0, Args,
+ NextArgWidth),
+ % If this argument starts a word but the next argument is not packed
+ % with it, then this argument is not packed.
+ (
+ ArgWidth0 = partial_word_first(_),
+ ( NextArgWidth = full_word
+ ; NextArgWidth = partial_word_first(_)
+ )
+ ->
+ ArgWidth = full_word
+ ;
+ ArgWidth = ArgWidth0
+ ),
+ Arg = ctor_arg(Name, Type, ArgWidth, Context)
+ ;
+ % This argument occupies a full word.
+ Arg = Arg0,
+ ArgWidth = full_word,
+ NextShift = 0,
+ pack_du_ctor_args(ModuleInfo, TargetWordBits, NextShift, Args0, Args,
+ _)
+ ).
+
+:- pred type_is_enum_bits(module_info::in, mer_type::in, int::out) is semidet.
+
+type_is_enum_bits(ModuleInfo, Type, NumBits) :-
+ type_to_type_defn_body(ModuleInfo, Type, TypeBody),
+ TypeCategory = classify_type_defn_body(TypeBody),
+ (
+ TypeCategory = ctor_cat_enum(cat_enum_mercury),
+ NumBits = cons_tags_bits(TypeBody ^ du_type_cons_tag_values)
+ ;
+ TypeCategory = ctor_cat_user(cat_user_general),
+ TypeBody = hlds_abstract_type(abstract_enum_type(NumBits))
+ ).
+
+:- func cons_tags_bits(cons_tag_values) = int.
+
+cons_tags_bits(ConsTagValues) = NumBits :-
+ map.foldl_values(max_int_tag, ConsTagValues, 0, MaxFunctor),
+ int.log2(MaxFunctor + 1, NumBits).
+
+:- pred max_int_tag(cons_tag::in, int::in, int::out) is det.
+
+max_int_tag(ConsTag, !Max) :-
+ ( ConsTag = int_tag(Int) ->
+ int.max(Int, !Max)
+ ;
+ unexpected($module, $pred, "non-integer value for enumeration")
+ ).
+
+:- pred count_words(list(constructor_arg)::in, int::in, int::out) is det.
+
+count_words([], !Count).
+count_words([Arg | Args], !Count) :-
+ ArgWidth = Arg ^ arg_width,
+ (
+ ArgWidth = full_word,
+ !:Count = !.Count + 1
+ ;
+ ArgWidth = partial_word_first(_),
+ !:Count = !.Count + 1
+ ;
+ ArgWidth = partial_word_shifted(_Shift, _Mask)
+ ),
+ count_words(Args, !Count).
+
+%-----------------------------------------------------------------------------%
+
:- pred add_builtin_type_ctor_special_preds(type_ctor::in,
module_info::in, module_info::out) is det.
add_builtin_type_ctor_special_preds(TypeCtor, !ModuleInfo) :-
varset.init(TVarSet),
- Body = hlds_abstract_type(non_solver_type),
+ Body = hlds_abstract_type(abstract_type_general),
term.context_init(Context),
Status = status_local,
construct_type(TypeCtor, [], Type),
diff --git a/compiler/make_tags.m b/compiler/make_tags.m
index fc8661a..2c05d78 100644
--- a/compiler/make_tags.m
+++ b/compiler/make_tags.m
@@ -565,7 +565,7 @@ is_direct_arg_ctor(TypeTable, TypeCtorModule, TypeStatus,
ExistConstraints = [],
ConsArgs = [ConsArg],
Arity = 1,
- ConsArg = ctor_arg(_MaybeFieldName, ArgType, _ArgContext),
+ ConsArg = ctor_arg(_MaybeFieldName, ArgType, _ArgWidth, _ArgContext),
type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeCtorArgTypes),
(
diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m
index 7b67901..92731eb 100644
--- a/compiler/mercury_to_mercury.m
+++ b/compiler/mercury_to_mercury.m
@@ -1911,12 +1911,29 @@ mercury_format_mode(user_defined_mode(Name, Args), InstInfo, !U) :-
mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context,
!IO) :-
(
- TypeDefn = parse_tree_abstract_type(IsSolverType),
+ TypeDefn = parse_tree_abstract_type(Details),
+ (
+ ( Details = abstract_type_general
+ ; Details = abstract_enum_type(_)
+ ),
+ IsSolverType = non_solver_type
+ ;
+ Details = abstract_solver_type,
+ IsSolverType = solver_type
+ ),
mercury_output_begin_type_decl(IsSolverType, !IO),
Args = list.map((func(V) = term.variable(V, Context)), TParams),
construct_qualified_term(Name, Args, Context, TypeTerm),
mercury_output_term_nq(TVarSet, no, next_to_graphic_token, TypeTerm,
!IO),
+ (
+ Details = abstract_enum_type(NumBits),
+ mercury_output_where_abstract_enum_type(NumBits, !IO)
+ ;
+ Details = abstract_type_general
+ ;
+ Details = abstract_solver_type
+ ),
io.write_string(".\n", !IO)
;
TypeDefn = parse_tree_eqv_type(Body),
@@ -2141,6 +2158,15 @@ mercury_output_solver_type_details(Info, TVarSet, Details, !IO) :-
io.write_string("\n\t\t]", !IO)
).
+:- pred mercury_output_where_abstract_enum_type(int::in, io::di, io::uo)
+ is det.
+
+mercury_output_where_abstract_enum_type(NumBits, !IO) :-
+ io.write_string("\n\twhere\t", !IO),
+ io.write_string("type_is_abstract_enum(", !IO),
+ io.write_int(NumBits, !IO),
+ io.write_string(")", !IO).
+
:- pred mercury_output_ctors(list(constructor)::in, tvarset::in,
io::di, io::uo) is det.
@@ -2220,9 +2246,9 @@ mercury_output_ctor(Ctor, VarSet, !IO) :-
:- pred mercury_output_ctor_arg(tvarset::in, constructor_arg::in,
io::di, io::uo) is det.
-mercury_output_ctor_arg(Varset, ctor_arg(N, T, _), !IO) :-
- mercury_output_ctor_arg_name_prefix(N, !IO),
- mercury_output_type(Varset, no, T, !IO).
+mercury_output_ctor_arg(Varset, ctor_arg(Name, Type, _Width, _Context), !IO) :-
+ mercury_output_ctor_arg_name_prefix(Name, !IO),
+ mercury_output_type(Varset, no, Type, !IO).
mercury_output_remaining_ctor_args(_Varset, [], !IO).
mercury_output_remaining_ctor_args(Varset, [A | As], !IO) :-
diff --git a/compiler/ml_unify_gen.m b/compiler/ml_unify_gen.m
index 9e7d0c1..ea15835 100644
--- a/compiler/ml_unify_gen.m
+++ b/compiler/ml_unify_gen.m
@@ -119,6 +119,7 @@
:- implementation.
+:- import_module backend_libs.arg_pack.
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.rtti.
:- import_module backend_libs.type_class_info.
@@ -147,6 +148,7 @@
:- import_module require.
:- import_module set.
:- import_module term.
+:- import_module unit.
:- import_module varset.
:- inst no_or_direct_arg_tag
@@ -225,8 +227,8 @@ ml_gen_unification(Unification, CodeModel, Context, Statements, !Info) :-
expect(unify(MaybeSizeProfInfo, no), $module, $pred,
"term size profiling not yet supported")
),
- ml_gen_construct(Var, ConsId, Args, ArgModes, TakeAddr, HowToConstruct,
- Context, Statements, !Info)
+ ml_gen_construct(Var, ConsId, Args, ArgModes, TakeAddr,
+ HowToConstruct, Context, Statements, !Info)
;
Unification = deconstruct(Var, ConsId, Args, ArgModes, CanFail,
CanCGC),
@@ -626,8 +628,8 @@ ml_gen_compound(ConsId, Ptag, MaybeStag, UsesBaseClass, Var, ArgVars, ArgModes,
HowToConstruct, Context, Statements, !Info).
ml_gen_new_object(MaybeConsId, MaybeCtorName, Tag, ExplicitSecTag, Var,
- ExtraRvals, ExtraTypes, ArgVars, ArgModes, TakeAddr, HowToConstruct,
- Context, Statements, !Info) :-
+ ExtraRvals, ExtraTypes, ArgVars, ArgModes, TakeAddr,
+ HowToConstruct, Context, Statements, !Info) :-
% Determine the variable's type and lval, the tag to use, and the types
% of the argument vars.
ml_variable_type(!.Info, Var, VarType),
@@ -679,8 +681,8 @@ ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName, MaybeTag, ExplicitSecT
ml_gen_var_list(!.Info, ArgVars, ArgLvals),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
get_maybe_cons_id_arg_types(ModuleInfo, MaybeConsId, ArgTypes, VarType,
- ConsArgTypes),
- FirstOffset = length(ExtraRvals),
+ ConsArgTypes, ConsArgWidths),
+ NumExtraRvals = length(ExtraRvals),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, use_atomic_cells, UseAtomicCells),
(
@@ -692,16 +694,22 @@ ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName, MaybeTag, ExplicitSecT
),
ml_gen_info_get_high_level_data(!.Info, HighLevelData),
ml_gen_cons_args(ArgVars, ArgLvals, ArgTypes, ConsArgTypes, ArgModes,
- FirstOffset, 1, TakeAddr, ModuleInfo, HighLevelData,
+ NumExtraRvals, ConsArgWidths, TakeAddr, ModuleInfo, HighLevelData,
ArgRvals0, MLDS_ArgTypes0, TakeAddrInfos, MayUseAtomic0, MayUseAtomic),
- % Insert the extra rvals at the start.
- ArgRvals = ExtraRvals ++ ArgRvals0,
- MLDS_ArgTypes = ExtraTypes ++ MLDS_ArgTypes0,
+ % Pack arguments into fields.
+ assoc_list.from_corresponding_lists(ArgRvals0, MLDS_ArgTypes0, ArgsTypes0),
+ pack_args(ml_shift_combine_rval_type, ConsArgWidths,
+ ArgsTypes0, ArgsTypes1, unit, _, unit, _),
+ assoc_list.keys_and_values(ArgsTypes1, ArgRvals1, MLDS_ArgTypes1),
+
+ % Add the extra rvals to the start.
+ ArgRvals = ExtraRvals ++ ArgRvals1,
+ MLDS_ArgTypes = ExtraTypes ++ MLDS_ArgTypes1,
% Compute the number of words to allocate.
- list.length(ArgRvals, NumArgs),
- SizeInWordsRval = ml_const(mlconst_int(NumArgs)),
+ list.length(ArgRvals, Size),
+ SizeInWordsRval = ml_const(mlconst_int(Size)),
% Generate an allocation site id.
globals.lookup_bool_option(Globals, profile_memory, ProfileMemory),
@@ -711,7 +719,7 @@ ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName, MaybeTag, ExplicitSecT
ml_gen_info_get_proc_id(!.Info, ProcId),
ml_gen_info_get_global_data(!.Info, GlobalData0),
ml_gen_proc_label(ModuleInfo, PredId, ProcId, ProcLabel, _Module),
- ml_gen_alloc_site(ProcLabel, MaybeConsId, NumArgs, Context, AllocId,
+ ml_gen_alloc_site(ProcLabel, MaybeConsId, Size, Context, AllocId,
GlobalData0, GlobalData),
ml_gen_info_set_global_data(GlobalData, !Info),
MaybeAllocId = yes(AllocId)
@@ -733,6 +741,8 @@ ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName, MaybeTag, ExplicitSecT
MaybeTag, Context, !.Info, TakeAddrStatements),
Statements = [Statement | TakeAddrStatements].
+%-----------------------------------------------------------------------------%
+
:- pred ml_gen_new_object_statically(maybe(cons_id)::in, maybe(ctor_name)::in,
maybe(mlds_tag)::in,
prog_var::in, mlds_lval::in, mer_type::in, mlds_type::in,
@@ -748,7 +758,7 @@ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
ml_gen_info_get_module_info(!.Info, ModuleInfo),
ml_gen_info_get_high_level_data(!.Info, HighLevelData),
get_maybe_cons_id_arg_types(ModuleInfo, MaybeConsId, ArgTypes, VarType,
- ConsArgTypes),
+ ConsArgTypes, ConsArgWidths),
some [!GlobalData] (
% Generate rvals for the arguments.
@@ -764,8 +774,7 @@ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
ml_gen_box_extra_const_rval_list(ModuleInfo, Context, ExtraTypes,
ExtraRvals, ExtraArgRvals, !GlobalData),
ml_gen_box_const_rval_list(ModuleInfo, Context, ArgGroundTerms,
- ArgRvals1, !GlobalData),
- ArgRvals = ExtraArgRvals ++ ArgRvals1
+ ArgRvals1, !GlobalData)
;
HighLevelData = yes,
list.map(ml_gen_info_lookup_const_var_rval(!.Info), ArgVars,
@@ -777,7 +786,7 @@ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
% For --high-level-data, the ExtraRvals should already have
% the right type, so we don't need to worry about boxing
% or unboxing them.
- ArgRvals = ExtraRvals ++ ArgRvals1
+ ExtraArgRvals = ExtraRvals
),
% Generate a static constant for this term.
@@ -795,7 +804,10 @@ ml_gen_new_object_statically(MaybeConsId, MaybeCtorName, MaybeTag,
% initializer should be wrapped in `init_struct([init_obj(X)])'
% rather than just `init_obj(X)' -- the fact that we don't leads to
% some warnings from GNU C about missing braces in initializers.
- ArgInits = list.map(func(X) = init_obj(X), ArgRvals),
+ pack_args(ml_shift_combine_rval, ConsArgWidths, ArgRvals1, ArgRvals,
+ unit, _, unit, _),
+ AllArgRvals = ExtraArgRvals ++ ArgRvals,
+ ArgInits = list.map(func(X) = init_obj(X), AllArgRvals),
( ConstType = mlds_array_type(_) ->
Initializer = init_array(ArgInits)
;
@@ -843,7 +855,9 @@ ml_gen_new_object_reuse_cell(MaybeConsId, MaybeCtorName, Tag, MaybeTag,
ExplicitSecTag, Var, VarLval, VarType, MLDS_Type,
ExtraRvals, ExtraTypes, ArgVars, ArgTypes, ArgModes, TakeAddr,
CellToReuse, Context, Statements, !Info) :-
- CellToReuse = cell_to_reuse(ReuseVar, ReuseConsIds, _),
+ % NOTE: if it is ever used, NeedsUpdates needs to be modified to take into
+ % account argument packing, as in unify_gen.m.
+ CellToReuse = cell_to_reuse(ReuseVar, ReuseConsIds, _NeedsUpdates),
(
MaybeConsId = yes(ConsId0),
ConsId = ConsId0
@@ -943,8 +957,10 @@ ml_gen_field_take_address_assigns([TakeAddrInfo | TakeAddrInfos],
% in which a predicate fills in a field of such a type after a *recursive*
% call, since recursive calls tend to generate values of recursive (i.e.
% discriminated union) types. -zs
+ Offset = offset(OffsetInt),
SourceRval = ml_mem_addr(ml_field(MaybeTag, ml_lval(CellLval),
- ml_field_offset(ml_const(mlconst_int(Offset))), FieldType, CellType)),
+ ml_field_offset(ml_const(mlconst_int(OffsetInt))),
+ FieldType, CellType)),
ml_gen_var(Info, AddrVar, AddrLval),
CastSourceRval = ml_unop(cast(mlds_ptr_type(ConsArgType)), SourceRval),
Assign = ml_gen_assign(AddrLval, CastSourceRval, Context)
@@ -1074,25 +1090,28 @@ ml_type_as_field(ModuleInfo, HighLevelData, FieldType, BoxedFieldType) :-
).
:- pred get_maybe_cons_id_arg_types(module_info::in, maybe(cons_id)::in,
- list(mer_type)::in, mer_type::in, list(mer_type)::out)
- is det.
+ list(mer_type)::in, mer_type::in, list(mer_type)::out,
+ list(arg_width)::out) is det.
get_maybe_cons_id_arg_types(ModuleInfo, MaybeConsId, ArgTypes, Type,
- ConsArgTypes) :-
+ ConsArgTypes, ConsArgWidths) :-
(
MaybeConsId = yes(ConsId),
- ConsArgTypes =
- constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type)
+ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type,
+ ConsArgTypes, ConsArgWidths)
;
MaybeConsId = no,
% It's a closure. In this case, the arguments are all boxed.
- ConsArgTypes = ml_make_boxed_types(list.length(ArgTypes))
+ Length = list.length(ArgTypes),
+ ConsArgTypes = ml_make_boxed_types(Length),
+ ConsArgWidths = list.duplicate(Length, full_word)
).
-:- func constructor_arg_types(module_info, cons_id, list(mer_type), mer_type)
- = list(mer_type).
+:- pred constructor_arg_types(module_info::in, cons_id::in, list(mer_type)::in,
+ mer_type::in, list(mer_type)::out, list(arg_width)::out) is det.
-constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :-
+constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type,
+ ConsArgTypes, ConsArgWidths) :-
(
ConsId = cons(_, _, _),
\+ is_introduced_type_info_type(Type)
@@ -1103,7 +1122,11 @@ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :-
type_util.get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
->
ConsArgDefns = ConsDefn ^ cons_args,
- ConsArgTypes0 = list.map(func(C) = C ^ arg_type, ConsArgDefns),
+ list.map2(
+ (pred(C::in, CType::out, CWidth::out) is det :-
+ C = ctor_arg(_, CType, CWidth, _)
+ ),
+ ConsArgDefns, ConsArgTypes0, ConsArgWidths0),
% There may have been additional types inserted to hold the
% type_infos and type_class_infos for existentially quantified
@@ -1111,7 +1134,9 @@ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :-
NumExtraArgs = list.length(ArgTypes) - list.length(ConsArgTypes0),
ExtraArgTypes = list.take_upto(NumExtraArgs, ArgTypes),
- ConsArgTypes = ExtraArgTypes ++ ConsArgTypes0
+ ExtraArgWidths = list.duplicate(NumExtraArgs, full_word),
+ ConsArgTypes = ExtraArgTypes ++ ConsArgTypes0,
+ ConsArgWidths = ExtraArgWidths ++ ConsArgWidths0
;
% If we didn't find a constructor definition, maybe that is because
% this type was a built-in tuple type.
@@ -1122,7 +1147,9 @@ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :-
% here, since all we really care about at this point is whether
% something is a type variable or not, not which type variable it
% is.
- ConsArgTypes = ml_make_boxed_types(list.length(ArgTypes))
+ Length = list.length(ArgTypes),
+ ConsArgTypes = ml_make_boxed_types(Length),
+ ConsArgWidths = list.duplicate(Length, full_word)
;
% Type_util.get_cons_defn shouldn't have failed.
unexpected($module, $pred, "get_cons_defn failed")
@@ -1132,7 +1159,9 @@ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :-
% as can happen e.g. for closures and type_infos, we assume that
% the arguments all have the right type already.
% XXX is this the right thing to do?
- ConsArgTypes = ArgTypes
+ ConsArgTypes = ArgTypes,
+ Length = list.length(ArgTypes),
+ ConsArgWidths = list.duplicate(Length, full_word)
).
:- func ml_gen_mktag(int) = mlds_rval.
@@ -1259,12 +1288,17 @@ ml_cons_name(CompilationTarget, HLDS_ConsId, QualifiedConsId) :-
:- type take_addr_info
---> take_addr_info(
prog_var, % The variable we record the address in.
- int, % The offset of the field
+ field_offset, % The offset of the field. This must take
+ % into account extra arguments and
+ % argument packing.
mlds_type, % The type of the field variable.
mlds_type % The type of the field, possibly
% after boxing.
).
+:- type field_offset
+ ---> offset(int).
+
% Create a list of rvals for the arguments for a construction unification.
% For each argument which is input to the construction unification,
% we produce the corresponding lval, boxed or unboxed if needed,
@@ -1272,16 +1306,16 @@ ml_cons_name(CompilationTarget, HLDS_ConsId, QualifiedConsId) :-
%
:- pred ml_gen_cons_args(list(prog_var)::in, list(mlds_lval)::in,
list(mer_type)::in, list(mer_type)::in, list(uni_mode)::in,
- int::in, int::in, list(int)::in, module_info::in, bool::in,
+ int::in, list(arg_width)::in, list(int)::in, module_info::in, bool::in,
list(mlds_rval)::out, list(mlds_type)::out, list(take_addr_info)::out,
may_use_atomic_alloc::in, may_use_atomic_alloc::out) is det.
-ml_gen_cons_args(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes, FirstOffset,
- FirstArgNum, TakeAddr, ModuleInfo, HighLevelData,
+ml_gen_cons_args(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
+ NumExtraArgs, ConsArgWidths, TakeAddr, ModuleInfo, HighLevelData,
!:Rvals, !:MLDS_Types, !:TakeAddrInfos, !MayUseAtomic) :-
(
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
- FirstOffset, FirstArgNum, TakeAddr, ModuleInfo, HighLevelData,
+ NumExtraArgs, ConsArgWidths, 1, TakeAddr, ModuleInfo, HighLevelData,
!:Rvals, !:MLDS_Types, !:TakeAddrInfos, !MayUseAtomic)
->
true
@@ -1291,15 +1325,18 @@ ml_gen_cons_args(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes, FirstOffset,
:- pred ml_gen_cons_args_2(list(prog_var)::in, list(mlds_lval)::in,
list(mer_type)::in, list(mer_type)::in, list(uni_mode)::in,
- int::in, int::in, list(int)::in, module_info::in, bool::in,
+ int::in, list(arg_width)::in, int::in, list(int)::in,
+ module_info::in, bool::in,
list(mlds_rval)::out, list(mlds_type)::out, list(take_addr_info)::out,
may_use_atomic_alloc::in, may_use_atomic_alloc::out) is semidet.
-ml_gen_cons_args_2([], [], [], [], [], _FirstOffset, _FirstArgNum, _TakeAddr,
+ml_gen_cons_args_2([], [], [], [], [],
+ _NumExtraArgs, _ArgWidths, _CurArgNum, _TakeAddr,
_ModuleInfo, _HighLevelData, [], [], [], !MayUseAtomic).
ml_gen_cons_args_2([Var | Vars], [Lval | Lvals], [ArgType | ArgTypes],
- [ConsArgType | ConsArgTypes], [UniMode | UniModes], FirstOffset,
- CurArgNum, !.TakeAddr, ModuleInfo, HighLevelData, [Rval | Rvals],
+ [ConsArgType | ConsArgTypes], [UniMode | UniModes],
+ NumExtraArgs, ArgWidths, CurArgNum, !.TakeAddr,
+ ModuleInfo, HighLevelData, [Rval | Rvals],
[MLDS_Type | MLDS_Types], TakeAddrInfos, !MayUseAtomic) :-
% It is important to use ArgType instead of ConsArgType here. ConsArgType
% is the declared type of the argument of the cons_id, while ArgType is
@@ -1321,13 +1358,10 @@ ml_gen_cons_args_2([Var | Vars], [Lval | Lvals], [ArgType | ArgTypes],
( !.TakeAddr = [CurArgNum | !:TakeAddr] ->
Rval = ml_const(mlconst_null(MLDS_Type)),
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
- FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, HighLevelData,
- Rvals, MLDS_Types, TakeAddrInfosTail, !MayUseAtomic),
- % Whereas CurArgNum starts numbering the arguments from 1, offsets
- % into fields start from zero. However, if FirstOffset > 0, then the
- % cell contains FirstOffset other things (e.g. a secondary tag) before
- % the first argument.
- Offset = CurArgNum - 1 + FirstOffset,
+ NumExtraArgs, ArgWidths, CurArgNum + 1, !.TakeAddr,
+ ModuleInfo, HighLevelData, Rvals, MLDS_Types, TakeAddrInfosTail,
+ !MayUseAtomic),
+ Offset = ml_calc_field_offset(NumExtraArgs, ArgWidths, CurArgNum),
OrigMLDS_Type = mercury_type_to_mlds_type(ModuleInfo, ConsArgType),
TakeAddrInfo = take_addr_info(Var, Offset, OrigMLDS_Type, MLDS_Type),
TakeAddrInfos = [TakeAddrInfo | TakeAddrInfosTail]
@@ -1343,17 +1377,28 @@ ml_gen_cons_args_2([Var | Vars], [Lval | Lvals], [ArgType | ArgTypes],
Rval = ml_const(mlconst_null(MLDS_Type))
),
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
- FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, HighLevelData,
- Rvals, MLDS_Types, TakeAddrInfos, !MayUseAtomic)
+ NumExtraArgs, ArgWidths, CurArgNum + 1, !.TakeAddr,
+ ModuleInfo, HighLevelData, Rvals, MLDS_Types, TakeAddrInfos,
+ !MayUseAtomic)
+ ).
+
+:- func ml_calc_field_offset(int, list(arg_width), int) = field_offset.
+
+ml_calc_field_offset(NumExtraArgs, ArgWidths, ArgNum) = Offset :-
+ ( list.take(ArgNum - 1, ArgWidths, WidthsBeforeArg) ->
+ WordsBeforeArg = count_distinct_words(WidthsBeforeArg),
+ Offset = offset(NumExtraArgs + WordsBeforeArg)
+ ;
+ unexpected($module, $pred, "more fields than arg_widths")
).
% Generate assignment statements for each of ExtraRvals into the object at
% VarLval, beginning at Offset.
%
:- pred ml_gen_extra_arg_assign(list(mlds_rval)::in,
- list(mlds_type)::in, mer_type::in, mlds_lval::in, int::in, cons_tag::in,
- prog_context::in, list(statement)::out, ml_gen_info::in, ml_gen_info::out)
- is det.
+ list(mlds_type)::in, mer_type::in, mlds_lval::in,
+ int::in, cons_tag::in, prog_context::in,
+ list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_extra_arg_assign([_ | _], [], _, _, _, _, _, _, !Info) :-
unexpected($module, $pred, "length mismatch").
@@ -1433,7 +1478,7 @@ ml_gen_det_deconstruct_tag(Tag, Type, Var, ConsId, Args, Modes, Context,
ml_gen_var(!.Info, Var, VarLval),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, VarLval, Type,
- Context, [], Statements)
+ full_word, Context, [], Statements)
;
unexpected($module, $pred, "no_tag: arity != 1")
)
@@ -1478,30 +1523,30 @@ ml_gen_det_deconstruct_tag(Tag, Type, Var, ConsId, Args, Modes, Context,
% indicates that the data doesn't have any fields.
%
:- pred ml_tag_offset_and_argnum(cons_tag::in, tag_bits::out,
- int::out, int::out) is det.
+ field_offset::out, int::out) is det.
-ml_tag_offset_and_argnum(Tag, TagBits, OffSet, ArgNum) :-
+ml_tag_offset_and_argnum(Tag, TagBits, Offset, ArgNum) :-
(
Tag = single_functor_tag,
TagBits = 0,
- OffSet = 0,
+ Offset = offset(0),
ArgNum = 1
;
( Tag = unshared_tag(UnsharedTag)
; Tag = direct_arg_tag(UnsharedTag)
),
TagBits = UnsharedTag,
- OffSet = 0,
+ Offset = offset(0),
ArgNum = 1
;
Tag = shared_remote_tag(PrimaryTag, _SecondaryTag),
TagBits = PrimaryTag,
- OffSet = 1,
+ Offset = offset(1),
ArgNum = 1
;
Tag = shared_with_reserved_addresses_tag(_, ThisTag),
% Just recurse on ThisTag.
- ml_tag_offset_and_argnum(ThisTag, TagBits, OffSet, ArgNum)
+ ml_tag_offset_and_argnum(ThisTag, TagBits, Offset, ArgNum)
;
( Tag = string_tag(_String)
; Tag = int_tag(_Int)
@@ -1533,7 +1578,10 @@ ml_tag_offset_and_argnum(Tag, TagBits, OffSet, ArgNum) :-
ml_field_names_and_types(Info, Type, ConsId, ArgTypes, Fields) :-
% Lookup the field types for the arguments of this cons_id.
Context = term.context_init,
- MakeUnnamedField = (func(FieldType) = ctor_arg(no, FieldType, Context)),
+ MakeUnnamedField = (func(FieldType) =
+ % Tuples and extra fields are word-sized.
+ ctor_arg(no, FieldType, full_word, Context)
+ ),
(
type_is_tuple(Type, _),
list.length(ArgTypes, TupleArity)
@@ -1560,8 +1608,9 @@ ml_field_names_and_types(Info, Type, ConsId, ArgTypes, Fields) :-
:- pred ml_gen_unify_args(cons_id::in, list(prog_var)::in, list(uni_mode)::in,
list(mer_type)::in, list(constructor_arg)::in, mer_type::in,
- mlds_lval::in, int::in, int::in, cons_tag::in, prog_context::in,
- list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
+ mlds_lval::in, field_offset::in, int::in, cons_tag::in,
+ prog_context::in, list(statement)::out, ml_gen_info::in, ml_gen_info::out)
+ is det.
ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, VarType, VarLval,
Offset, ArgNum, Tag, Context, Statements, !Info) :-
@@ -1577,25 +1626,43 @@ ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, VarType, VarLval,
:- pred ml_gen_unify_args_2(cons_id::in, list(prog_var)::in,
list(uni_mode)::in, list(mer_type)::in, list(constructor_arg)::in,
- mer_type::in, mlds_lval::in, int::in, int::in, cons_tag::in,
- prog_context::in, list(statement)::in, list(statement)::out,
+ mer_type::in, mlds_lval::in, field_offset::in, int::in,
+ cons_tag::in, prog_context::in, list(statement)::in, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is semidet.
ml_gen_unify_args_2(_, [], [], [], _, _, _, _, _, _, _, !Statements, !Info).
ml_gen_unify_args_2(ConsId, [Arg | Args], [Mode | Modes], [ArgType | ArgTypes],
[Field | Fields], VarType, VarLval, Offset, ArgNum, Tag,
Context, !Statements, !Info) :-
- Offset1 = Offset + 1,
+ ml_next_field_offset(Fields, Offset, Offset1),
ArgNum1 = ArgNum + 1,
ml_gen_unify_args_2(ConsId, Args, Modes, ArgTypes, Fields, VarType,
VarLval, Offset1, ArgNum1, Tag, Context, !Statements, !Info),
ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
Offset, ArgNum, Tag, Context, !Statements, !Info).
+:- pred ml_next_field_offset(list(constructor_arg)::in,
+ field_offset::in, field_offset::out) is det.
+
+ml_next_field_offset([], Offset, Offset).
+ml_next_field_offset([NextArg | _], PrevOffset, NextOffset) :-
+ NextArg = ctor_arg(_, _, NextWidth, _),
+ (
+ ( NextWidth = full_word
+ ; NextWidth = partial_word_first(_)
+ ),
+ PrevOffset = offset(Int),
+ NextOffset = offset(Int + 1)
+ ;
+ NextWidth = partial_word_shifted(_, _),
+ NextOffset = PrevOffset
+ ).
+
:- pred ml_gen_unify_args_for_reuse(cons_id::in, list(prog_var)::in,
list(uni_mode)::in, list(mer_type)::in, list(constructor_arg)::in,
- list(int)::in, mer_type::in, mlds_lval::in, int::in, int::in, cons_tag::in,
- prog_context::in, list(statement)::out, list(take_addr_info)::out,
+ list(int)::in, mer_type::in, mlds_lval::in, field_offset::in,
+ int::in, cons_tag::in, prog_context::in,
+ list(statement)::out, list(take_addr_info)::out,
ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_unify_args_for_reuse(ConsId, Args, Modes, ArgTypes, Fields, TakeAddr,
@@ -1615,7 +1682,7 @@ ml_gen_unify_args_for_reuse(ConsId, Args, Modes, ArgTypes, Fields, TakeAddr,
ArgTypes = [ArgType | ArgTypes1],
Fields = [Field | Fields1]
->
- Offset1 = Offset + 1,
+ ml_next_field_offset(Fields1, Offset, Offset1),
ArgNum1 = ArgNum + 1,
( TakeAddr = [ArgNum | TakeAddr1] ->
ml_gen_unify_args_for_reuse(ConsId, Args1, Modes1, ArgTypes1,
@@ -1646,7 +1713,7 @@ ml_gen_unify_args_for_reuse(ConsId, Args, Modes, ArgTypes, Fields, TakeAddr,
:- pred ml_gen_unify_arg(cons_id::in, prog_var::in, uni_mode::in,
mer_type::in, constructor_arg::in, mer_type::in, mlds_lval::in,
- int::in, int::in, cons_tag::in, prog_context::in,
+ field_offset::in, int::in, cons_tag::in, prog_context::in,
list(statement)::in, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is det.
@@ -1654,12 +1721,14 @@ ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
Offset, ArgNum, Tag, Context, !Statements, !Info) :-
MaybeFieldName = Field ^ arg_field_name,
FieldType = Field ^ arg_type,
+ FieldWidth = Field ^ arg_width,
ml_gen_info_get_high_level_data(!.Info, HighLevelData),
(
% With the low-level data representation, we access all fields
% using offsets.
HighLevelData = no,
- FieldId = ml_field_offset(ml_const(mlconst_int(Offset)))
+ Offset = offset(OffsetInt),
+ FieldId = ml_field_offset(ml_const(mlconst_int(OffsetInt)))
;
% With the high-level data representation, we always use named fields,
% except for tuple types.
@@ -1670,7 +1739,8 @@ ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
; type_needs_lowlevel_rep(Target, VarType)
)
->
- FieldId = ml_field_offset(ml_const(mlconst_int(Offset)))
+ Offset = offset(OffsetInt),
+ FieldId = ml_field_offset(ml_const(mlconst_int(OffsetInt)))
;
FieldName = ml_gen_field_name(MaybeFieldName, ArgNum),
( ConsId = cons(ConsName, ConsArity, TypeCtor) ->
@@ -1697,14 +1767,14 @@ ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
% Now generate code to unify them.
ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval,
- BoxedFieldType, Context, !Statements).
+ BoxedFieldType, FieldWidth, Context, !Statements).
:- pred ml_gen_sub_unify(module_info::in, uni_mode::in, mlds_lval::in,
- mer_type::in, mlds_lval::in, mer_type::in, prog_context::in,
+ mer_type::in, mlds_lval::in, mer_type::in, arg_width::in, prog_context::in,
list(statement)::in, list(statement)::out) is det.
ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval, FieldType,
- Context, !Statements) :-
+ FieldWidth, Context, !Statements) :-
% Figure out the direction of data-flow from the mode,
% and generate code accordingly.
%
@@ -1743,7 +1813,18 @@ ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval, FieldType,
->
ml_gen_box_or_unbox_rval(ModuleInfo, FieldType, ArgType,
native_if_possible, ml_lval(FieldLval), FieldRval),
- Statement = ml_gen_assign(ArgLval, FieldRval, Context),
+ (
+ FieldWidth = full_word,
+ Statement = ml_gen_assign(ArgLval, FieldRval, Context)
+ ;
+ FieldWidth = partial_word_first(Mask),
+ UnpackRval = ml_bitwise_and(FieldRval, Mask),
+ Statement = ml_gen_assign(ArgLval, UnpackRval, Context)
+ ;
+ FieldWidth = partial_word_shifted(Shift, Mask),
+ UnpackRval = ml_bitwise_and(ml_rshift(FieldRval, Shift), Mask),
+ Statement = ml_gen_assign(ArgLval, UnpackRval, Context)
+ ),
!:Statements = [Statement | !.Statements]
;
% Output - input: it's an assignment to the LHS.
@@ -1752,7 +1833,22 @@ ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval, FieldType,
->
ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, FieldType,
native_if_possible, ml_lval(ArgLval), ArgRval),
- Statement = ml_gen_assign(FieldLval, ArgRval, Context),
+ (
+ FieldWidth = full_word,
+ Statement = ml_gen_assign(FieldLval, ArgRval, Context)
+ ;
+ (
+ FieldWidth = partial_word_first(Mask),
+ Shift = 0
+ ;
+ FieldWidth = partial_word_shifted(Shift, Mask)
+ ),
+ CastVal = ml_unop(unbox(mlds_native_int_type), ml_lval(FieldLval)),
+ MaskOld = ml_bitwise_and(CastVal, \(Mask << Shift)),
+ ShiftNew = ml_lshift(ArgRval, Shift),
+ Combined = ml_bitwise_or(MaskOld, ShiftNew),
+ Statement = ml_gen_assign(FieldLval, Combined, Context)
+ ),
!:Statements = [Statement | !.Statements]
;
% Unused - unused: the unification has no effect.
@@ -2384,7 +2480,9 @@ ml_gen_ground_term_conjunct_compound(ModuleInfo, Target, HighLevelData,
type_util.get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
->
ConsArgDefns = ConsDefn ^ cons_args,
+ % XXX the compiler crashes if you try to write this with list.map2
ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgDefns),
+ ConsArgWidths = list.map(func(C) = C ^ arg_width, ConsArgDefns),
NumExtraArgs = list.length(Args) - list.length(ConsArgTypes),
% If the scope contains existentially typed constructions,
% then polymorphism should have changed its scope_reason
@@ -2401,24 +2499,31 @@ ml_gen_ground_term_conjunct_compound(ModuleInfo, Target, HighLevelData,
% here, since all we really care about at this point is whether
% something is a type variable or not, not which type variable it
% is.
- ConsArgTypes = ml_make_boxed_types(list.length(Args))
+ Length = list.length(Args),
+ ConsArgTypes = ml_make_boxed_types(Length),
+ ConsArgWidths = list.duplicate(Length, full_word)
;
% Type_util.get_cons_defn shouldn't have failed.
unexpected($module, $pred, "get_cons_defn failed")
)
;
- ConsArgTypes = ArgTypes
+ Length = list.length(ArgTypes),
+ ConsArgTypes = ArgTypes,
+ ConsArgWidths = list.duplicate(Length, full_word)
),
assoc_list.from_corresponding_lists(Args, ConsArgTypes, ArgConsArgTypes),
(
HighLevelData = yes,
construct_ground_term_initializers_hld(ModuleInfo, Context,
- ArgConsArgTypes, ArgInitializers, !GlobalData, !GroundTermMap)
+ ArgConsArgTypes, ArgRvals0, !GlobalData, !GroundTermMap)
;
HighLevelData = no,
construct_ground_term_initializers_lld(ModuleInfo, Context,
- ArgConsArgTypes, ArgInitializers, !GlobalData, !GroundTermMap)
+ ArgConsArgTypes, ArgRvals0, !GlobalData, !GroundTermMap)
),
+ pack_args(ml_shift_combine_rval, ConsArgWidths, ArgRvals0, ArgRvals,
+ unit, _, unit, _),
+ ArgInitializers = list.map(func(Init) = init_obj(Init), ArgRvals),
% By construction, boxing the rvals in ExtraInitializers would be a no-op.
SubInitializers = ExtraInitializers ++ ArgInitializers,
@@ -2455,64 +2560,153 @@ ml_gen_ground_term_conjunct_compound(ModuleInfo, Target, HighLevelData,
:- pred construct_ground_term_initializers_hld(module_info::in,
prog_context::in,
- assoc_list(prog_var, mer_type) ::in, list(mlds_initializer)::out,
+ assoc_list(prog_var, mer_type) ::in, list(mlds_rval)::out,
ml_global_data::in, ml_global_data::out,
ml_ground_term_map::in, ml_ground_term_map::out) is det.
construct_ground_term_initializers_hld(_, _, [], [],
!GlobalData, !GroundTermMap).
construct_ground_term_initializers_hld(ModuleInfo, Context,
- [ArgConsArgType | ArgConsArgTypes], [ArgInitializer | ArgInitializers],
+ [ArgConsArgType | ArgConsArgTypes], [ArgRval | ArgRvals],
!GlobalData, !GroundTermMap) :-
construct_ground_term_initializer_hld(ModuleInfo, Context,
- ArgConsArgType, ArgInitializer, !GlobalData, !GroundTermMap),
+ ArgConsArgType, ArgRval, !GlobalData, !GroundTermMap),
construct_ground_term_initializers_hld(ModuleInfo, Context,
- ArgConsArgTypes, ArgInitializers, !GlobalData, !GroundTermMap).
+ ArgConsArgTypes, ArgRvals, !GlobalData, !GroundTermMap).
:- pred construct_ground_term_initializers_lld(module_info::in,
prog_context::in,
- assoc_list(prog_var, mer_type) ::in, list(mlds_initializer)::out,
+ assoc_list(prog_var, mer_type) ::in, list(mlds_rval)::out,
ml_global_data::in, ml_global_data::out,
ml_ground_term_map::in, ml_ground_term_map::out) is det.
construct_ground_term_initializers_lld(_, _, [], [],
!GlobalData, !GroundTermMap).
construct_ground_term_initializers_lld(ModuleInfo, Context,
- [ArgConsArgType | ArgConsArgTypes], [ArgInitializer | ArgInitializers],
+ [ArgConsArgType | ArgConsArgTypes], [ArgRval | ArgRvals],
!GlobalData, !GroundTermMap) :-
construct_ground_term_initializer_lld(ModuleInfo, Context,
- ArgConsArgType, ArgInitializer, !GlobalData, !GroundTermMap),
+ ArgConsArgType, ArgRval, !GlobalData, !GroundTermMap),
construct_ground_term_initializers_lld(ModuleInfo, Context,
- ArgConsArgTypes, ArgInitializers, !GlobalData, !GroundTermMap).
+ ArgConsArgTypes, ArgRvals, !GlobalData, !GroundTermMap).
%-----------------------------------------------------------------------------%
:- pred construct_ground_term_initializer_hld(module_info::in,
- prog_context::in, pair(prog_var, mer_type) ::in, mlds_initializer::out,
+ prog_context::in, pair(prog_var, mer_type) ::in, mlds_rval::out,
ml_global_data::in, ml_global_data::out,
ml_ground_term_map::in, ml_ground_term_map::out) is det.
construct_ground_term_initializer_hld(ModuleInfo, Context,
- Arg - ConsArgType, ArgInitializer, !GlobalData, !GroundTermMap) :-
+ Arg - ConsArgType, ArgRval, !GlobalData, !GroundTermMap) :-
map.det_remove(Arg, ArgGroundTerm, !GroundTermMap),
ArgGroundTerm = ml_ground_term(ArgRval0, ArgType, _MLDS_ArgType),
ml_type_as_field(ModuleInfo, yes, ConsArgType, BoxedArgType),
ml_gen_box_or_unbox_const_rval(ModuleInfo, ArgType, BoxedArgType,
- ArgRval0, Context, ArgRval, !GlobalData),
- ArgInitializer = init_obj(ArgRval).
+ ArgRval0, Context, ArgRval, !GlobalData).
:- pred construct_ground_term_initializer_lld(module_info::in,
- prog_context::in, pair(prog_var, mer_type) ::in, mlds_initializer::out,
+ prog_context::in, pair(prog_var, mer_type) ::in, mlds_rval::out,
ml_global_data::in, ml_global_data::out,
ml_ground_term_map::in, ml_ground_term_map::out) is det.
construct_ground_term_initializer_lld(ModuleInfo, Context,
- Arg - _ConsArgType, ArgInitializer, !GlobalData, !GroundTermMap) :-
+ Arg - _ConsArgType, ArgRval, !GlobalData, !GroundTermMap) :-
map.det_remove(Arg, ArgGroundTerm, !GroundTermMap),
ArgGroundTerm = ml_ground_term(ArgRval0, _ArgType, MLDS_ArgType),
ml_gen_box_const_rval(ModuleInfo, Context, MLDS_ArgType,
- ArgRval0, ArgRval, !GlobalData),
- ArgInitializer = init_obj(ArgRval).
+ ArgRval0, ArgRval, !GlobalData).
+
+%-----------------------------------------------------------------------------%
+
+:- pred ml_shift_combine_rval(mlds_rval::in, int::in, maybe(mlds_rval)::in,
+ mlds_rval::out, unit::in, unit::out, unit::in, unit::out) is det.
+
+ml_shift_combine_rval(RvalA, Shift, MaybeRvalB, RvalC, !Acc1, !Acc2) :-
+ ShiftRvalA = ml_lshift(RvalA, Shift),
+ (
+ MaybeRvalB = yes(RvalB),
+ RvalC = ml_bitwise_or(ShiftRvalA, RvalB)
+ ;
+ MaybeRvalB = no,
+ RvalC = ShiftRvalA
+ ).
+
+:- pred ml_shift_combine_rval_type(pair(mlds_rval, mlds_type)::in, int::in,
+ maybe(pair(mlds_rval, mlds_type))::in, pair(mlds_rval, mlds_type)::out,
+ unit::in, unit::out, unit::in, unit::out) is det.
+
+ml_shift_combine_rval_type(ArgA, Shift, MaybeArgB, ArgC, !Acc1, !Acc2) :-
+ ArgA = RvalA - TypeA,
+ ShiftRvalA = ml_lshift(RvalA, Shift),
+ (
+ MaybeArgB = yes(RvalB - _TypeB),
+ RvalC = ml_bitwise_or(ShiftRvalA, RvalB)
+ ;
+ MaybeArgB = no,
+ RvalC = ShiftRvalA
+ ),
+ % This type better be acceptable.
+ ArgC = RvalC - TypeA.
+
+:- func ml_lshift(mlds_rval, int) = mlds_rval.
+
+ml_lshift(Rval0, Shift) = Rval :-
+ % We may get nulls from unfilled fields. Replace them with zeroes so we
+ % don't get type errors from the C compiler.
+ ( Rval0 = ml_const(mlconst_null(_)) ->
+ Rval = ml_const(mlconst_int(0))
+ ; Shift = 0 ->
+ Rval = Rval0
+ ; Rval0 = ml_unop(box(Type), Rval1) ->
+ Rval2 = ml_binop(unchecked_left_shift, Rval1,
+ ml_const(mlconst_int(Shift))),
+ Rval = ml_unop(box(Type), Rval2)
+ ;
+ Rval = ml_binop(unchecked_left_shift, Rval0,
+ ml_const(mlconst_int(Shift)))
+ ).
+
+:- func ml_rshift(mlds_rval, int) = mlds_rval.
+
+ml_rshift(Rval, Shift) =
+ ( Shift = 0 ->
+ Rval
+ ;
+ ml_binop(unchecked_right_shift, Rval, ml_const(mlconst_int(Shift)))
+ ).
+
+:- func ml_bitwise_or(mlds_rval, mlds_rval) = mlds_rval.
+
+ml_bitwise_or(RvalA, RvalB) = Rval :-
+ some [!MaybeType] (
+ !:MaybeType = no,
+ ( RvalA = ml_unop(box(TypeA), UnboxRvalA0) ->
+ UnboxRvalA = UnboxRvalA0,
+ !:MaybeType = yes(TypeA)
+ ;
+ UnboxRvalA = RvalA
+ ),
+ ( RvalB = ml_unop(box(TypeB), UnboxRvalB0) ->
+ UnboxRvalB = UnboxRvalB0,
+ !:MaybeType = yes(TypeB)
+ ;
+ UnboxRvalB = RvalB
+ ),
+ UnboxRval = ml_binop(bitwise_or, UnboxRvalA, UnboxRvalB),
+ (
+ !.MaybeType = yes(BoxType),
+ Rval = ml_unop(box(BoxType), UnboxRval)
+ ;
+ !.MaybeType = no,
+ Rval = UnboxRval
+ )
+ ).
+
+:- func ml_bitwise_and(mlds_rval, int) = mlds_rval.
+
+ml_bitwise_and(Rval, Mask) =
+ ml_binop(bitwise_and, Rval, ml_const(mlconst_int(Mask))).
%-----------------------------------------------------------------------------%
:- end_module ml_backend.ml_unify_gen.
diff --git a/compiler/mlds.m b/compiler/mlds.m
index 518c78c..e8c4696 100644
--- a/compiler/mlds.m
+++ b/compiler/mlds.m
@@ -1314,6 +1314,8 @@
maybe(ctor_name),
% The arguments to the constructor.
+ % Any arguments which are supposed to be packed together should
+ % be packed in this list by the HLDS->MLDS code generator.
list(mlds_rval),
% The types of the arguments to the constructor.
@@ -2126,166 +2128,46 @@ mlds_std_tabling_proc_label(ProcLabel0) = ProcLabel :-
%-----------------------------------------------------------------------------%
- % We represent the set of declaration flags as a bunch of bit-fields packed
- % into a single int.
+ % The compiler can pack all the enumeration arguments together,
+ % though a cell will still be allocated.
%
-:- type mlds_decl_flags == int.
-
-% Here we define which bits are used to store each bitfield.
-%
-% It would be nicer to use a language builtin, e.g. index/2, for these.
-% But currently builtin.index/2 does not work in the reverse mode,
-% and you can't use construct.construct/4 since that numbers the
-% alternatives in a different order than builtin.index/2.
-%
-% It would also be nice to use a typeclass:
-% :- typeclass bitfield(T) where [
-% func bits(T) = int,
-% func mask(T::unused) = (int::out) is det
-% ].
-% But currently that is too cumbersome, since you can't define class
-% methods inline.
-%
-% On the other hand, doing it manually may be more efficient than either
-% of those two approaches.
-
-:- func access_bits(access) = int.
-:- mode access_bits(in) = out is det.
-:- mode access_bits(out) = in is semidet.
-access_bits(acc_public) = 0x00.
-access_bits(acc_private) = 0x01.
-access_bits(acc_protected) = 0x02.
-access_bits(acc_default) = 0x03.
-access_bits(acc_local) = 0x04.
-% 0x5 - 0x7 reserved
-
-:- func access_mask = int.
-access_mask = 0x07.
-
-:- func per_instance_bits(per_instance) = int.
-:- mode per_instance_bits(in) = out is det.
-:- mode per_instance_bits(out) = in is semidet.
-per_instance_bits(one_copy) = 0x00.
-per_instance_bits(per_instance) = 0x08.
-
-:- func per_instance_mask = int.
-per_instance_mask = per_instance_bits(per_instance).
-
-:- func virtuality_bits(virtuality) = int.
-:- mode virtuality_bits(in) = out is det.
-:- mode virtuality_bits(out) = in is semidet.
-virtuality_bits(non_virtual) = 0x00.
-virtuality_bits(virtual) = 0x10.
-
-:- func virtuality_mask = int.
-virtuality_mask = virtuality_bits(virtual).
-
-:- func overridability_bits(overridability) = int.
-:- mode overridability_bits(in) = out is det.
-:- mode overridability_bits(out) = in is semidet.
-overridability_bits(overridable) = 0x00.
-overridability_bits(sealed) = 0x20.
-
-:- func overridability_mask = int.
-overridability_mask = overridability_bits(sealed).
-
-:- func constness_bits(constness) = int.
-:- mode constness_bits(in) = out is det.
-:- mode constness_bits(out) = in is semidet.
-constness_bits(modifiable) = 0x00.
-constness_bits(const) = 0x40.
-
-:- func constness_mask = int.
-constness_mask = constness_bits(const).
-
-:- func abstractness_bits(abstractness) = int.
-:- mode abstractness_bits(in) = out is det.
-:- mode abstractness_bits(out) = in is semidet.
-abstractness_bits(abstract) = 0x00.
-abstractness_bits(concrete) = 0x80.
-
-:- func abstractness_mask = int.
-abstractness_mask = abstractness_bits(concrete).
-
-%
-% Here we define the functions to lookup a member of the set.
-%
-
-access(Flags) = Access :-
- ( Flags /\ access_mask = access_bits(AccessPrime) ->
- Access = AccessPrime
- ;
- unexpected($module, $pred, "access: unknown bits")
- ).
-
-per_instance(Flags) = PerInstance :-
- ( Flags /\ per_instance_mask = per_instance_bits(PerInstancePrime) ->
- PerInstance = PerInstancePrime
- ;
- unexpected($module, $pred, "per_instance: unknown bits")
- ).
-
-virtuality(Flags) = Virtuality :-
- ( Flags /\ virtuality_mask = virtuality_bits(VirtualityPrime) ->
- Virtuality = VirtualityPrime
- ;
- unexpected($module, $pred, "virtuality: unknown bits")
- ).
-
-overridability(Flags) = Overridability :-
- ( Flags /\ overridability_mask = overridability_bits(Overridability0) ->
- Overridability = Overridability0
- ;
- unexpected($module, $pred, "per_instance: unknown bits")
- ).
-
-constness(Flags) = Constness :-
- ( Flags /\ constness_mask = constness_bits(ConstnessPrime) ->
- Constness = ConstnessPrime
- ;
- unexpected($module, $pred, "per_instance: unknown bits")
- ).
-
-abstractness(Flags) = Abstractness :-
- ( Flags /\ abstractness_mask = abstractness_bits(AbstractnessPrime) ->
- Abstractness = AbstractnessPrime
- ;
- unexpected($module, $pred, "per_instance: unknown bits")
- ).
+:- type mlds_decl_flags
+ ---> mlds_decl_flags(
+ mdf_access :: access,
+ mdf_per_instance :: per_instance,
+ mdf_virtuality :: virtuality,
+ mdf_overridability :: overridability,
+ mdf_constness :: constness,
+ mdf_abstractness :: abstractness
+ ).
-%
-% Here we define the functions to set a member of the set.
-%
+access(Flags) = Flags ^ mdf_access.
+per_instance(Flags) = Flags ^ mdf_per_instance.
+virtuality(Flags) = Flags ^ mdf_virtuality.
+overridability(Flags) = Flags ^ mdf_overridability.
+constness(Flags) = Flags ^ mdf_constness.
+abstractness(Flags) = Flags ^ mdf_abstractness.
set_access(Flags, Access) =
- Flags /\ \access_mask \/ access_bits(Access).
-
+ Flags ^ mdf_access := Access.
set_per_instance(Flags, PerInstance) =
- Flags /\ \per_instance_mask \/ per_instance_bits(PerInstance).
-
+ Flags ^ mdf_per_instance := PerInstance.
set_virtuality(Flags, Virtuality) =
- Flags /\ \virtuality_mask \/ virtuality_bits(Virtuality).
-
+ Flags ^ mdf_virtuality := Virtuality.
set_overridability(Flags, Overridability) =
- Flags /\ \overridability_mask \/ overridability_bits(Overridability).
-
+ Flags ^ mdf_overridability := Overridability.
set_constness(Flags, Constness) =
- Flags /\ \constness_mask \/ constness_bits(Constness).
-
+ Flags ^ mdf_constness := Constness.
set_abstractness(Flags, Abstractness) =
- Flags /\ \abstractness_mask \/ abstractness_bits(Abstractness).
+ Flags ^ mdf_abstractness := Abstractness.
init_decl_flags(Access, PerInstance, Virtuality, Overridability, Constness,
Abstractness) =
- access_bits(Access) \/
- per_instance_bits(PerInstance) \/
- virtuality_bits(Virtuality) \/
- overridability_bits(Overridability) \/
- constness_bits(Constness) \/
- abstractness_bits(Abstractness).
+ mlds_decl_flags(Access, PerInstance, Virtuality, Overridability, Constness,
+ Abstractness).
ml_static_const_decl_flags = DeclFlags :-
- % Note that rtti_decl_flags, in rtti_to_mlds.m,
+ % Note that rtti_data_decl_flags, in rtti_to_mlds.m,
% must be the same as this apart from the access.
Access = acc_local,
PerInstance = one_copy,
diff --git a/compiler/mlds_to_gcc.m b/compiler/mlds_to_gcc.m
index 0644080..a4aeff5 100644
--- a/compiler/mlds_to_gcc.m
+++ b/compiler/mlds_to_gcc.m
@@ -1966,6 +1966,8 @@ build_rtti_type_name(type_ctor_exist_info(_), GCC_Type, !IO) :-
build_du_exist_info_type(GCC_Type, !IO).
build_rtti_type_name(type_ctor_field_names(_), 'MR_ConstString', !IO).
build_rtti_type_name(type_ctor_field_types(_), 'MR_PseudoTypeInfo', !IO).
+build_rtti_type_name(type_ctor_field_locns(_), _, !IO) :-
+ sorry($module, $pred, "MR_DuArgLocn").
build_rtti_type_name(type_ctor_res_addrs, gcc.ptr_type_node, !IO).
build_rtti_type_name(type_ctor_res_addr_functors, gcc.ptr_type_node, !IO).
build_rtti_type_name(type_ctor_enum_functor_desc(_), GCC_Type, !IO) :-
@@ -2002,6 +2004,7 @@ build_rtti_type_name(type_ctor_du_functor_desc(_), GCC_Type, !IO) :-
% const MR_PseudoTypeInfo *MR_du_functor_arg_types;
% const MR_ConstString *MR_du_functor_arg_names;
% const MR_DuExistInfo *MR_du_functor_exist_info;
+ % const MR_DuArgLocn *MR_du_functor_arg_locns; /* XXX not yet */
% } MR_DuFunctorDesc;
build_du_exist_info_type(MR_DuExistInfo, !IO),
gcc.build_pointer_type('MR_PseudoTypeInfo', MR_PseudoTypeInfoPtr, !IO),
diff --git a/compiler/modules.m b/compiler/modules.m
index a692dde..679ba68 100644
--- a/compiler/modules.m
+++ b/compiler/modules.m
@@ -739,22 +739,25 @@ strip_unnecessary_impl_defns(Items0, Items) :-
% If there is an exported type declaration for a type with an abstract
% declaration in the implementation (usually it will originally
% have been a d.u. type), remove the declaration in the implementation.
- FindAbstractExportedTypes =
+ % Don't remove `type_is_abstract_enum' declarations, though.
+ FindRemovableAbsExpTypes =
(pred(TypeCtor::out) is nondet :-
map.member(!.ImplTypesMap, TypeCtor, Defns),
- \+ (
- list.member(Defn, Defns),
- Defn \= parse_tree_abstract_type(_) - _
- ),
+ all [Defn] (
+ list.member(Defn - _, Defns)
+ => (
+ Defn = parse_tree_abstract_type(Details),
+ Details \= abstract_enum_type(_)
+ )),
multi_map.contains(!.IntTypesMap, TypeCtor)
),
- solutions(FindAbstractExportedTypes, AbstractExportedTypes),
+ solutions(FindRemovableAbsExpTypes, RemovableAbstractExportedTypes),
RemoveFromImplTypesMap =
(pred(TypeCtor::in, !.ImplTypesMap::in, !:ImplTypesMap::out)
is det :-
multi_map.delete(TypeCtor, !ImplTypesMap)
),
- list.foldl(RemoveFromImplTypesMap, AbstractExportedTypes,
+ list.foldl(RemoveFromImplTypesMap, RemovableAbstractExportedTypes,
!ImplTypesMap),
AddProjectedItem =
@@ -938,13 +941,24 @@ insert_type_defn(New, [Head | Tail], Result) :-
make_impl_type_abstract(TypeDefnMap, !TypeDefnPairs) :-
(
!.TypeDefnPairs = [TypeDefn0 - ItemTypeDefn0],
- TypeDefn0 = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors),
- not constructor_list_represents_dummy_argument_type(TypeDefnMap,
- Ctors, MaybeEqCmp, MaybeDirectArgCtors)
+ TypeDefn0 = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors)
->
- Defn = parse_tree_abstract_type(non_solver_type),
- ItemTypeDefn = ItemTypeDefn0 ^ td_ctor_defn := Defn,
- !:TypeDefnPairs = [Defn - ItemTypeDefn]
+ (
+ constructor_list_represents_dummy_argument_type(TypeDefnMap, Ctors,
+ MaybeEqCmp, MaybeDirectArgCtors)
+ ->
+ % Leave dummy types alone.
+ true
+ ;
+ ( du_type_is_enum(Ctors, NumBits) ->
+ Details = abstract_enum_type(NumBits)
+ ;
+ Details = abstract_type_general
+ ),
+ Defn = parse_tree_abstract_type(Details),
+ ItemTypeDefn = ItemTypeDefn0 ^ td_ctor_defn := Defn,
+ !:TypeDefnPairs = [Defn - ItemTypeDefn]
+ )
;
true
).
@@ -982,7 +996,7 @@ constructor_list_represents_dummy_argument_type_2(TypeDefnMap, [Ctor], no, no,
Args = []
;
% A constructor with a single dummy argument.
- Args = [ctor_arg(_, ArgType, _)],
+ Args = [ctor_arg(_, ArgType, _, _)],
ctor_arg_is_dummy_type(TypeDefnMap, ArgType, CoveredTypes) = yes
).
@@ -1106,6 +1120,10 @@ is_not_unnecessary_impl_type(NecessaryTypeCtors, Item) :-
% exported and the implementation section also contains a foreign_type
% definition of the type constructor.
%
+ % Given a enumeration type definition in the implementation section, we
+ % should include it in AbsImplExpEnumTypeCtors if the type constructor is
+ % abstract exported.
+ %
% Return in Modules the set of modules that define the type constructors
% in NecessaryTypeCtors.
%
@@ -1116,24 +1134,28 @@ is_not_unnecessary_impl_type(NecessaryTypeCtors, Item) :-
get_requirements_of_impl_exported_types(InterfaceTypeMap, ImplTypeMap,
BothTypeMap, DummyTypeCtors, NecessaryTypeCtors, Modules) :-
multi_map.to_flat_assoc_list(ImplTypeMap, ImplTypes),
- list.foldl2(
+ list.foldl3(
accumulate_abs_impl_exported_type_lhs(InterfaceTypeMap, BothTypeMap),
- ImplTypes, set.init, AbsImplExpLhsTypeCtors, set.init, DummyTypeCtors),
+ ImplTypes, set.init, AbsImplExpLhsTypeCtors,
+ set.init, AbsImplExpEnumTypeCtors, set.init, DummyTypeCtors),
set.fold3(accumulate_abs_impl_exported_type_rhs(ImplTypeMap),
AbsImplExpLhsTypeCtors,
set.init, AbsEqvRhsTypeCtors, set.init, ForeignDuFieldTypeCtors,
set.init, Modules),
NecessaryTypeCtors = set.union_list([AbsImplExpLhsTypeCtors,
- AbsEqvRhsTypeCtors, ForeignDuFieldTypeCtors]).
+ AbsEqvRhsTypeCtors, ForeignDuFieldTypeCtors,
+ AbsImplExpEnumTypeCtors]).
:- pred accumulate_abs_impl_exported_type_lhs(type_defn_map::in,
type_defn_map::in,
pair(type_ctor, pair(type_defn, item_type_defn_info))::in,
set(type_ctor)::in, set(type_ctor)::out,
+ set(type_ctor)::in, set(type_ctor)::out,
set(type_ctor)::in, set(type_ctor)::out) is det.
accumulate_abs_impl_exported_type_lhs(InterfaceTypeMap, BothTypesMap,
- TypeCtor - (TypeDefn - _Item), !AbsEqvLhsTypeCtors, !DummyTypeCtors) :-
+ TypeCtor - (TypeDefn - _Item), !AbsEqvLhsTypeCtors,
+ !AbsImplExpEnumTypeCtors, !DummyTypeCtors) :-
% A type may have multiple definitions because it may be defined both
% as a foreign type and as a Mercury type. We grab any equivalence types
% that are in there.
@@ -1148,11 +1170,21 @@ accumulate_abs_impl_exported_type_lhs(InterfaceTypeMap, BothTypesMap,
->
set.insert(TypeCtor, !AbsEqvLhsTypeCtors)
;
- TypeDefn = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors),
- constructor_list_represents_dummy_argument_type(BothTypesMap,
- Ctors, MaybeEqCmp, MaybeDirectArgCtors)
+ TypeDefn = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors)
->
- set.insert(TypeCtor, !DummyTypeCtors)
+ (
+ map.search(InterfaceTypeMap, TypeCtor, _),
+ du_type_is_enum(Ctors, _NumBits)
+ ->
+ set.insert(TypeCtor, !AbsImplExpEnumTypeCtors)
+ ;
+ constructor_list_represents_dummy_argument_type(BothTypesMap,
+ Ctors, MaybeEqCmp, MaybeDirectArgCtors)
+ ->
+ set.insert(TypeCtor, !DummyTypeCtors)
+ ;
+ true
+ )
;
true
).
@@ -1260,7 +1292,7 @@ ctors_to_type_ctor_set([Ctor | Ctors], !TypeCtors) :-
cons_args_to_type_ctor_set([], !TypeCtors).
cons_args_to_type_ctor_set([Arg | Args], !TypeCtors) :-
- Arg = ctor_arg(_, Type, _),
+ Arg = ctor_arg(_, Type, _, _),
type_to_type_ctor_set(Type, !TypeCtors),
cons_args_to_type_ctor_set(Args, !TypeCtors).
@@ -3927,26 +3959,29 @@ make_abstract_defn(Item, ShortInterfaceKind, AbstractItem) :-
Item = item_type_defn(ItemTypeDefn),
TypeDefn = ItemTypeDefn ^ td_ctor_defn,
(
- TypeDefn = parse_tree_du_type(_, _, _),
- IsSolverType = non_solver_type,
+ TypeDefn = parse_tree_du_type(Ctors, _, _),
+ ( du_type_is_enum(Ctors, NumBits) ->
+ AbstractDetails = abstract_enum_type(NumBits)
+ ;
+ AbstractDetails = abstract_type_general
+ ),
% For the `.int2' files, we need the full definitions of
% discriminated union types. Even if the functors for a type
% are not used within a module, we may need to know them for
% comparing insts, e.g. for comparing `ground' and `bound(...)'.
ShortInterfaceKind = int3
;
- TypeDefn = parse_tree_abstract_type(IsSolverType)
+ TypeDefn = parse_tree_abstract_type(AbstractDetails)
;
TypeDefn = parse_tree_solver_type(_, _),
% rafe: XXX we need to also export the details of the
% forwarding type for the representation and the forwarding
% pred for initialization.
- IsSolverType = solver_type
+ AbstractDetails = abstract_solver_type
;
TypeDefn = parse_tree_eqv_type(_),
- % rafe: XXX what *should* IsSolverType be here? We need
- % to know properly.
- IsSolverType = non_solver_type,
+ % XXX is this right for solver types?
+ AbstractDetails = abstract_type_general,
% For the `.int2' files, we need the full definitions of
% equivalence types. They are needed to ensure that
% non-abstract equivalence types always get fully expanded
@@ -3960,11 +3995,11 @@ make_abstract_defn(Item, ShortInterfaceKind, AbstractItem) :-
TypeDefn = parse_tree_foreign_type(_, _, _),
% We always need the definitions of foreign types
% to handle inter-language interfacing correctly.
- IsSolverType = non_solver_type,
+ AbstractDetails = abstract_type_general,
semidet_fail
),
AbstractItemTypeDefn = ItemTypeDefn ^ td_ctor_defn
- := parse_tree_abstract_type(IsSolverType),
+ := parse_tree_abstract_type(AbstractDetails),
AbstractItem = item_type_defn(AbstractItemTypeDefn)
;
Item = item_instance(ItemInstance),
@@ -3978,6 +4013,21 @@ make_abstract_defn(Item, ShortInterfaceKind, AbstractItem) :-
AbstractItem = item_typeclass(AbstractItemTypeClass)
).
+:- pred du_type_is_enum(list(constructor)::in, int::out) is semidet.
+
+du_type_is_enum(Ctors, NumBits) :-
+ Ctors = [_, _ | _],
+ all [Ctor] (
+ list.member(Ctor, Ctors)
+ => (
+ Ctor = ctor(ExistQTVars, ExistConstraints, _Name, Args, _Context),
+ ExistQTVars = [],
+ ExistConstraints = [],
+ Args = []
+ )),
+ list.length(Ctors, NumFunctors),
+ int.log2(NumFunctors, NumBits).
+
:- pred make_abstract_unify_compare(item::in, short_interface_kind::in,
item::out) is semidet.
diff --git a/compiler/opt_debug.m b/compiler/opt_debug.m
index 4e49cb6..dfe53ea 100644
--- a/compiler/opt_debug.m
+++ b/compiler/opt_debug.m
@@ -426,6 +426,8 @@ dump_rtti_name(type_ctor_field_names(Ordinal)) =
"field_names_" ++ int_to_string(Ordinal).
dump_rtti_name(type_ctor_field_types(Ordinal)) =
"field_types_" ++ int_to_string(Ordinal).
+dump_rtti_name(type_ctor_field_locns(Ordinal)) =
+ "field_locns_" ++ int_to_string(Ordinal).
dump_rtti_name(type_ctor_res_addrs) = "res_addrs".
dump_rtti_name(type_ctor_res_addr_functors) = "res_addr_functors".
dump_rtti_name(type_ctor_enum_functor_desc(Ordinal)) =
diff --git a/compiler/options.m b/compiler/options.m
index 7170fb8..c975c95 100644
--- a/compiler/options.m
+++ b/compiler/options.m
@@ -577,6 +577,8 @@
; type_check_constraints
+ ; allow_argument_packing
+
% Code generation options
; low_level_debug
; table_debug
@@ -1390,7 +1392,8 @@ option_defaults_2(internal_use_option, [
size_region_commit_entry - int(1),
solver_type_auto_init - bool(no),
allow_multi_arm_switches - bool(yes),
- type_check_constraints - bool(no)
+ type_check_constraints - bool(no),
+ allow_argument_packing - bool(yes)
]).
option_defaults_2(code_gen_option, [
% Code Generation Options
@@ -2268,6 +2271,7 @@ long_option("size-region-commit-entry", size_region_commit_entry).
long_option("solver-type-auto-init", solver_type_auto_init).
long_option("allow-multi-arm-switches", allow_multi_arm_switches).
long_option("type-check-constraints", type_check_constraints).
+long_option("allow-argument-packing", allow_argument_packing).
% code generation options
long_option("low-level-debug", low_level_debug).
@@ -4634,6 +4638,12 @@ options_help_compilation_model -->
% "--type-check-constraints",
% "(This option is not for general use.)",
% Use the constraint based type checker instead of the old one.
+
+ % This is a developer only option.
+% "--allow-argument-packing",
+% "(This option is not for general use.)",
+% Allow the compiler to pack multiple constructor arguments into
+% a single field.
]).
:- pred options_help_code_generation(io::di, io::uo) is det.
diff --git a/compiler/prog_data.m b/compiler/prog_data.m
index 9bf4eac..07f4702 100644
--- a/compiler/prog_data.m
+++ b/compiler/prog_data.m
@@ -1635,7 +1635,7 @@ equivalent_cons_ids(ConsIdA, ConsIdB) :-
eqv_type :: mer_type
)
; parse_tree_abstract_type(
- abstract_is_solver :: is_solver_type
+ abstract_details :: abstract_type_details
)
; parse_tree_solver_type(
solver_details :: solver_type_details,
@@ -1647,6 +1647,14 @@ equivalent_cons_ids(ConsIdA, ConsIdB) :-
foreign_assertions :: list(foreign_type_assertion)
).
+:- type abstract_type_details
+ ---> abstract_type_general
+ ; abstract_enum_type(int)
+ % The abstract type is known to be an enumeration type, requiring
+ % the given number of bits required to represent.
+ ; abstract_solver_type.
+ % An abstract solver type.
+
% The `is_solver_type' type specifies whether a type is a "solver" type,
% for which `any' insts are interpreted as "don't know", or a non-solver
% type for which `any' is the same as `bound(...)'.
@@ -1683,11 +1691,34 @@ equivalent_cons_ids(ConsIdA, ConsIdB) :-
---> ctor_arg(
arg_field_name :: maybe(ctor_field_name),
arg_type :: mer_type,
+ arg_width :: arg_width,
arg_context :: prog_context
).
:- type ctor_field_name == sym_name.
+ % How much space does a constructor argument occupy in the underlying
+ % representation.
+ %
+ % `full_word' indicates that an argument occupies a full word.
+ % This is the case for all arguments except some enumeration arguments.
+ %
+ % `partial_word_begin(Mask)' indicates that the argument is the first of
+ % two or more arguments which share the same word. The argument occupies
+ % the lowest bits in the word so no shifting is required. The other
+ % arguments can be masked out with the bit-mask `Mask'. The actual number
+ % of bits occupied by the argument is `int.log2(Mask)'.
+ %
+ % `partial_word_shifted(Shift, Mask)' indicates that the argument is one of
+ % the subsequent arguments which share the same word. `Shift' is the
+ % non-zero number of bits that the argument value is left-shifted by.
+ % `Mask' is the unshifted bit-mask to mask out other arguments.
+ %
+:- type arg_width
+ ---> full_word
+ ; partial_word_first(int) % mask
+ ; partial_word_shifted(int, int). % shift, mask
+
% unify_compare gives the user-defined unification and/or comparison
% predicates for a noncanonical type, if they are known. The value
% `abstract_noncanonical_type' represents a type whose definition uses
diff --git a/compiler/prog_io_type_defn.m b/compiler/prog_io_type_defn.m
index 8e4202c..66cbd71 100644
--- a/compiler/prog_io_type_defn.m
+++ b/compiler/prog_io_type_defn.m
@@ -93,7 +93,7 @@ parse_type_defn(ModuleName, VarSet, TypeDefnTerm, Attributes, Context,
Condition, Context, SeqNum, MaybeItem)
;
Name = "where",
- parse_solver_type_defn(ModuleName, VarSet,
+ parse_where_block_type_defn(ModuleName, VarSet,
HeadTerm, BeforeCondTerm, Attributes,
Condition, Context, SeqNum, MaybeItem)
)
@@ -348,7 +348,8 @@ convert_constructor_arg_list_2(ModuleName, VarSet, MaybeFieldName,
(
MaybeType = ok1(Type),
Context = get_term_context(TypeTerm),
- Arg = ctor_arg(MaybeFieldName, Type, Context),
+ % Initially every argument is assumed to occupy one word.
+ Arg = ctor_arg(MaybeFieldName, Type, full_word, Context),
MaybeTailArgs =
convert_constructor_arg_list(ModuleName, VarSet, Terms),
(
@@ -582,22 +583,20 @@ parse_eqv_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes,
%-----------------------------------------------------------------------------%
- % parse_solver_type_defn parses the definition of a solver type.
+ % Parse a type definition which consists only of a `where' block.
+ % This is either an abstract enumeration type, or a solver type.
%
-:- pred parse_solver_type_defn(module_name::in, varset::in, term::in, term::in,
- decl_attrs::in, condition::in, prog_context::in, int::in,
+:- pred parse_where_block_type_defn(module_name::in, varset::in, term::in,
+ term::in, decl_attrs::in, condition::in, prog_context::in, int::in,
maybe1(item)::out) is det.
-parse_solver_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
- Condition, Context, SeqNum, MaybeItem) :-
+parse_where_block_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm,
+ Attributes0, Condition, Context, SeqNum, MaybeItem) :-
get_is_solver_type(IsSolverType, Attributes0, Attributes),
(
IsSolverType = non_solver_type,
- Pieces = [words("Error: only solver types can be defined"),
- words("by a `where' block alone."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
+ parse_where_type_is_abstract_enum(ModuleName, VarSet, HeadTerm,
+ BodyTerm, Condition, Context, SeqNum, MaybeItem)
;
IsSolverType = solver_type,
MaybeWhere = parse_type_decl_where_term(solver_type, ModuleName,
@@ -624,6 +623,49 @@ parse_solver_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
)
).
+:- pred parse_where_type_is_abstract_enum(module_name::in, varset::in,
+ term::in, term::in, condition::in, prog_context::in, int::in,
+ maybe1(item)::out) is det.
+
+parse_where_type_is_abstract_enum(ModuleName, VarSet, HeadTerm, BodyTerm,
+ Condition, Context, SeqNum, MaybeItem) :-
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeNameParams),
+ (
+ MaybeNameParams = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeNameParams = ok2(Name, Params),
+ (
+ BodyTerm = term.functor(term.atom("type_is_abstract_enum"),
+ Args, _)
+ ->
+ (
+ Args = [Arg],
+ Arg = term.functor(integer(NumBits), [], _)
+ ->
+ varset.coerce(VarSet, TypeVarSet),
+ TypeDefn = parse_tree_abstract_type(
+ abstract_enum_type(NumBits)),
+ ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
+ TypeDefn, Condition, Context, SeqNum),
+ Item = item_type_defn(ItemTypeDefn),
+ MaybeItem = ok1(Item)
+ ;
+ Pieces = [words("Error: invalid argument for"),
+ words("type_is_abstract_enum."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: invalid"), quote("where ..."),
+ words("attributes for abstract non-solver type."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ ).
+
:- pred parse_solver_type_base(module_name::in, varset::in, term::in,
maybe(solver_type_details)::in, maybe(unify_compare)::in,
decl_attrs::in, condition::in, prog_context::in, int::in,
@@ -691,7 +733,13 @@ parse_abstract_type_defn(ModuleName, VarSet, HeadTerm, Attributes0,
;
MaybeTypeCtorAndArgs = ok2(Name, Params),
varset.coerce(VarSet, TypeVarSet),
- TypeDefn = parse_tree_abstract_type(IsSolverType),
+ (
+ IsSolverType = non_solver_type,
+ TypeDefn = parse_tree_abstract_type(abstract_type_general)
+ ;
+ IsSolverType = solver_type,
+ TypeDefn = parse_tree_abstract_type(abstract_solver_type)
+ ),
ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params, TypeDefn,
Condition, Context, SeqNum),
Item = item_type_defn(ItemTypeDefn),
diff --git a/compiler/prog_type.m b/compiler/prog_type.m
index fe4050b..8eb4d61 100644
--- a/compiler/prog_type.m
+++ b/compiler/prog_type.m
@@ -931,7 +931,7 @@ type_constructors_are_type_info(Ctors) :-
type_is_single_ctor_single_arg(Ctors, Ctor, ArgType, MaybeArgName) :-
Ctors = [SingleCtor],
SingleCtor = ctor(ExistQVars, _Constraints, Ctor,
- [ctor_arg(MaybeArgName, ArgType, _)], _Ctxt),
+ [ctor_arg(MaybeArgName, ArgType, _, _)], _Ctxt),
ExistQVars = [].
:- pred ctor_is_type_info(sym_name::in) is semidet.
diff --git a/compiler/recompilation.check.m b/compiler/recompilation.check.m
index 384dac5..500a3c2 100644
--- a/compiler/recompilation.check.m
+++ b/compiler/recompilation.check.m
@@ -1198,9 +1198,9 @@ check_functor_ambiguities(NeedQualifier, TypeCtor, Ctor, !Info) :-
constructor_arg::in,
recompilation_check_info::in, recompilation_check_info::out) is det.
-check_field_ambiguities(_, _, ctor_arg(no, _, _), !Info).
+check_field_ambiguities(_, _, ctor_arg(no, _, _, _), !Info).
check_field_ambiguities(NeedQualifier, ResolvedCtor,
- ctor_arg(yes(FieldName), _, _), !Info) :-
+ ctor_arg(yes(FieldName), _, _, _), !Info) :-
% XXX The arities to match below will need to change if we ever
% allow taking the address of field access functions.
field_access_function_name(get, FieldName, ExtractFuncName),
diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m
index f66abb8..451fc59 100644
--- a/compiler/recompilation.version.m
+++ b/compiler/recompilation.version.m
@@ -294,8 +294,10 @@ gather_items_2(Item, !Section, !Info) :-
BodyItem = Item
;
Body = parse_tree_du_type(_, _, _),
+ % XXX does the abstract_details matter here?
+ AbstractDetails = abstract_type_general,
NameItemTypeDefn = item_type_defn_info(VarSet, Name, Args,
- parse_tree_abstract_type(non_solver_type), Cond, Context,
+ parse_tree_abstract_type(AbstractDetails), Cond, Context,
SeqNum),
NameItem = item_type_defn(NameItemTypeDefn),
BodyItem = Item
diff --git a/compiler/rtti.m b/compiler/rtti.m
index ffc78e3..53881fe 100644
--- a/compiler/rtti.m
+++ b/compiler/rtti.m
@@ -400,7 +400,8 @@
:- type du_arg_info
---> du_arg_info(
du_arg_name :: maybe(string),
- du_arg_type :: rtti_maybe_pseudo_type_info_or_self
+ du_arg_type :: rtti_maybe_pseudo_type_info_or_self,
+ du_arg_width :: arg_width
).
% An rtti_maybe_pseudo_type_info identifies the type of a function
@@ -629,6 +630,7 @@
; type_ctor_exist_info(int) % functor ordinal
; type_ctor_field_names(int) % functor ordinal
; type_ctor_field_types(int) % functor ordinal
+ ; type_ctor_field_locns(int) % functor ordinal
; type_ctor_res_addrs
; type_ctor_res_addr_functors
; type_ctor_enum_functor_desc(int) % functor ordinal
@@ -792,9 +794,9 @@
%
:- func du_arg_info_type(du_arg_info) = rtti_maybe_pseudo_type_info_or_self.
- % If the given value is bound to yes, return its argument.
+ % Extract the argument width from du_arg_info.
%
-:- func project_yes(maybe(T)) = T is semidet.
+:- func du_arg_info_width(du_arg_info) = arg_width.
% Return the symbolic representation of the address of the given
% functor descriptor.
@@ -1084,6 +1086,7 @@ ctor_rtti_name_is_exported(type_ctor_exist_tc_constrs(_)) = no.
ctor_rtti_name_is_exported(type_ctor_exist_info(_)) = no.
ctor_rtti_name_is_exported(type_ctor_field_names(_)) = no.
ctor_rtti_name_is_exported(type_ctor_field_types(_)) = no.
+ctor_rtti_name_is_exported(type_ctor_field_locns(_)) = no.
ctor_rtti_name_is_exported(type_ctor_res_addrs) = no.
ctor_rtti_name_is_exported(type_ctor_res_addr_functors) = no.
ctor_rtti_name_is_exported(type_ctor_enum_functor_desc(_)) = no.
@@ -1183,6 +1186,11 @@ name_to_string(RttiTypeCtor, RttiName) = Str :-
string.append_list([ModuleName, "__field_types_",
TypeName, "_", A_str, "_", O_str], Str)
;
+ RttiName = type_ctor_field_locns(Ordinal),
+ string.int_to_string(Ordinal, O_str),
+ string.append_list([ModuleName, "__field_locns_",
+ TypeName, "_", A_str, "_", O_str], Str)
+ ;
RttiName = type_ctor_res_addrs,
string.append_list([ModuleName, "__reserved_addrs_",
TypeName, "_", A_str], Str)
@@ -1745,7 +1753,7 @@ du_arg_info_name(ArgInfo) = ArgInfo ^ du_arg_name.
du_arg_info_type(ArgInfo) = ArgInfo ^ du_arg_type.
-project_yes(yes(X)) = X.
+du_arg_info_width(ArgInfo) = ArgInfo ^ du_arg_width.
enum_functor_rtti_name(EnumFunctor) =
type_ctor_enum_functor_desc(EnumFunctor ^ enum_ordinal).
@@ -1791,6 +1799,7 @@ ctor_rtti_name_code_addr(type_ctor_exist_tc_constrs(_)) = no.
ctor_rtti_name_code_addr(type_ctor_exist_info(_)) = no.
ctor_rtti_name_code_addr(type_ctor_field_names(_)) = no.
ctor_rtti_name_code_addr(type_ctor_field_types(_)) = no.
+ctor_rtti_name_code_addr(type_ctor_field_locns(_)) = no.
ctor_rtti_name_code_addr(type_ctor_res_addrs) = no.
ctor_rtti_name_code_addr(type_ctor_res_addr_functors) = no.
ctor_rtti_name_code_addr(type_ctor_enum_functor_desc(_)) = no.
@@ -2030,6 +2039,8 @@ ctor_rtti_name_type(type_ctor_field_names(_),
"ConstString", is_array).
ctor_rtti_name_type(type_ctor_field_types(_),
"PseudoTypeInfo", is_array).
+ctor_rtti_name_type(type_ctor_field_locns(_),
+ "DuArgLocn", is_array).
ctor_rtti_name_type(type_ctor_res_addrs,
"ReservedAddr", is_array).
ctor_rtti_name_type(type_ctor_res_addr_functors,
diff --git a/compiler/rtti_out.m b/compiler/rtti_out.m
index 2d0a27a..a88a77e 100644
--- a/compiler/rtti_out.m
+++ b/compiler/rtti_out.m
@@ -114,6 +114,7 @@
:- import_module ll_backend.llds_out.llds_out_code_addr.
:- import_module ll_backend.llds_out.llds_out_data.
:- import_module ll_backend.llds_out.llds_out_file.
+:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_foreign.
:- import_module assoc_list.
@@ -874,7 +875,7 @@ output_du_functor_defn(Info, RttiTypeCtor, DuFunctor, !DeclSet, !IO) :-
ArgInfos, MaybeExistInfo),
ArgTypes = list.map(du_arg_info_type, ArgInfos),
MaybeArgNames = list.map(du_arg_info_name, ArgInfos),
- ArgNames = list.filter_map(project_yes, MaybeArgNames),
+ HaveArgNames = (list.member(yes(_), MaybeArgNames) -> yes ; no),
(
ArgInfos = [_ | _],
output_du_arg_types(Info, RttiTypeCtor, Ordinal, ArgTypes,
@@ -883,12 +884,14 @@ output_du_functor_defn(Info, RttiTypeCtor, DuFunctor, !DeclSet, !IO) :-
ArgInfos = []
),
(
- ArgNames = [_ | _],
+ HaveArgNames = yes,
output_du_arg_names(Info, RttiTypeCtor, Ordinal, MaybeArgNames,
!DeclSet, !IO)
;
- ArgNames = []
+ HaveArgNames = no
),
+ output_du_arg_locns(Info, RttiTypeCtor, Ordinal, ArgInfos,
+ HaveArgLocns, !DeclSet, !IO),
(
MaybeExistInfo = yes(ExistInfo),
output_exist_info(Info, RttiTypeCtor, Ordinal, ExistInfo,
@@ -947,11 +950,20 @@ output_du_functor_defn(Info, RttiTypeCtor, DuFunctor, !DeclSet, !IO) :-
),
io.write_string(",\n\t", !IO),
(
- ArgNames = [_ | _],
+ HaveArgNames = yes,
output_addr_of_ctor_rtti_id(RttiTypeCtor,
type_ctor_field_names(Ordinal), !IO)
;
- ArgNames = [],
+ HaveArgNames = no,
+ io.write_string("NULL", !IO)
+ ),
+ io.write_string(",\n\t", !IO),
+ (
+ HaveArgLocns = yes,
+ output_addr_of_ctor_rtti_id(RttiTypeCtor,
+ type_ctor_field_locns(Ordinal), !IO)
+ ;
+ HaveArgLocns = no,
io.write_string("NULL", !IO)
),
io.write_string(",\n\t", !IO),
@@ -1118,6 +1130,53 @@ output_du_arg_names(Info, RttiTypeCtor, Ordinal, MaybeNames, !DeclSet, !IO) :-
output_maybe_quoted_strings(MaybeNames, !IO),
io.write_string("};\n", !IO).
+:- pred output_du_arg_locns(llds_out_info::in, rtti_type_ctor::in, int::in,
+ list(du_arg_info)::in, bool::out, decl_set::in, decl_set::out,
+ io::di, io::uo) is det.
+
+output_du_arg_locns(Info, RttiTypeCtor, Ordinal, ArgInfos, HaveArgLocns,
+ !DeclSet, !IO) :-
+ (
+ list.member(ArgInfo, ArgInfos),
+ ArgInfo = du_arg_info(_, _, partial_word_first(_))
+ ->
+ output_generic_rtti_data_defn_start(Info,
+ ctor_rtti_id(RttiTypeCtor, type_ctor_field_locns(Ordinal)),
+ !DeclSet, !IO),
+ io.write_string(" = {\n", !IO),
+ output_du_arg_locns_2(ArgInfos, -1, !IO),
+ io.write_string("};\n", !IO),
+ HaveArgLocns = yes
+ ;
+ HaveArgLocns = no
+ ).
+
+:- pred output_du_arg_locns_2(list(du_arg_info)::in, int::in, io::di, io::uo)
+ is det.
+
+output_du_arg_locns_2([], _, !IO).
+output_du_arg_locns_2([ArgInfo | ArgInfos], PrevSlotNum, !IO) :-
+ ArgWidth = ArgInfo ^ du_arg_width,
+ (
+ ArgWidth = full_word,
+ % Code which examines this structure must check for Bits = 0 as a
+ % special case, meaning that the argument is not packed.
+ Shift = 0,
+ Bits = 0,
+ SlotNum = PrevSlotNum + 1
+ ;
+ ArgWidth = partial_word_first(Mask),
+ Shift = 0,
+ int.log2(Mask, Bits),
+ SlotNum = PrevSlotNum + 1
+ ;
+ ArgWidth = partial_word_shifted(Shift, Mask),
+ int.log2(Mask, Bits),
+ SlotNum = PrevSlotNum
+ ),
+ io.format("\t{ %d, %d, %d },\n", [i(SlotNum), i(Shift), i(Bits)], !IO),
+ output_du_arg_locns_2(ArgInfos, SlotNum, !IO).
+
%-----------------------------------------------------------------------------%
:- pred output_enum_value_ordered_table(llds_out_info::in, rtti_type_ctor::in,
diff --git a/compiler/rtti_to_mlds.m b/compiler/rtti_to_mlds.m
index 4d30e91..074ac16 100644
--- a/compiler/rtti_to_mlds.m
+++ b/compiler/rtti_to_mlds.m
@@ -714,7 +714,7 @@ gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData) :-
MaybeExistInfo),
ArgTypes = list.map(du_arg_info_type, ArgInfos),
MaybeArgNames = list.map(du_arg_info_name, ArgInfos),
- ArgNames = list.filter_map(project_yes, MaybeArgNames),
+ HaveArgNames = (list.member(yes(_), MaybeArgNames) -> yes ; no),
ContainsVarBitVector = compute_contains_var_bit_vector(ArgTypes),
module_info_get_name(ModuleInfo, ModuleName),
(
@@ -730,17 +730,29 @@ gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData) :-
ctor_rtti_id(RttiTypeCtor, type_ctor_field_types(0)))))
),
(
- ArgNames = [_ | _],
+ HaveArgNames = yes,
gen_field_names(ModuleInfo, RttiTypeCtor, Ordinal,
MaybeArgNames, !GlobalData),
ArgNameInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_field_names(Ordinal))
;
- ArgNames = [],
+ HaveArgNames = no,
ArgNameInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_field_names(0)))))
),
+ gen_field_locns(ModuleInfo, RttiTypeCtor, Ordinal, ArgInfos, HaveArgLocns,
+ !GlobalData),
+ (
+ HaveArgLocns = yes,
+ ArgLocnsInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
+ type_ctor_field_locns(Ordinal))
+ ;
+ HaveArgLocns = no,
+ ArgLocnsInitializer = gen_init_null_pointer(
+ mlds_rtti_type(item_type(
+ ctor_rtti_id(RttiTypeCtor, type_ctor_field_locns(0)))))
+ ),
(
MaybeExistInfo = yes(ExistInfo),
gen_exist_info(ModuleInfo, RttiTypeCtor, Ordinal, ExistInfo,
@@ -786,6 +798,7 @@ gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData) :-
gen_init_int(Ordinal),
ArgTypeInitializer,
ArgNameInitializer,
+ ArgLocnsInitializer,
ExistInfoInitializer
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
@@ -948,6 +961,55 @@ gen_field_names(_ModuleInfo, RttiTypeCtor, Ordinal, MaybeNames, !GlobalData) :-
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
+:- pred gen_field_locns(module_info::in, rtti_type_ctor::in, int::in,
+ list(du_arg_info)::in, bool::out, ml_global_data::in, ml_global_data::out)
+ is det.
+
+gen_field_locns(_ModuleInfo, RttiTypeCtor, Ordinal, ArgInfos, HaveArgLocns,
+ !GlobalData) :-
+ (
+ some [ArgInfo] (
+ list.member(ArgInfo, ArgInfos),
+ ArgInfo ^ du_arg_width \= full_word
+ )
+ ->
+ HaveArgLocns = yes,
+ RttiName = type_ctor_field_locns(Ordinal),
+ RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
+ list.map_foldl(gen_field_locn(RttiId), ArgInfos, ArgLocnInitializers,
+ -1, _Offset),
+ Initializer = init_struct(mlds_rtti_type(item_type(RttiId)),
+ ArgLocnInitializers),
+ rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData)
+ ;
+ HaveArgLocns = no
+ ).
+
+:- pred gen_field_locn(rtti_id::in, du_arg_info::in, mlds_initializer::out,
+ int::in, int::out) is det.
+
+gen_field_locn(RttiId, ArgInfo, ArgLocnInitializer, !Offset) :-
+ ArgWidth = ArgInfo ^ du_arg_width,
+ (
+ ArgWidth = full_word,
+ !:Offset = !.Offset + 1,
+ Shift = 0,
+ Bits = 0
+ ;
+ ArgWidth = partial_word_first(Mask),
+ !:Offset = !.Offset + 1,
+ Shift = 0,
+ int.log2(Mask, Bits)
+ ;
+ ArgWidth = partial_word_shifted(Shift, Mask),
+ int.log2(Mask, Bits)
+ ),
+ ArgLocnInitializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
+ gen_init_int(!.Offset),
+ gen_init_int(Shift),
+ gen_init_int(Bits)
+ ]).
+
%-----------------------------------------------------------------------------%
:- pred gen_enum_value_ordered_table(module_info::in, rtti_type_ctor::in,
diff --git a/compiler/special_pred.m b/compiler/special_pred.m
index bfd8dfc..c3be963 100644
--- a/compiler/special_pred.m
+++ b/compiler/special_pred.m
@@ -209,7 +209,7 @@ special_pred_is_generated_lazily(ModuleInfo, TypeCtor, Body, Status) :-
% appear in the symbol table.
Body \= hlds_solver_type(_, _),
- Body \= hlds_abstract_type(solver_type),
+ Body \= hlds_abstract_type(abstract_solver_type),
CtorCat = classify_type_ctor(ModuleInfo, TypeCtor),
(
diff --git a/compiler/structure_reuse.direct.choose_reuse.m b/compiler/structure_reuse.direct.choose_reuse.m
index 9f3f259..62b6ca1 100644
--- a/compiler/structure_reuse.direct.choose_reuse.m
+++ b/compiler/structure_reuse.direct.choose_reuse.m
@@ -948,7 +948,19 @@ compute_reuse_type(Background, NewVar, NewCons, NewCellArgs, DeconSpec,
DeconSpec = decon(DeadVar, _, DeadCons, DeadCellArgs, _),
ModuleInfo = Background ^ back_module_info,
- Vartypes = Background ^ back_vartypes,
+ VarTypes = Background ^ back_vartypes,
+
+ ( NewCons = DeadCons ->
+ SameCons = yes
+ ;
+ SameCons = no,
+ % XXX All the reuse code was written before packed arguments were
+ % introduced. For now only allow reuse of cells with packed fields when
+ % the dead variable and the new variable have the same constructor.
+ cons_has_no_packed_fields(ModuleInfo, NewCons),
+ cons_has_no_packed_fields(ModuleInfo, DeadCons)
+ ),
+
NewNumArgs = list.length(NewCellArgs),
DeadNumArgs = list.length(DeadCellArgs),
@@ -956,8 +968,8 @@ compute_reuse_type(Background, NewVar, NewCons, NewCellArgs, DeconSpec,
NewNumArgs \= 0,
% Include the space needed for secondary tags.
- has_secondary_tag(ModuleInfo, Vartypes, NewVar, NewCons, SecTag),
- has_secondary_tag(ModuleInfo, Vartypes, DeadVar, DeadCons, DeadSecTag),
+ has_secondary_tag(ModuleInfo, VarTypes, NewVar, NewCons, SecTag),
+ has_secondary_tag(ModuleInfo, VarTypes, DeadVar, DeadCons, DeadSecTag),
NewArity = NewNumArgs + (SecTag = yes -> 1 ; 0),
DeadArity = DeadNumArgs + (DeadSecTag = yes -> 1 ; 0),
@@ -968,7 +980,6 @@ compute_reuse_type(Background, NewVar, NewCons, NewCellArgs, DeconSpec,
% specified by the user.
Constraint = Background ^ back_strategy,
DiffArity = DeadArity - NewArity,
- ( NewCons = DeadCons -> SameCons = yes ; SameCons = no),
(
Constraint = within_n_cells_difference(N),
DiffArity =< N
@@ -997,6 +1008,38 @@ compute_reuse_type(Background, NewVar, NewCons, NewCellArgs, DeconSpec,
Weight > 0,
ReuseType = reuse_type(SameCons, ReuseFields, float(Weight)).
+:- pred cons_has_no_packed_fields(module_info::in, cons_id::in) is semidet.
+
+cons_has_no_packed_fields(ModuleInfo, Cons) :-
+ (
+ Cons = cons(_, _, TypeCtor),
+ get_cons_defn_det(ModuleInfo, TypeCtor, Cons, ConsDefn),
+ ConsArgs = ConsDefn ^ cons_args,
+ all [Arg] (
+ list.member(Arg, ConsArgs)
+ =>
+ Arg = ctor_arg(_, _, full_word, _)
+ )
+ ;
+ Cons = tuple_cons(_)
+ ;
+ ( Cons = closure_cons(_, _)
+ ; Cons = int_const(_)
+ ; Cons = float_const(_)
+ ; Cons = char_const(_)
+ ; Cons = string_const(_)
+ ; Cons = impl_defined_const(_)
+ ; Cons = type_ctor_info_const(_, _, _)
+ ; Cons = base_typeclass_info_const(_, _, _, _)
+ ; Cons = type_info_cell_constructor(_)
+ ; Cons = typeclass_info_cell_constructor
+ ; Cons = tabling_info_const(_)
+ ; Cons = table_io_decl(_)
+ ; Cons = deep_profiling_proc_layout(_)
+ ),
+ unexpected($module, $pred, "unusual cons_id")
+ ).
+
:- func glb_reuse_types(list(reuse_type)) = reuse_type is semidet.
glb_reuse_types([First|Rest]) =
diff --git a/compiler/type_constraints.m b/compiler/type_constraints.m
index a077d5f..99ba970 100644
--- a/compiler/type_constraints.m
+++ b/compiler/type_constraints.m
@@ -2204,7 +2204,7 @@ get_case_goal(Case, Case ^ case_goal).
:- pred get_ctor_arg_type(constructor_arg::in, mer_type::out) is det.
-get_ctor_arg_type(ctor_arg(_, Type, _), Type).
+get_ctor_arg_type(ctor_arg(_, Type, _, _), Type).
:- func tvar_to_type(tvar) = mer_type.
diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m
index 02100c9..b7f91b7 100644
--- a/compiler/type_ctor_info.m
+++ b/compiler/type_ctor_info.m
@@ -220,7 +220,7 @@ builtin_type_defn = TypeDefn :-
varset.init(TVarSet),
Params = [],
map.init(Kinds),
- Body = hlds_abstract_type(non_solver_type),
+ Body = hlds_abstract_type(abstract_type_general),
ImportStatus = status_local,
NeedQualifier = may_be_unqualified,
term.context_init(Context),
@@ -487,7 +487,7 @@ impl_type_ctor("table_builtin", "ml_subgoal", 0, impl_ctor_subgoal).
%
:- func type_ctor_info_rtti_version = int.
-type_ctor_info_rtti_version = 14.
+type_ctor_info_rtti_version = 15.
% 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
@@ -898,7 +898,7 @@ get_maybe_reserved_rep(ConsTag, ConsRep) :-
du_arg_info::out) is det.
generate_du_arg_info(NumUnivTvars, ExistTvars, ConstructorArg, ArgInfo) :-
- ConstructorArg = ctor_arg(MaybeArgSymName, ArgType, _Ctxt),
+ ConstructorArg = ctor_arg(MaybeArgSymName, ArgType, ArgWidth, _Ctxt),
(
MaybeArgSymName = yes(SymName),
ArgName = unqualify_name(SymName),
@@ -918,7 +918,7 @@ generate_du_arg_info(NumUnivTvars, ExistTvars, ConstructorArg, ArgInfo) :-
MaybePseudoTypeInfo = pseudo(PseudoTypeInfo),
MaybePseudoTypeInfoOrSelf = pseudo(PseudoTypeInfo)
),
- ArgInfo = du_arg_info(MaybeArgName, MaybePseudoTypeInfoOrSelf).
+ ArgInfo = du_arg_info(MaybeArgName, MaybePseudoTypeInfoOrSelf, ArgWidth).
% This function gives the size of the MR_du_functor_arg_type_contains_var
% field of the C type MR_DuFunctorDesc in bits.
diff --git a/compiler/type_util.m b/compiler/type_util.m
index c193b30..34dec87 100644
--- a/compiler/type_util.m
+++ b/compiler/type_util.m
@@ -547,7 +547,7 @@ type_is_solver_type_with_auto_init(ModuleInfo, Type) :-
% problem. (In the event that we do re-add some form of support for
% automatic solver initialisation then we will need to make sure
% that this information ends up in interface files somehow.)
- TypeBody = hlds_abstract_type(solver_type),
+ TypeBody = hlds_abstract_type(abstract_solver_type),
fail
;
TypeBody = hlds_eqv_type(ActualType)
@@ -563,7 +563,7 @@ type_is_solver_type(ModuleInfo, Type) :-
(
TypeBody = hlds_solver_type(_, _)
;
- TypeBody = hlds_abstract_type(solver_type)
+ TypeBody = hlds_abstract_type(abstract_solver_type)
;
TypeBody = hlds_eqv_type(EqvType),
type_is_solver_type(ModuleInfo, EqvType)
@@ -601,7 +601,7 @@ type_body_is_solver_type(ModuleInfo, TypeBody) :-
(
TypeBody = hlds_solver_type(_, _)
;
- TypeBody = hlds_abstract_type(solver_type)
+ TypeBody = hlds_abstract_type(abstract_solver_type)
;
TypeBody = hlds_eqv_type(Type),
is_solver_type(ModuleInfo, Type)
@@ -779,40 +779,10 @@ classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
module_info_get_type_table(ModuleInfo, TypeTable),
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- (
- TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _, _),
- (
- DuTypeKind = du_type_kind_mercury_enum,
- TypeCategory = ctor_cat_enum(cat_enum_mercury)
- ;
- DuTypeKind = du_type_kind_foreign_enum(_),
- TypeCategory = ctor_cat_enum(cat_enum_foreign)
- ;
- DuTypeKind = du_type_kind_direct_dummy,
- TypeCategory = ctor_cat_user(cat_user_direct_dummy)
- ;
- DuTypeKind = du_type_kind_notag(_, _, _),
- TypeCategory = ctor_cat_user(cat_user_notag)
- ;
- DuTypeKind = du_type_kind_general,
- TypeCategory = ctor_cat_user(cat_user_general)
- )
- ;
- % XXX We should be able to return more precise descriptions
- % than this.
- ( TypeBody = hlds_eqv_type(_)
- ; TypeBody = hlds_foreign_type(_)
- ; TypeBody = hlds_solver_type(_, _)
- ; TypeBody = hlds_abstract_type(_)
- ),
- TypeCategory = ctor_cat_user(cat_user_general)
- )
+ TypeCategory = classify_type_defn_body(TypeBody)
).
classify_type_defn_body(TypeBody) = TypeCategory :-
- % Please keep the code of this predicate in sync with the code of
- % classify_type_ctor.
- %
% Unlike classify_type_ctor, we don't have to (a) test for types that do
% not have definitions, or (b) look up the definition, since our caller has
% already done that.
@@ -841,7 +811,9 @@ classify_type_defn_body(TypeBody) = TypeCategory :-
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_, _)
- ; TypeBody = hlds_abstract_type(_)
+ ; TypeBody = hlds_abstract_type(abstract_type_general)
+ ; TypeBody = hlds_abstract_type(abstract_enum_type(_))
+ ; TypeBody = hlds_abstract_type(abstract_solver_type)
),
TypeCategory = ctor_cat_user(cat_user_general)
).
@@ -902,7 +874,8 @@ type_constructors(ModuleInfo, Type, Constructors) :-
ClassConstraints = [],
Context = term.context_init,
CtorArgs = list.map(
- (func(ArgType) = ctor_arg(no, ArgType, Context)), TypeArgs),
+ (func(ArgType) = ctor_arg(no, ArgType, full_word, Context)),
+ TypeArgs),
Constructors = [ctor(ExistQVars, ClassConstraints, unqualified("{}"),
CtorArgs, Context)]
;
diff --git a/compiler/unify_gen.m b/compiler/unify_gen.m
index e986cd0..9c0215e 100644
--- a/compiler/unify_gen.m
+++ b/compiler/unify_gen.m
@@ -56,6 +56,7 @@
:- implementation.
+:- import_module backend_libs.arg_pack.
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.proc_label.
:- import_module backend_libs.rtti.
@@ -92,12 +93,26 @@
:- import_module set.
:- import_module string.
:- import_module term.
+:- import_module unit.
%---------------------------------------------------------------------------%
:- type uni_val
---> ref(prog_var)
- ; lval(lval).
+ ; lval(lval, arg_width).
+ % The argument may only occupy part of a word.
+
+ % The phantom type prevents us from mixing field_addrs which are computed
+ % with and without consideration for argument packing.
+ %
+:- type field_addr(T)
+ ---> field_addr(
+ fa_num :: int,
+ fa_var :: prog_var
+ ).
+
+:- type unpacked ---> unpacked.
+:- type packed ---> packed.
%---------------------------------------------------------------------------%
@@ -137,17 +152,25 @@ generate_unification(CodeModel, Uni, GoalInfo, Code, !CI) :-
MaybeTakeAddr = no,
TakeAddr = []
),
- generate_construction(Var, ConsId, Args, Modes, HowToConstruct,
- TakeAddr, MaybeSize, GoalInfo, Code, !CI)
+ get_module_info(!.CI, ModuleInfo),
+ get_cons_arg_widths(ModuleInfo, ConsId, Args, ConsArgWidths),
+ generate_construction(Var, ConsId, Args, Modes, ConsArgWidths,
+ HowToConstruct, TakeAddr, MaybeSize, GoalInfo, Code, !CI)
;
Code = empty
)
;
Uni = deconstruct(Var, ConsId, Args, Modes, _CanFail, CanCGC),
- ( CodeModel = model_det ->
- generate_det_deconstruction(Var, ConsId, Args, Modes, Code0, !CI)
+ get_module_info(!.CI, ModuleInfo),
+ get_cons_arg_widths(ModuleInfo, ConsId, Args, ConsArgWidths),
+ (
+ CodeModel = model_det,
+ generate_det_deconstruction(Var, ConsId, Args, Modes,
+ ConsArgWidths, Code0, !CI)
;
- generate_semi_deconstruction(Var, ConsId, Args, Modes, Code0, !CI)
+ CodeModel = model_semi,
+ generate_semi_deconstruction(Var, ConsId, Args, Modes,
+ ConsArgWidths, Code0, !CI)
),
(
CanCGC = can_cgc,
@@ -184,6 +207,31 @@ generate_unification(CodeModel, Uni, GoalInfo, Code, !CI) :-
unexpected($module, $pred, "complicated unify")
).
+:- pred get_cons_arg_widths(module_info::in, cons_id::in,
+ list(prog_var)::in, list(arg_width)::out) is det.
+
+get_cons_arg_widths(ModuleInfo, ConsId, Args, AllArgWidths) :-
+ (
+ ConsId = cons(_, _, TypeCtor),
+ get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
+ ->
+ ConsArgs = ConsDefn ^ cons_args,
+ ArgWidths = list.map((func(C) = C ^ arg_width), ConsArgs),
+ list.length(Args, NumArgs),
+ list.length(ConsArgs, NumConsArgs),
+ NumExtraArgs = NumArgs - NumConsArgs,
+ ( NumExtraArgs = 0 ->
+ AllArgWidths = ArgWidths
+ ; NumExtraArgs > 0 ->
+ ExtraArgWidths = list.duplicate(NumExtraArgs, full_word),
+ AllArgWidths = ExtraArgWidths ++ ArgWidths
+ ;
+ unexpected($module, $pred, "too few arguments")
+ )
+ ;
+ AllArgWidths = list.duplicate(length(Args), full_word)
+ ).
+
%---------------------------------------------------------------------------%
% Assignment unifications are generated by simply caching the bound
@@ -448,23 +496,25 @@ generate_reserved_address(reserved_object(_, _, _)) = _ :-
% instantiate the arguments of that term.
%
:- pred generate_construction(prog_var::in, cons_id::in,
- list(prog_var)::in, list(uni_mode)::in, how_to_construct::in,
+ list(prog_var)::in, list(uni_mode)::in, list(arg_width)::in,
+ how_to_construct::in,
list(int)::in, maybe(term_size_value)::in, hlds_goal_info::in,
llds_code::out, code_info::in, code_info::out) is det.
-generate_construction(Var, ConsId, Args, Modes, HowToConstruct,
+generate_construction(Var, ConsId, Args, Modes, ArgWidths, HowToConstruct,
TakeAddr, MaybeSize, GoalInfo, Code, !CI) :-
get_module_info(!.CI, ModuleInfo),
Tag = cons_id_to_tag(ModuleInfo, ConsId),
- generate_construction_2(Tag, Var, Args, Modes, HowToConstruct,
+ generate_construction_2(Tag, Var, Args, Modes, ArgWidths, HowToConstruct,
TakeAddr, MaybeSize, GoalInfo, Code, !CI).
:- pred generate_construction_2(cons_tag::in, prog_var::in,
- list(prog_var)::in, list(uni_mode)::in, how_to_construct::in,
+ list(prog_var)::in, list(uni_mode)::in, list(arg_width)::in,
+ how_to_construct::in,
list(int)::in, maybe(term_size_value)::in, hlds_goal_info::in,
llds_code::out, code_info::in, code_info::out) is det.
-generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct,
+generate_construction_2(ConsTag, Var, Args, Modes, ArgWidths, HowToConstruct0,
TakeAddr, MaybeSize, GoalInfo, Code, !CI) :-
(
ConsTag = string_tag(String),
@@ -511,11 +561,17 @@ generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct,
ConsTag = unshared_tag(Ptag)
),
var_types(!.CI, Args, ArgTypes),
- generate_cons_args(Args, ArgTypes, Modes, 0, 1, TakeAddr, !.CI,
- MaybeRvals, FieldAddrs, MayUseAtomic),
+ FirstOffset = 0,
+ generate_cons_args(Args, ArgTypes, Modes, FirstOffset, TakeAddr, !.CI,
+ MaybeRvals0, FieldAddrs0, MayUseAtomic),
+ pack_cell_rvals(ArgWidths, MaybeRvals0, MaybeRvals, AllFilled,
+ PackCode, !CI),
+ pack_field_addrs(ArgWidths, FieldAddrs0, FieldAddrs),
+ pack_how_to_construct(ArgWidths, HowToConstruct0, HowToConstruct),
Context = goal_info_get_context(GoalInfo),
- construct_cell(Var, Ptag, MaybeRvals, HowToConstruct,
- MaybeSize, FieldAddrs, Context, MayUseAtomic, Code, !CI)
+ construct_cell(Var, Ptag, MaybeRvals, AllFilled, HowToConstruct,
+ MaybeSize, FieldAddrs, Context, MayUseAtomic, ConstructCode, !CI),
+ Code = PackCode ++ ConstructCode
;
ConsTag = direct_arg_tag(Ptag),
(
@@ -537,13 +593,19 @@ generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct,
;
ConsTag = shared_remote_tag(Ptag, Sectag),
var_types(!.CI, Args, ArgTypes),
- generate_cons_args(Args, ArgTypes, Modes, 1, 1, TakeAddr, !.CI,
- MaybeRvals0, FieldAddrs, MayUseAtomic),
% The first field holds the secondary tag.
- MaybeRvals = [yes(const(llconst_int(Sectag))) | MaybeRvals0],
+ FirstOffset = 1,
+ generate_cons_args(Args, ArgTypes, Modes, FirstOffset, TakeAddr, !.CI,
+ MaybeRvals0, FieldAddrs0, MayUseAtomic),
+ pack_cell_rvals(ArgWidths, MaybeRvals0, MaybeRvals1, AllFilled,
+ PackCode, !CI),
+ pack_field_addrs(ArgWidths, FieldAddrs0, FieldAddrs),
+ pack_how_to_construct(ArgWidths, HowToConstruct0, HowToConstruct),
+ MaybeRvals = [yes(const(llconst_int(Sectag))) | MaybeRvals1],
Context = goal_info_get_context(GoalInfo),
- construct_cell(Var, Ptag, MaybeRvals, HowToConstruct,
- MaybeSize, FieldAddrs, Context, MayUseAtomic, Code, !CI)
+ construct_cell(Var, Ptag, MaybeRvals, AllFilled, HowToConstruct,
+ MaybeSize, FieldAddrs, Context, MayUseAtomic, ConstructCode, !CI),
+ Code = PackCode ++ ConstructCode
;
ConsTag = shared_local_tag(Ptag, Sectag),
assign_const_to_var(Var,
@@ -611,8 +673,8 @@ generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct,
% For shared_with_reserved_address, the sharing is only important
% for tag tests, not for constructions, so here we just recurse
% on the real representation.
- generate_construction_2(ThisTag, Var, Args, Modes, HowToConstruct,
- TakeAddr, MaybeSize, GoalInfo, Code, !CI)
+ generate_construction_2(ThisTag, Var, Args, Modes, ArgWidths,
+ HowToConstruct0, TakeAddr, MaybeSize, GoalInfo, Code, !CI)
;
ConsTag = closure_tag(PredId, ProcId, EvalMethod),
expect(unify(TakeAddr, []), $module, $pred,
@@ -807,12 +869,15 @@ generate_closure(PredId, ProcId, EvalMethod, Var, Args, GoalInfo, Code, !CI) :-
yes(const(llconst_int(NumArgs)))
| PredArgs
],
+ AllFilled = yes,
% XXX construct_dynamically is just a dummy value. We just want
% something which is not construct_in_region(_).
+ HowToConstruct = construct_dynamically,
+ MaybeSize = no,
maybe_add_alloc_site_info(Context, "closure", length(Vector),
MaybeAllocId, !CI),
- assign_cell_to_var(Var, no, 0, Vector, construct_dynamically, no, [],
- MaybeAllocId, MayUseAtomic, Code, !CI)
+ assign_cell_to_var(Var, no, 0, Vector, AllFilled, HowToConstruct,
+ MaybeSize, [], MaybeAllocId, MayUseAtomic, Code, !CI)
).
:- pred generate_extra_closure_args(list(prog_var)::in, lval::in,
@@ -880,15 +945,16 @@ generate_pred_args(CI, VarTypes, [Var | Vars], [ArgInfo | ArgInfos],
!MayUseAtomic).
:- pred generate_cons_args(list(prog_var)::in, list(mer_type)::in,
- list(uni_mode)::in, int::in, int::in, list(int)::in, code_info::in,
- list(maybe(rval))::out, assoc_list(int, prog_var)::out,
+ list(uni_mode)::in, int::in, list(int)::in, code_info::in,
+ list(maybe(rval))::out, list(field_addr(unpacked))::out,
may_use_atomic_alloc::out) is det.
-generate_cons_args(Vars, Types, Modes, FirstOffset, FirstArgNum, TakeAddr,
- CI, !:Args, !:FieldAddrs, !:MayUseAtomic) :-
+generate_cons_args(Vars, Types, Modes, FirstOffset, TakeAddr, CI,
+ !:Args, !:FieldAddrs, !:MayUseAtomic) :-
get_module_info(CI, ModuleInfo),
!:MayUseAtomic = initial_may_use_atomic(ModuleInfo),
(
+ FirstArgNum = 1,
generate_cons_args_2(Vars, Types, Modes, FirstOffset, FirstArgNum,
TakeAddr, CI, !:Args, !:FieldAddrs, !MayUseAtomic)
->
@@ -904,7 +970,7 @@ generate_cons_args(Vars, Types, Modes, FirstOffset, FirstArgNum, TakeAddr,
%
:- pred generate_cons_args_2(list(prog_var)::in, list(mer_type)::in,
list(uni_mode)::in, int::in, int::in, list(int)::in, code_info::in,
- list(maybe(rval))::out, assoc_list(int, prog_var)::out,
+ list(maybe(rval))::out, list(field_addr(unpacked))::out,
may_use_atomic_alloc::in, may_use_atomic_alloc::out) is semidet.
generate_cons_args_2([], [], [], _, _, [], _, [], [], !MayUseAtomic).
@@ -927,9 +993,10 @@ generate_cons_args_2([Var | Vars], [Type | Types], [UniMode | UniModes],
!.TakeAddr, CI, MaybeRvals, FieldAddrs1, !MayUseAtomic),
% Whereas CurArgNum starts numbering the arguments from 1, offsets
% into fields start from zero. However, if FirstOffset = 1, then the
- % first word in the cell is the secondary tag.
+ % first word in the cell is the secondary tag. This offset calculation
+ % does not consider field packing; that is done subsequently.
Offset = CurArgNum - 1 + FirstOffset,
- FieldAddrs = [Offset - Var | FieldAddrs1]
+ FieldAddrs = [field_addr(Offset, Var) | FieldAddrs1]
;
UniMode = ((_LI - RI) -> (_LF - RF)),
mode_to_arg_mode(ModuleInfo, (RI -> RF), Type, ArgMode),
@@ -959,13 +1026,69 @@ initial_may_use_atomic(ModuleInfo) = InitMayUseAtomic :-
InitMayUseAtomic = may_use_atomic_alloc
).
-:- pred construct_cell(prog_var::in, tag::in, list(maybe(rval))::in,
+:- pred pack_cell_rvals(list(arg_width)::in,
+ list(maybe(rval))::in, list(maybe(rval))::out, bool::out,
+ llds_code::out, code_info::in, code_info::out) is det.
+
+pack_cell_rvals(ArgWidths, Rvals0, Rvals, AllFilled, Code, !CI) :-
+ % Check whether all arguments are filled in. This has to be done on the
+ % unpacked rvals list.
+ AllFilled = (list.contains(Rvals0, no) -> no ; yes),
+ pack_args(shift_combine_arg, ArgWidths, Rvals0, Rvals, empty, Code, !CI).
+
+:- pred pack_field_addrs(list(arg_width)::in,
+ list(field_addr(unpacked))::in, list(field_addr(packed))::out) is det.
+
+pack_field_addrs(ArgWidths, FieldAddrs0, FieldAddrs) :-
+ list.map(pack_field_addr(ArgWidths), FieldAddrs0, FieldAddrs).
+
+:- pred pack_field_addr(list(arg_width)::in,
+ field_addr(unpacked)::in, field_addr(packed)::out) is det.
+
+pack_field_addr(ArgWidths, field_addr(Num0, Var), field_addr(Num, Var)) :-
+ ( list.take(Num0, ArgWidths, ArgWidthsToVar) ->
+ Num = count_distinct_words(ArgWidthsToVar)
+ ;
+ unexpected($module, $pred, "more fields than arg_widths")
+ ).
+
+:- pred pack_how_to_construct(list(arg_width)::in,
+ how_to_construct::in, how_to_construct::out) is det.
+
+pack_how_to_construct(ArgWidths, !HowToConstruct) :-
+ (
+ !.HowToConstruct = construct_statically
+ ;
+ !.HowToConstruct = construct_dynamically
+ ;
+ !.HowToConstruct = construct_in_region(_)
+ ;
+ !.HowToConstruct = reuse_cell(CellToReuse0),
+ % If an argument within a packed field needs updating,
+ % the field needs updating.
+ CellToReuse0 = cell_to_reuse(Var, ConsIds, NeedsUpdates0),
+ chunk_list_by_words(ArgWidths, NeedsUpdates0, NeedsUpdates1),
+ list.map(condense_needs_updates, NeedsUpdates1) = NeedsUpdates,
+ CellToReuse = cell_to_reuse(Var, ConsIds, NeedsUpdates),
+ !:HowToConstruct = reuse_cell(CellToReuse)
+ ).
+
+:- func condense_needs_updates(list(needs_update)) = needs_update.
+
+condense_needs_updates(NeedsUpdatess) =
+ ( list.member(needs_update, NeedsUpdatess) ->
+ needs_update
+ ;
+ does_not_need_update
+ ).
+
+:- pred construct_cell(prog_var::in, tag::in, list(maybe(rval))::in, bool::in,
how_to_construct::in, maybe(term_size_value)::in,
- assoc_list(int, prog_var)::in, prog_context::in, may_use_atomic_alloc::in,
+ list(field_addr(packed))::in, prog_context::in, may_use_atomic_alloc::in,
llds_code::out, code_info::in, code_info::out) is det.
-construct_cell(Var, Ptag, MaybeRvals, HowToConstruct, MaybeSize, FieldAddrs,
- Context, MayUseAtomic, Code, !CI) :-
+construct_cell(Var, Ptag, MaybeRvals, AllFilled, HowToConstruct, MaybeSize,
+ FieldAddrs, Context, MayUseAtomic, Code, !CI) :-
VarType = variable_type(!.CI, Var),
var_type_msg(VarType, VarTypeMsg),
% If we're doing accurate GC, then for types which hold RTTI that
@@ -984,10 +1107,10 @@ construct_cell(Var, Ptag, MaybeRvals, HowToConstruct, MaybeSize, FieldAddrs,
;
ReserveWordAtStart = no
),
- FieldNums = list.map(fst, FieldAddrs),
+ FieldNums = list.map(get_field_num, FieldAddrs),
Size = list.length(MaybeRvals),
maybe_add_alloc_site_info(Context, VarTypeMsg, Size, MaybeAllocId, !CI),
- assign_cell_to_var(Var, ReserveWordAtStart, Ptag, MaybeRvals,
+ assign_cell_to_var(Var, ReserveWordAtStart, Ptag, MaybeRvals, AllFilled,
HowToConstruct, MaybeSize, FieldNums, MaybeAllocId, MayUseAtomic,
CellCode, !CI),
(
@@ -1004,6 +1127,10 @@ construct_cell(Var, Ptag, MaybeRvals, HowToConstruct, MaybeSize, FieldAddrs,
Code = CellCode ++ FieldCode
).
+:- func get_field_num(field_addr(packed)) = int.
+
+get_field_num(field_addr(Num, _Var)) = Num.
+
:- pred maybe_add_alloc_site_info(prog_context::in, string::in, int::in,
maybe(alloc_site_id)::out, code_info::in, code_info::out) is det.
@@ -1019,13 +1146,14 @@ maybe_add_alloc_site_info(Context, VarTypeMsg, Size, MaybeAllocId, !CI) :-
MaybeAllocId = no
).
-:- pred generate_field_take_address_assigns(assoc_list(int, prog_var)::in,
+:- pred generate_field_take_address_assigns(list(field_addr(packed))::in,
prog_var::in, int::in, llds_code::out, code_info::in, code_info::out)
is det.
generate_field_take_address_assigns([], _, _, empty, !CI).
-generate_field_take_address_assigns([FieldNum - Var | FieldAddrs],
+generate_field_take_address_assigns([FieldAddr | FieldAddrs],
CellVar, CellPtag, ThisCode ++ RestCode, !CI) :-
+ FieldAddr = field_addr(FieldNum, Var),
FieldNumRval = const(llconst_int(FieldNum)),
Addr = mem_addr(heap_ref(var(CellVar), CellPtag, FieldNumRval)),
assign_expr_to_var(Var, Addr, ThisCode, !CI),
@@ -1047,16 +1175,28 @@ var_types(CI, Vars, Types) :-
% Construct a pair of lists that associates the fields of a term
% with variables.
%
-:- pred make_fields_and_argvars(list(prog_var)::in, rval::in,
- int::in, int::in, list(uni_val)::out, list(uni_val)::out) is det.
+:- pred make_fields_and_argvars(list(prog_var)::in, list(arg_width)::in,
+ rval::in, int::in, int::in, list(uni_val)::out, list(uni_val)::out) is det.
-make_fields_and_argvars([], _, _, _, [], []).
-make_fields_and_argvars([Var | Vars], Rval, Field0, TagNum,
- [F | Fs], [A | As]) :-
- F = lval(field(yes(TagNum), Rval, const(llconst_int(Field0)))),
+make_fields_and_argvars([], [], _, _, _, [], []).
+make_fields_and_argvars([Var | Vars], [Width | Widths], Rval, PrevOffset,
+ TagNum, [F | Fs], [A | As]) :-
+ (
+ ( Width = full_word
+ ; Width = partial_word_first(_Mask)
+ ),
+ Offset = PrevOffset + 1
+ ;
+ Width = partial_word_shifted(_Shift, _Mask),
+ Offset = PrevOffset
+ ),
+ F = lval(field(yes(TagNum), Rval, const(llconst_int(Offset))), Width),
A = ref(Var),
- Field1 = Field0 + 1,
- make_fields_and_argvars(Vars, Rval, Field1, TagNum, Fs, As).
+ make_fields_and_argvars(Vars, Widths, Rval, Offset, TagNum, Fs, As).
+make_fields_and_argvars([], [_ | _], _, _, _, _, _) :-
+ unexpected($module, $pred, "mismatched lists").
+make_fields_and_argvars([_ | _], [], _, _, _, _, _) :-
+ unexpected($module, $pred, "mismatched lists").
%---------------------------------------------------------------------------%
@@ -1069,19 +1209,21 @@ make_fields_and_argvars([Var | Vars], Rval, Field0, TagNum,
% are cached.
%
:- pred generate_det_deconstruction(prog_var::in, cons_id::in,
- list(prog_var)::in, list(uni_mode)::in, llds_code::out,
- code_info::in, code_info::out) is det.
+ list(prog_var)::in, list(uni_mode)::in, list(arg_width)::in,
+ llds_code::out, code_info::in, code_info::out) is det.
-generate_det_deconstruction(Var, Cons, Args, Modes, Code, !CI) :-
+generate_det_deconstruction(Var, Cons, Args, Modes, ArgWidths, Code, !CI) :-
get_module_info(!.CI, ModuleInfo),
Tag = cons_id_to_tag(ModuleInfo, Cons),
- generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI).
+ generate_det_deconstruction_2(Var, Cons, Args, Modes, ArgWidths, Tag,
+ Code, !CI).
:- pred generate_det_deconstruction_2(prog_var::in, cons_id::in,
- list(prog_var)::in, list(uni_mode)::in, cons_tag::in,
+ list(prog_var)::in, list(uni_mode)::in, list(arg_width)::in, cons_tag::in,
llds_code::out, code_info::in, code_info::out) is det.
-generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
+generate_det_deconstruction_2(Var, Cons, Args, Modes, ArgWidths, Tag,
+ Code, !CI) :-
% For constants, if the deconstruction is det, then we already know
% the value of the constant, so Code = empty.
(
@@ -1105,7 +1247,8 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
Tag = no_tag,
(
Args = [Arg],
- Modes = [Mode]
+ Modes = [Mode],
+ ArgWidths = [_ArgWidth]
->
VarType = variable_type(!.CI, Var),
get_module_info(!.CI, ModuleInfo),
@@ -1128,8 +1271,8 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
;
IsDummy = is_not_dummy_type,
ArgType = variable_type(!.CI, Arg),
- generate_sub_unify(ref(Var), ref(Arg), Mode, ArgType, Code,
- !CI)
+ generate_sub_unify(ref(Var), ref(Arg), Mode, ArgType,
+ Code, !CI)
)
;
unexpected($module, $pred, "no_tag: arity != 1")
@@ -1137,19 +1280,20 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
;
Tag = single_functor_tag,
% Treat single_functor the same as unshared_tag(0).
- generate_det_deconstruction_2(Var, Cons, Args, Modes, unshared_tag(0),
- Code, !CI)
+ generate_det_deconstruction_2(Var, Cons, Args, Modes, ArgWidths,
+ unshared_tag(0), Code, !CI)
;
Tag = unshared_tag(Ptag),
Rval = var(Var),
- make_fields_and_argvars(Args, Rval, 0, Ptag, Fields, ArgVars),
+ make_fields_and_argvars(Args, ArgWidths, Rval, -1, Ptag, Fields, ArgVars),
var_types(!.CI, Args, ArgTypes),
generate_unify_args(Fields, ArgVars, Modes, ArgTypes, Code, !CI)
;
Tag = direct_arg_tag(Ptag),
(
Args = [Arg],
- Modes = [Mode]
+ Modes = [Mode],
+ ArgWidths = [_]
->
Type = variable_type(!.CI, Arg),
generate_direct_arg_deconstruct(Var, Arg, Ptag, Mode, Type, Code,
@@ -1160,7 +1304,7 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
;
Tag = shared_remote_tag(Ptag, _Sectag1),
Rval = var(Var),
- make_fields_and_argvars(Args, Rval, 1, Ptag, Fields, ArgVars),
+ make_fields_and_argvars(Args, ArgWidths, Rval, 0, Ptag, Fields, ArgVars),
var_types(!.CI, Args, ArgTypes),
generate_unify_args(Fields, ArgVars, Modes, ArgTypes, Code, !CI)
;
@@ -1168,8 +1312,8 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
% for tag tests, not for det deconstructions, so here we just recurse
% on the real representation.
Tag = shared_with_reserved_addresses_tag(_RAs, ThisTag),
- generate_det_deconstruction_2(Var, Cons, Args, Modes, ThisTag, Code,
- !CI)
+ generate_det_deconstruction_2(Var, Cons, Args, Modes, ArgWidths,
+ ThisTag, Code, !CI)
).
%---------------------------------------------------------------------------%
@@ -1179,10 +1323,10 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :-
% followed by a deterministic deconstruction.
%
:- pred generate_semi_deconstruction(prog_var::in, cons_id::in,
- list(prog_var)::in, list(uni_mode)::in, llds_code::out,
- code_info::in, code_info::out) is det.
+ list(prog_var)::in, list(uni_mode)::in, list(arg_width)::in,
+ llds_code::out, code_info::in, code_info::out) is det.
-generate_semi_deconstruction(Var, Tag, Args, Modes, Code, !CI) :-
+generate_semi_deconstruction(Var, Tag, Args, Modes, ArgWidths, Code, !CI) :-
VarType = variable_type(!.CI, Var),
CheaperTagTest = lookup_cheaper_tag_test(!.CI, VarType),
generate_tag_test(Var, Tag, CheaperTagTest, branch_on_success, SuccLabel,
@@ -1190,7 +1334,8 @@ generate_semi_deconstruction(Var, Tag, Args, Modes, Code, !CI) :-
remember_position(!.CI, AfterUnify),
generate_failure(FailCode, !CI),
reset_to_position(AfterUnify, !CI),
- generate_det_deconstruction(Var, Tag, Args, Modes, DeconsCode, !CI),
+ generate_det_deconstruction(Var, Tag, Args, Modes, ArgWidths, DeconsCode,
+ !CI),
SuccessLabelCode = singleton(llds_instr(label(SuccLabel), "")),
Code = TagTestCode ++ FailCode ++ SuccessLabelCode ++ DeconsCode.
@@ -1269,26 +1414,56 @@ generate_sub_unify(L, R, Mode, Type, Code, !CI) :-
generate_sub_assign(Left, Right, Code, !CI) :-
(
- Left = lval(_Lval),
- Right = lval(_Rval),
+ Left = lval(_Lval, _),
+ Right = lval(_Rval, _),
% Assignment between two lvalues - cannot happen.
unexpected($module, $pred, "lval/lval")
;
- Left = lval(Lval0),
+ Left = lval(Lval0, LeftWidth),
Right = ref(Var),
% Assignment from a variable to an lvalue - cannot cache
% so generate immediately.
produce_variable(Var, SourceCode, Source, !CI),
materialize_vars_in_lval(Lval0, Lval, MaterializeCode, !CI),
- CopyCode = singleton(llds_instr(assign(Lval, Source), "Copy value")),
- Code = SourceCode ++ MaterializeCode ++ CopyCode
+ (
+ LeftWidth = full_word,
+ AssignCode = singleton(llds_instr(assign(Lval, Source),
+ "Copy value"))
+ ;
+ (
+ LeftWidth = partial_word_first(Mask),
+ Shift = 0
+ ;
+ LeftWidth = partial_word_shifted(Shift, Mask)
+ ),
+ ComplementMask = const(llconst_int(\(Mask << Shift))),
+ MaskOld = binop(bitwise_and, lval(Lval), ComplementMask),
+ ShiftNew = maybe_left_shift_rval(Source, Shift),
+ Combined = binop(bitwise_or, MaskOld, ShiftNew),
+ AssignCode = singleton(llds_instr(assign(Lval, Combined),
+ "Update part of word"))
+ ),
+ Code = SourceCode ++ MaterializeCode ++ AssignCode
;
Left = ref(Lvar),
( variable_is_forward_live(!.CI, Lvar) ->
(
- Right = lval(Lval),
+ Right = lval(Lval, RightWidth),
% Assignment of a value to a variable, generate now.
- assign_lval_to_var(Lvar, Lval, Code, !CI)
+ (
+ RightWidth = full_word,
+ assign_lval_to_var(Lvar, Lval, Code, !CI)
+ ;
+ (
+ RightWidth = partial_word_first(Mask),
+ Rval0 = lval(Lval)
+ ;
+ RightWidth = partial_word_shifted(Shift, Mask),
+ Rval0 = right_shift_rval(lval(Lval), Shift)
+ ),
+ Rval = binop(bitwise_and, Rval0, const(llconst_int(Mask))),
+ assign_field_lval_expr_to_var(Lvar, Lval, Rval, Code, !CI)
+ )
;
Right = ref(Rvar),
% Assignment of a variable to a variable, so cache it.
@@ -1470,19 +1645,20 @@ generate_ground_term_conjunct(ModuleInfo, Goal, UnboxedFloats,
SubInfo = no_construct_sub_info
->
ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
- generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
- !StaticCellInfo, !ActiveMap)
+ get_cons_arg_widths(ModuleInfo, ConsId, Args, ConsArgWidths),
+ generate_ground_term_conjunct_tag(Var, ConsTag, Args, ConsArgWidths,
+ UnboxedFloats, !StaticCellInfo, !ActiveMap)
;
unexpected($module, $pred, "malformed goal")
).
:- pred generate_ground_term_conjunct_tag(prog_var::in, cons_tag::in,
- list(prog_var)::in, have_unboxed_floats::in,
+ list(prog_var)::in, list(arg_width)::in, have_unboxed_floats::in,
static_cell_info::in, static_cell_info::out,
active_ground_term_map::in, active_ground_term_map::out) is det.
-generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
- !StaticCellInfo, !ActiveMap) :-
+generate_ground_term_conjunct_tag(Var, ConsTag, Args, ConsArgWidths,
+ UnboxedFloats, !StaticCellInfo, !ActiveMap) :-
(
(
ConsTag = string_tag(String),
@@ -1525,7 +1701,7 @@ generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
;
ConsTag = shared_with_reserved_addresses_tag(_, ActualConsTag),
generate_ground_term_conjunct_tag(Var, ActualConsTag, Args,
- UnboxedFloats, !StaticCellInfo, !ActiveMap)
+ ConsArgWidths, UnboxedFloats, !StaticCellInfo, !ActiveMap)
;
ConsTag = no_tag,
(
@@ -1547,7 +1723,8 @@ generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
ConsTag = unshared_tag(Ptag)
),
generate_ground_term_args(Args, ArgRvalsTypes, !ActiveMap),
- add_scalar_static_cell(ArgRvalsTypes, DataAddr, !StaticCellInfo),
+ pack_ground_term_args(ConsArgWidths, ArgRvalsTypes, PackArgRvalsTypes),
+ add_scalar_static_cell(PackArgRvalsTypes, DataAddr, !StaticCellInfo),
MaybeOffset = no,
CellPtrConst = const(llconst_data_addr(DataAddr, MaybeOffset)),
Rval = mkword(Ptag, CellPtrConst),
@@ -1570,8 +1747,9 @@ generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
;
ConsTag = shared_remote_tag(Ptag, Stag),
generate_ground_term_args(Args, ArgRvalsTypes, !ActiveMap),
+ pack_ground_term_args(ConsArgWidths, ArgRvalsTypes, PackArgRvalsTypes),
StagRvalType = const(llconst_int(Stag)) - lt_integer,
- AllRvalsTypes = [StagRvalType | ArgRvalsTypes],
+ AllRvalsTypes = [StagRvalType | PackArgRvalsTypes],
add_scalar_static_cell(AllRvalsTypes, DataAddr, !StaticCellInfo),
MaybeOffset = no,
CellPtrConst = const(llconst_data_addr(DataAddr, MaybeOffset)),
@@ -1598,6 +1776,121 @@ generate_ground_term_args([Var | Vars], [RvalType | RvalsTypes], !ActiveMap) :-
map.det_remove(Var, RvalType, !ActiveMap),
generate_ground_term_args(Vars, RvalsTypes, !ActiveMap).
+:- pred pack_ground_term_args(list(arg_width)::in,
+ assoc_list(rval, llds_type)::in, assoc_list(rval, llds_type)::out) is det.
+
+pack_ground_term_args(Widths, !RvalsTypes) :-
+ pack_args(shift_combine_rval_type, Widths, !RvalsTypes, unit, _, unit, _).
+
+%-----------------------------------------------------------------------------%
+
+:- pred shift_combine_arg(maybe(rval)::in, int::in,
+ maybe(maybe(rval))::in, maybe(rval)::out,
+ llds_code::in, llds_code::out, code_info::in, code_info::out) is det.
+
+shift_combine_arg(ArgA, Shift, MaybeArgB, FinalArg, !Code, !CI) :-
+ (
+ Shift = 0,
+ MaybeArgB = no
+ ->
+ FinalArg = ArgA
+ ;
+ (
+ ArgA = yes(RvalA),
+ ( RvalA = var(Var) ->
+ IsDummy = variable_is_of_dummy_type(!.CI, Var),
+ (
+ IsDummy = is_dummy_type,
+ ShiftArgA = no
+ ;
+ IsDummy = is_not_dummy_type,
+ produce_variable(Var, VarCode, VarRval, !CI),
+ ShiftArgA = yes(maybe_left_shift_rval(VarRval, Shift)),
+ !:Code = !.Code ++ VarCode
+ )
+ ; RvalA = const(llconst_int(Int)) ->
+ NewInt = maybe_left_shift_int(Int, Shift),
+ ShiftArgA = yes(const(llconst_int(NewInt)))
+ ;
+ unexpected($module, $pred, "non-var or int argument")
+ )
+ ;
+ ArgA = no,
+ ShiftArgA = no
+ ),
+ (
+ MaybeArgB = yes(ArgB),
+ FinalArg = bitwise_or_maybe_rval(ShiftArgA, ArgB)
+ ;
+ MaybeArgB = no,
+ FinalArg = ShiftArgA
+ )
+ ).
+
+:- pred shift_combine_rval_type(pair(rval, llds_type)::in, int::in,
+ maybe(pair(rval, llds_type))::in, pair(rval, llds_type)::out,
+ unit::in, unit::out, unit::in, unit::out) is det.
+
+shift_combine_rval_type(ArgA, Shift, MaybeArgB, FinalArg, !Acc1, !Acc2) :-
+ ArgA = RvalA - TypeA,
+ ShiftRvalA = maybe_left_shift_rval(RvalA, Shift),
+ (
+ MaybeArgB = yes(RvalB - TypeB),
+ ( TypeA = TypeB ->
+ FinalRval = binop(bitwise_or, ShiftRvalA, RvalB)
+ ;
+ unexpected($module, $pred, "mismatched llds_types")
+ )
+ ;
+ MaybeArgB = no,
+ FinalRval = ShiftRvalA
+ ),
+ FinalArg = FinalRval - TypeA.
+
+:- func maybe_left_shift_rval(rval, int) = rval.
+
+maybe_left_shift_rval(Rval, Shift) =
+ ( Shift = 0 ->
+ Rval
+ ;
+ binop(unchecked_left_shift, Rval, const(llconst_int(Shift)))
+ ).
+
+:- func maybe_left_shift_int(int, int) = int.
+
+maybe_left_shift_int(X, Shift) =
+ ( Shift = 0 ->
+ X
+ ;
+ X << Shift
+ ).
+
+:- func right_shift_rval(rval, int) = rval.
+
+right_shift_rval(Rval, Shift) =
+ binop(unchecked_right_shift, Rval, const(llconst_int(Shift))).
+
+:- func bitwise_or_maybe_rval(maybe(rval), maybe(rval)) = maybe(rval).
+
+bitwise_or_maybe_rval(MaybeRvalA, MaybeRvalB) = MaybeRval :-
+ (
+ MaybeRvalA = yes(RvalA),
+ MaybeRvalB = yes(RvalB),
+ MaybeRval = yes(binop(bitwise_or, RvalA, RvalB))
+ ;
+ MaybeRvalA = yes(_),
+ MaybeRvalB = no,
+ MaybeRval = MaybeRvalA
+ ;
+ MaybeRvalA = no,
+ MaybeRvalB = yes(_),
+ MaybeRval = MaybeRvalB
+ ;
+ MaybeRvalA = no,
+ MaybeRvalB = no,
+ MaybeRval = no
+ ).
+
%---------------------------------------------------------------------------%
:- pred var_type_msg(mer_type::in, string::out) is det.
diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m
index a317f69..dc765eb 100644
--- a/compiler/unify_proc.m
+++ b/compiler/unify_proc.m
@@ -391,7 +391,8 @@ add_lazily_generated_unify_pred(TypeCtor, PredId, !ModuleInfo) :-
ExistQVars = [],
ClassConstraints = [],
- MakeUnamedField = (func(ArgType) = ctor_arg(no, ArgType, Context)),
+ MakeUnamedField = (func(ArgType) =
+ ctor_arg(no, ArgType, full_word, Context)),
CtorArgs = list.map(MakeUnamedField, TupleArgTypes),
CtorSymName = unqualified("{}"),
diff --git a/compiler/var_locn.m b/compiler/var_locn.m
index a421bc5..64c21ee 100644
--- a/compiler/var_locn.m
+++ b/compiler/var_locn.m
@@ -144,6 +144,17 @@
static_cell_info::in, llds_code::out,
var_locn_info::in, var_locn_info::out) is det.
+ % var_locn_assign_field_lval_expr_to_var(ModuleInfo, Var, FieldLval, Expr,
+ % StaticCellInfo, Code, !VarLocnInfo);
+ %
+ % Reflects the effect of the assignment Var := Expr,
+ % where Expr contains on the field lval FieldLval.
+ % Any code required to effect the assignment will be returned in Code.
+ %
+:- pred var_locn_assign_field_lval_expr_to_var(prog_var::in,
+ lval::in, rval::in, llds_code::out,
+ var_locn_info::in, var_locn_info::out) is det.
+
% var_locn_assign_const_to_var(ExprnOpts, Var, ConstRval,
% !VarLocnInfo):
%
@@ -181,7 +192,7 @@
% obvious conflict.) Label can be used in the generated code if necessary.
%
:- pred var_locn_assign_cell_to_var(module_info::in, exprn_opts::in,
- prog_var::in, bool::in, tag::in, list(maybe(rval))::in,
+ prog_var::in, bool::in, tag::in, list(maybe(rval))::in, bool::in,
how_to_construct::in, maybe(term_size_value)::in, list(int)::in,
maybe(alloc_site_id)::in, may_use_atomic_alloc::in, label::in,
llds_code::out, static_cell_info::in, static_cell_info::out,
@@ -758,6 +769,21 @@ var_locn_assign_lval_to_var(ModuleInfo, Var, Lval0, StaticCellInfo, Code,
add_field_offset(Ptag, Offset, Base) =
field(Ptag, lval(Base), Offset).
+var_locn_assign_field_lval_expr_to_var(Var, Lval, Expr, Code, !VLI) :-
+ check_var_is_unknown(!.VLI, Var),
+ ( Lval = field(yes(_Ptag), var(BaseVar), const(llconst_int(_Offset))) ->
+ var_locn_get_var_state_map(!.VLI, VarStateMap0),
+ set.init(Lvals),
+ set.init(Using),
+ State = var_state(Lvals, no, yes(Expr), Using, doa_alive),
+ map.det_insert(Var, State, VarStateMap0, VarStateMap1),
+ add_use_ref(BaseVar, Var, VarStateMap1, VarStateMap),
+ var_locn_set_var_state_map(VarStateMap, !VLI),
+ Code = empty
+ ;
+ unexpected($module, $pred, "not field lval")
+ ).
+
%----------------------------------------------------------------------------%
var_locn_assign_const_to_var(ExprnOpts, Var, ConstRval0, !VLI) :-
@@ -809,8 +835,8 @@ add_use_ref(ContainedVar, UsingVar, !VarStateMap) :-
%----------------------------------------------------------------------------%
var_locn_assign_cell_to_var(ModuleInfo, ExprnOpts, Var, ReserveWordAtStart,
- Ptag, MaybeRvals0, HowToConstruct, MaybeSize, FieldAddrs, MaybeAllocId,
- MayUseAtomic, Label, Code, !StaticCellInfo, !VLI) :-
+ Ptag, MaybeRvals0, AllFilled, HowToConstruct, MaybeSize, FieldAddrs,
+ MaybeAllocId, MayUseAtomic, Label, Code, !StaticCellInfo, !VLI) :-
(
MaybeSize = yes(SizeSource),
(
@@ -832,6 +858,7 @@ var_locn_assign_cell_to_var(ModuleInfo, ExprnOpts, Var, ReserveWordAtStart,
% We can make the cell a constant only if all its fields are filled in,
% and they are all constants.
(
+ AllFilled = yes,
StaticGroundCells = have_static_ground_cells,
FieldAddrs = [],
cell_is_constant(VarStateMap, ExprnOpts, MaybeRvals, RvalsTypes)
@@ -1101,17 +1128,26 @@ assign_cell_arg(ModuleInfo, Rval0, Ptag, Base, Offset, Code, !VLI) :-
AssignCode = singleton(llds_instr(assign(Target, Rval), Comment))
)
;
- Rval0 = const(_),
+ (
+ Rval0 = const(_),
+ Comment = "assigning field from const"
+ ;
+ Rval0 = mkword(_, _),
+ Comment = "assigning field from tagged pointer"
+ ;
+ Rval0 = unop(_, _),
+ Comment = "assigning field from unary op"
+ ;
+ Rval0 = binop(_, _, _),
+ Comment = "assigning field from binary op"
+ ;
+ Rval0 = lval(_),
+ Comment = "assigning field"
+ ),
EvalCode = empty,
- Comment = "assigning field from const",
AssignCode = singleton(llds_instr(assign(Target, Rval0), Comment))
;
- ( Rval0 = mkword(_, _)
- ; Rval0 = binop(_, _, _)
- ; Rval0 = unop(_, _)
- ; Rval0 = lval(_)
- ; Rval0 = mem_addr(_)
- ),
+ Rval0 = mem_addr(_),
unexpected($module, $pred, "unknown rval")
),
Code = EvalCode ++ AssignCode.
diff --git a/compiler/xml_documentation.m b/compiler/xml_documentation.m
index 6d71d58..8d0b074 100644
--- a/compiler/xml_documentation.m
+++ b/compiler/xml_documentation.m
@@ -413,7 +413,8 @@ constructor(C, TVarset,
:- func constructor_arg(comments, tvarset, constructor_arg) = xml.
-constructor_arg(C, TVarset, ctor_arg(MaybeFieldName, Type, Context)) = Xml :-
+constructor_arg(C, TVarset, CtorArg) = Xml :-
+ CtorArg = ctor_arg(MaybeFieldName, Type, _Width, Context),
XmlType = elem("arg_type", [], [mer_type(TVarset, Type)]),
XmlContext = prog_context(Context),
(
diff --git a/extras/trailed_update/samples/interpreter.m b/extras/trailed_update/samples/interpreter.m
index b3d88e6..a00c024 100644
--- a/extras/trailed_update/samples/interpreter.m
+++ b/extras/trailed_update/samples/interpreter.m
@@ -271,7 +271,7 @@ my_term_to_term(var(MyVar), variable(Var, Context), !VarSet, !VarMap, !S) :-
( assoc_list.search(!.VarMap, MyVar, Var0) ->
Var = Var0
;
- varset.new_var(!.VarSet, Var, !:VarSet),
+ varset.new_var(Var, !VarSet),
!:VarMap = [MyVar - Var | !.VarMap]
),
%
@@ -281,13 +281,13 @@ my_term_to_term(var(MyVar), variable(Var, Context), !VarSet, !VarMap, !S) :-
tr_store.get_mutvar(MyVar, MyValue, !S),
( MyValue \= free ->
my_term_to_term(MyValue, Value, !VarSet, !VarMap, !S),
- varset.bind_var(!.VarSet, Var, Value, !:VarSet)
+ varset.bind_var(Var, Value, !VarSet)
;
true
).
my_term_to_term(free, variable(Var, Context), !VarSet, !VarMap, !S) :-
context_init(Context),
- varset.new_var(!.VarSet, Var, !:VarSet),
+ varset.new_var(Var, !VarSet),
error("my_term_to_term: unexpected free var").
my_term_to_term(functor(Functor, Args0), functor(Functor, Args, Context),
!VarSet, !VarMap, !S) :-
@@ -562,17 +562,17 @@ database_assert_clause(VarSet, Term, !Database) :-
( map.search(Preds0, PredId, Pred0) ->
Pred0 = db_pred(PredUnindexedClauses,
PredIndexedClauses0),
- multi_map.set(PredIndexedClauses0, FirstArgId,
- Clause, PredIndexedClauses),
+ multi_map.set(FirstArgId, Clause,
+ PredIndexedClauses0, PredIndexedClauses),
Pred = db_pred(PredUnindexedClauses,
PredIndexedClauses),
- map.det_update(Preds0, PredId, Pred, Preds)
+ map.det_update(PredId, Pred, Preds0, Preds)
;
multi_map.init(PredIndexedClauses0),
- multi_map.set(PredIndexedClauses0, FirstArgId,
- Clause, PredIndexedClauses),
+ multi_map.set(FirstArgId, Clause,
+ PredIndexedClauses0, PredIndexedClauses),
Pred = db_pred([], PredIndexedClauses),
- map.det_insert(Preds0, PredId, Pred, Preds)
+ map.det_insert(PredId, Pred, Preds0, Preds)
)
;
% We can't do first-argument indexing -- just
@@ -583,11 +583,11 @@ database_assert_clause(VarSet, Term, !Database) :-
PredIndexedClauses),
Pred = db_pred([Clause | PredUnindexedClauses],
PredIndexedClauses),
- map.det_update(Preds0, PredId, Pred, Preds)
+ map.det_update(PredId, Pred, Preds0, Preds)
;
multi_map.init(PredIndexedClauses),
Pred = db_pred([Clause], PredIndexedClauses),
- map.det_insert(Preds0, PredId, Pred, Preds)
+ map.det_insert(PredId, Pred, Preds0, Preds)
)
),
!:Database = database(UnindexedClauses, Preds)
diff --git a/extras/trailed_update/tr_array.m b/extras/trailed_update/tr_array.m
index db3ba76..02ed168 100644
--- a/extras/trailed_update/tr_array.m
+++ b/extras/trailed_update/tr_array.m
@@ -290,7 +290,7 @@ tr_array.semidet_slow_set(Array0, Index, Item, Array) :-
tr_array.slow_set(Array0, Index, Item, Array) :-
tr_array.copy(Array0, Array1),
- array.set(Array1, Index, Item, Array).
+ array.set(Index, Item, Array1, Array).
%-----------------------------------------------------------------------------%
diff --git a/extras/trailed_update/tr_store.m b/extras/trailed_update/tr_store.m
index 6aa4b8c..d71cc5a 100644
--- a/extras/trailed_update/tr_store.m
+++ b/extras/trailed_update/tr_store.m
@@ -243,11 +243,12 @@ ref_functor(Ref, Functor, Arity, !S) :-
"
MR_TypeInfo arg_type_info;
MR_Word* arg_ref;
+ const MR_DuArgLocn* arg_locn;
MR_save_transient_registers();
if (!MR_arg((MR_TypeInfo) TypeInfo_for_T, (MR_Word *) Ref, ArgNum,
- &arg_type_info, &arg_ref, MR_NONCANON_ALLOW))
+ &arg_type_info, &arg_ref, &arg_locn, MR_NONCANON_ALLOW))
{
MR_fatal_error(
""tr_store.arg_ref: argument number out of range"");
@@ -259,6 +260,10 @@ ref_functor(Ref, Functor, Arity, !S) :-
MR_fatal_error(""tr_store.arg_ref: argument has wrong type"");
}
+ if (arg_locn != NULL && arg_locn->MR_arg_bits != 0) {
+ MR_fatal_error(""tr_store.arg_ref: argument has packed representation"");
+ }
+
MR_restore_transient_registers();
ArgRef = (MR_Word) arg_ref;
@@ -271,11 +276,12 @@ ref_functor(Ref, Functor, Arity, !S) :-
"
MR_TypeInfo arg_type_info;
MR_Word* arg_ref;
+ const MR_DuArgLocn* arg_locn;
MR_save_transient_registers();
if (!MR_arg((MR_TypeInfo) TypeInfo_for_T, (MR_Word *) &Val, ArgNum,
- &arg_type_info, &arg_ref, MR_NONCANON_ALLOW))
+ &arg_type_info, &arg_ref, &arg_locn, MR_NONCANON_ALLOW))
{
MR_fatal_error(
""tr_store.new_arg_ref: argument number out of range"");
@@ -290,13 +296,16 @@ ref_functor(Ref, Functor, Arity, !S) :-
MR_restore_transient_registers();
- /*
- ** For no_tag types, the argument may have the same address as the
- ** term. Since the term (Val) is currently on the C stack, we can't
- ** return a pointer to it; so if that is the case, then we need
- ** to copy it to the heap before returning.
- */
- if (arg_ref == &Val) {
+ if (arg_locn != NULL && arg_locn->MR_arg_bits != 0) {
+ MR_incr_hp(ArgRef, 1);
+ * (MR_Word *) ArgRef = MR_unpack_arg(*arg_ref, arg_locn);
+ } else if (arg_ref == &Val) {
+ /*
+ ** For no_tag types, the argument may have the same address as the
+ ** term. Since the term (Val) is currently on the C stack, we can't
+ ** return a pointer to it; so if that is the case, then we need
+ ** to copy it to the heap before returning.
+ */
MR_incr_hp(ArgRef, 1);
*(MR_Word *)ArgRef = Val;
} else {
diff --git a/java/runtime/DuArgLocn.java b/java/runtime/DuArgLocn.java
new file mode 100644
index 0000000..7e9ff5b
--- /dev/null
+++ b/java/runtime/DuArgLocn.java
@@ -0,0 +1,21 @@
+//
+// Copyright (C) 2011 The University of Melbourne.
+// This file may only be copied under the terms of the GNU Library General
+// Public License - see the file COPYING.LIB in the Mercury distribution.
+//
+
+package jmercury.runtime;
+
+public class DuArgLocn implements java.io.Serializable {
+
+ public int arg_offset;
+ public int arg_shift;
+ public int arg_bits;
+
+ public DuArgLocn(int arg_offset, int arg_shift, int arg_bits)
+ {
+ this.arg_offset = arg_offset;
+ this.arg_shift = arg_shift;
+ this.arg_bits = arg_bits;
+ }
+}
diff --git a/java/runtime/DuFunctorDesc.java b/java/runtime/DuFunctorDesc.java
index 1deb3e6..ae1098d 100644
--- a/java/runtime/DuFunctorDesc.java
+++ b/java/runtime/DuFunctorDesc.java
@@ -19,6 +19,7 @@ public class DuFunctorDesc implements java.io.Serializable {
// yet, so this may not be correct.
public /*final*/ PseudoTypeInfo[] du_functor_arg_types;
public /*final*/ java.lang.String[] du_functor_arg_names;
+ public /*final*/ DuArgLocn[] du_functor_arg_locns;
public /*final*/ DuExistInfo du_functor_exist_info;
public DuFunctorDesc()
@@ -31,6 +32,7 @@ public class DuFunctorDesc implements java.io.Serializable {
// XXX why do we need to use Object here?
java.lang.Object arg_types,
java.lang.Object arg_names,
+ java.lang.Object arg_locns,
java.lang.Object exist_info)
{
du_functor_name = functor_name;
@@ -43,6 +45,7 @@ public class DuFunctorDesc implements java.io.Serializable {
du_functor_ordinal = ordinal;
du_functor_arg_types = (PseudoTypeInfo []) arg_types;
du_functor_arg_names = (java.lang.String []) arg_names;
+ du_functor_arg_locns = (DuArgLocn []) arg_locns;
du_functor_exist_info = (DuExistInfo) exist_info;
}
}
diff --git a/library/construct.m b/library/construct.m
index 7ba5fa4..a431bf1 100644
--- a/library/construct.m
+++ b/library/construct.m
@@ -526,8 +526,6 @@ get_functor_lex(TypeDesc, Ordinal) = FunctorNumber :-
MR_restore_transient_registers();
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
if (Ordinal < 0 || Ordinal >= num_functors
- || type_ctor_info->MR_type_ctor_version
- < MR_RTTI_VERSION__FUNCTOR_NUMBERS
|| !type_ctor_info->MR_type_ctor_functor_number_map)
{
SUCCESS_INDICATOR = MR_FALSE;
@@ -660,15 +658,19 @@ find_functor_2(TypeInfo, Functor, Arity, Num0, FunctorNumber, ArgTypes) :-
case MR_TYPECTOR_REP_DU_USEREQ:
{
const MR_DuFunctorDesc *functor_desc;
+ const MR_DuArgLocn *arg_locns;
MR_Word arg_list;
MR_Word ptag;
MR_Word arity;
MR_Word arg_data;
MR_TypeInfo arg_type_info;
+ int args_size;
+ int alloc_size;
int size;
int i;
functor_desc = construct_info.functor_info.du_functor_desc;
+ arg_locns = functor_desc->MR_du_functor_arg_locns;
if (functor_desc->MR_du_functor_exist_info != NULL) {
MR_fatal_error(""not yet implemented: construction ""
""of terms containing existential types"");
@@ -686,12 +688,24 @@ find_functor_2(TypeInfo, Functor, Arity, Num0, FunctorNumber, ArgTypes) :-
case MR_SECTAG_REMOTE:
arity = functor_desc->MR_du_functor_orig_arity;
+ args_size = MR_cell_size_for_args(arity, arg_locns);
+ alloc_size = MR_SIZE_SLOT_SIZE + 1 + args_size;
MR_tag_offset_incr_hp_msg(new_data, ptag,
- MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1 + arity,
+ MR_SIZE_SLOT_SIZE, alloc_size,
MR_ALLOC_ID, ""<created by construct.construct/3>"");
- size = MR_cell_size(arity);
+ /*
+ ** Ensure words holding packed arguments are zeroed before
+ ** filling them in.
+ */
+ #ifndef MR_BOEHM_GC
+ if (arg_locns != NULL) {
+ MR_memset(new_data, 0, alloc_size * sizeof(MR_Word));
+ }
+ #endif
+
+ size = MR_cell_size(args_size);
MR_field(ptag, new_data, 0) =
functor_desc->MR_du_functor_secondary;
for (i = 0; i < arity; i++) {
@@ -701,7 +715,13 @@ find_functor_2(TypeInfo, Functor, Arity, Num0, FunctorNumber, ArgTypes) :-
arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
MR_list_head(arg_list),
MR_UNIV_OFFSET_FOR_TYPEINFO);
- MR_field(ptag, new_data, i + 1) = arg_data;
+ if (arg_locns == NULL) {
+ MR_field(ptag, new_data, 1 + i) = arg_data;
+ } else {
+ const MR_DuArgLocn *locn = &arg_locns[i];
+ MR_field(ptag, new_data, 1 + locn->MR_arg_offset)
+ |= (arg_data << locn->MR_arg_shift);
+ }
size += MR_term_size(arg_type_info, arg_data);
arg_list = MR_list_tail(arg_list);
}
@@ -711,12 +731,24 @@ find_functor_2(TypeInfo, Functor, Arity, Num0, FunctorNumber, ArgTypes) :-
case MR_SECTAG_NONE:
arity = functor_desc->MR_du_functor_orig_arity;
+ args_size = MR_cell_size_for_args(arity, arg_locns);
+ alloc_size = MR_SIZE_SLOT_SIZE + args_size;
MR_tag_offset_incr_hp_msg(new_data, ptag,
- MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + arity,
+ MR_SIZE_SLOT_SIZE, alloc_size,
MR_ALLOC_ID, ""<created by construct.construct/3>"");
- size = MR_cell_size(arity);
+ /*
+ ** Ensure words holding packed arguments are zeroed before
+ ** filling them in.
+ */
+ #ifndef MR_BOEHM_GC
+ if (arg_locns != NULL) {
+ MR_memset(new_data, 0, alloc_size * sizeof(MR_Word));
+ }
+ #endif
+
+ size = MR_cell_size(args_size);
for (i = 0; i < arity; i++) {
arg_data = MR_field(MR_UNIV_TAG,
MR_list_head(arg_list),
@@ -724,7 +756,13 @@ find_functor_2(TypeInfo, Functor, Arity, Num0, FunctorNumber, ArgTypes) :-
arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
MR_list_head(arg_list),
MR_UNIV_OFFSET_FOR_TYPEINFO);
- MR_field(ptag, new_data, i) = arg_data;
+ if (arg_locns == NULL) {
+ MR_field(ptag, new_data, i) = arg_data;
+ } else {
+ const MR_DuArgLocn *locn = &arg_locns[i];
+ MR_field(ptag, new_data, locn->MR_arg_offset)
+ |= (arg_data << locn->MR_arg_shift);
+ }
size += MR_term_size(arg_type_info, arg_data);
arg_list = MR_list_tail(arg_list);
}
diff --git a/library/store.m b/library/store.m
index c2f5cb7..e964657 100644
--- a/library/store.m
+++ b/library/store.m
@@ -222,10 +222,13 @@
% except that they doesn't check for errors,
% and they don't work for `no_tag' types (types with
% exactly one functor which has exactly one argument),
+ % and they don't work for arguments which occupy a word with other
+ % arguments,
% and they don't work for types with >4 functors.
% If the argument number is out of range,
% or if the argument reference has the wrong type,
% or if the argument is a `no_tag' type,
+ % or if the argument uses a packed representation,
% then the behaviour is undefined, and probably harmful.
:- pred store.unsafe_arg_ref(generic_ref(T, S)::in, int::in,
@@ -682,10 +685,11 @@ ref_functor(Ref, Functor, Arity, !Store) :-
arg_ref(Ref::in, ArgNum::in, ArgRef::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, may_not_duplicate],
"{
- MR_TypeInfo type_info;
- MR_TypeInfo arg_type_info;
- MR_TypeInfo exp_arg_type_info;
- MR_Word *arg_ref;
+ MR_TypeInfo type_info;
+ MR_TypeInfo arg_type_info;
+ MR_TypeInfo exp_arg_type_info;
+ MR_Word *arg_ref;
+ const MR_DuArgLocn *arg_locn;
type_info = (MR_TypeInfo) TypeInfo_for_T;
exp_arg_type_info = (MR_TypeInfo) TypeInfo_for_ArgT;
@@ -693,7 +697,7 @@ ref_functor(Ref, Functor, Arity, !Store) :-
MR_save_transient_registers();
if (!MR_arg(type_info, (MR_Word *) Ref, ArgNum, &arg_type_info,
- &arg_ref, MR_NONCANON_ABORT))
+ &arg_ref, &arg_locn, MR_NONCANON_ABORT))
{
MR_fatal_error(""store.arg_ref: argument number out of range"");
}
@@ -706,7 +710,14 @@ ref_functor(Ref, Functor, Arity, !Store) :-
MR_restore_transient_registers();
- ArgRef = (MR_Word) arg_ref;
+ if (arg_locn != NULL && arg_locn->MR_arg_bits != 0) {
+ MR_offset_incr_hp_msg(ArgRef, MR_SIZE_SLOT_SIZE,
+ MR_SIZE_SLOT_SIZE + 1, MR_ALLOC_ID, ""store.ref/2"");
+ MR_define_size_slot(0, ArgRef, 1);
+ * (MR_Word *) ArgRef = MR_unpack_arg(*arg_ref, arg_locn);
+ } else {
+ ArgRef = (MR_Word) arg_ref;
+ }
S = S0;
}").
@@ -740,10 +751,11 @@ ref_functor(Ref, Functor, Arity, !Store) :-
new_arg_ref(Val::di, ArgNum::in, ArgRef::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, may_not_duplicate],
"{
- MR_TypeInfo type_info;
- MR_TypeInfo arg_type_info;
- MR_TypeInfo exp_arg_type_info;
- MR_Word *arg_ref;
+ MR_TypeInfo type_info;
+ MR_TypeInfo arg_type_info;
+ MR_TypeInfo exp_arg_type_info;
+ MR_Word *arg_ref;
+ const MR_DuArgLocn *arg_locn;
type_info = (MR_TypeInfo) TypeInfo_for_T;
exp_arg_type_info = (MR_TypeInfo) TypeInfo_for_ArgT;
@@ -751,7 +763,7 @@ ref_functor(Ref, Functor, Arity, !Store) :-
MR_save_transient_registers();
if (!MR_arg(type_info, (MR_Word *) &Val, ArgNum, &arg_type_info,
- &arg_ref, MR_NONCANON_ABORT))
+ &arg_ref, &arg_locn, MR_NONCANON_ABORT))
{
MR_fatal_error(""store.new_arg_ref: argument number out of range"");
}
@@ -764,14 +776,19 @@ ref_functor(Ref, Functor, Arity, !Store) :-
MR_restore_transient_registers();
- /*
- ** For no_tag types, the argument may have the same address as the
- ** term. Since the term (Val) is currently on the C stack, we can't
- ** return a pointer to it; so if that is the case, then we need
- ** to copy it to the heap before returning.
- */
+ if (arg_locn != NULL && arg_locn->MR_arg_bits != 0) {
+ MR_offset_incr_hp_msg(ArgRef, MR_SIZE_SLOT_SIZE,
+ MR_SIZE_SLOT_SIZE + 1, MR_ALLOC_ID, ""store.ref/2"");
+ MR_define_size_slot(0, ArgRef, 1);
+ * (MR_Word *) ArgRef = MR_unpack_arg(*arg_ref, arg_locn);
+ } else if (arg_ref == &Val) {
+ /*
+ ** For no_tag types, the argument may have the same address as the
+ ** term. Since the term (Val) is currently on the C stack, we can't
+ ** return a pointer to it; so if that is the case, then we need
+ ** to copy it to the heap before returning.
+ */
- if (arg_ref == &Val) {
MR_offset_incr_hp_msg(ArgRef, MR_SIZE_SLOT_SIZE,
MR_SIZE_SLOT_SIZE + 1, MR_ALLOC_ID, ""store.ref/2"");
MR_define_size_slot(0, ArgRef, 1);
diff --git a/runtime/mercury_deconstruct.c b/runtime/mercury_deconstruct.c
index d66ec7c..d4beed4 100644
--- a/runtime/mercury_deconstruct.c
+++ b/runtime/mercury_deconstruct.c
@@ -85,6 +85,7 @@ static MR_ConstString MR_expand_type_name(MR_TypeCtorInfo tci, MR_bool);
MR_bool
MR_arg(MR_TypeInfo type_info, MR_Word *term_ptr, int arg_index,
MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr,
+ const MR_DuArgLocn **arg_locn_ptr,
MR_noncanon_handling noncanon)
{
MR_Expand_Chosen_Arg_Only_Info expand_info;
@@ -92,10 +93,11 @@ MR_arg(MR_TypeInfo type_info, MR_Word *term_ptr, int arg_index,
MR_expand_chosen_arg_only(type_info, term_ptr, noncanon, arg_index,
&expand_info);
- /* Check range */
+ /* Check range. */
if (expand_info.chosen_index_exists) {
*arg_type_info_ptr = expand_info.chosen_type_info;
*arg_ptr = expand_info.chosen_value_ptr;
+ *arg_locn_ptr = expand_info.chosen_arg_locn;
return MR_TRUE;
}
@@ -105,6 +107,7 @@ MR_arg(MR_TypeInfo type_info, MR_Word *term_ptr, int arg_index,
MR_bool
MR_named_arg(MR_TypeInfo type_info, MR_Word *term_ptr, MR_ConstString arg_name,
MR_TypeInfo *arg_type_info_ptr, MR_Word **arg_ptr,
+ const MR_DuArgLocn **arg_locn_ptr,
MR_noncanon_handling noncanon)
{
MR_Expand_Chosen_Arg_Only_Info expand_info;
@@ -112,10 +115,11 @@ MR_named_arg(MR_TypeInfo type_info, MR_Word *term_ptr, MR_ConstString arg_name,
MR_expand_named_arg_only(type_info, term_ptr, noncanon, arg_name,
&expand_info);
- /* Check range */
+ /* Check range. */
if (expand_info.chosen_index_exists) {
*arg_type_info_ptr = expand_info.chosen_type_info;
*arg_ptr = expand_info.chosen_value_ptr;
+ *arg_locn_ptr = expand_info.chosen_arg_locn;
return MR_TRUE;
}
diff --git a/runtime/mercury_deconstruct.h b/runtime/mercury_deconstruct.h
index ca27129..6be7e60 100644
--- a/runtime/mercury_deconstruct.h
+++ b/runtime/mercury_deconstruct.h
@@ -24,6 +24,7 @@
typedef struct {
int num_extra_args;
MR_Word *arg_values;
+ const MR_DuArgLocn *arg_locns;
MR_TypeInfo *arg_type_infos;
MR_bool can_free_arg_type_infos;
} MR_Expand_Args_Fields;
@@ -58,6 +59,7 @@ typedef struct {
int arity;
MR_bool chosen_index_exists;
MR_Word *chosen_value_ptr;
+ const MR_DuArgLocn *chosen_arg_locn;
MR_TypeInfo chosen_type_info;
} MR_Expand_Chosen_Arg_Only_Info;
@@ -121,6 +123,7 @@ extern void MR_expand_named_arg_only(MR_TypeInfo type_info,
extern MR_bool MR_arg(MR_TypeInfo type_info, MR_Word *term, int arg_index,
MR_TypeInfo *arg_type_info_ptr, MR_Word **argument_ptr,
+ const MR_DuArgLocn **arg_locn_ptr,
MR_noncanon_handling noncanon);
/*
@@ -133,7 +136,9 @@ extern MR_bool MR_arg(MR_TypeInfo type_info, MR_Word *term, int arg_index,
extern MR_bool MR_named_arg(MR_TypeInfo type_info, MR_Word *term,
MR_ConstString arg_name, MR_TypeInfo *arg_type_info_ptr,
- MR_Word **argument_ptr, MR_noncanon_handling noncanon);
+ MR_Word **argument_ptr,
+ const MR_DuArgLocn **arg_locn_ptr,
+ MR_noncanon_handling noncanon);
/*
** MR_named_arg_num() takes the address of a term, its type,
diff --git a/runtime/mercury_deconstruct_macros.h b/runtime/mercury_deconstruct_macros.h
index d117a1a..9149fd8 100644
--- a/runtime/mercury_deconstruct_macros.h
+++ b/runtime/mercury_deconstruct_macros.h
@@ -58,14 +58,25 @@
\
while (--i >= 0) { \
MR_Word arg; \
+ MR_Word val; \
\
- /* Create an argument on the heap */ \
+ if ((ei).args_field.arg_locns == NULL) { \
+ val = (ei).args_field.arg_values[i + \
+ (ei).args_field.num_extra_args]; \
+ } else { \
+ const MR_DuArgLocn *locn = \
+ &(ei).args_field.arg_locns[i]; \
+ val = (ei).args_field.arg_values[ \
+ locn->MR_arg_offset + \
+ (ei).args_field.num_extra_args]; \
+ val = MR_unpack_arg(val, locn); \
+ } \
+ \
+ /* Create an argument on the heap */ \
MR_new_univ_on_hp(arg, \
- (ei).args_field.arg_type_infos[i], \
- (ei).args_field.arg_values[i + \
- (ei).args_field.num_extra_args]); \
+ (ei).args_field.arg_type_infos[i], val); \
\
- /* Join the argument to the front of the list */ \
+ /* Join the argument to the front of the list */ \
var = MR_univ_list_cons_msg(arg, var, MR_ALLOC_ID); \
} \
} while (0)
diff --git a/runtime/mercury_deep_copy_body.h b/runtime/mercury_deep_copy_body.h
index 5adb1ac..63c7229 100644
--- a/runtime/mercury_deep_copy_body.h
+++ b/runtime/mercury_deep_copy_body.h
@@ -219,6 +219,7 @@ try_again:
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word); \
{ \
const MR_DuFunctorDesc *functor_desc; \
+ const MR_DuArgLocn *arg_locns; \
const MR_DuExistInfo *exist_info; \
MR_AllocSiteInfoPtr attrib; \
int sectag; \
@@ -237,14 +238,16 @@ try_again:
functor_desc = ptag_layout->MR_sectag_alternatives \
[sectag]; \
arity = functor_desc->MR_du_functor_orig_arity; \
+ arg_locns = functor_desc->MR_du_functor_arg_locns; \
exist_info = functor_desc->MR_du_functor_exist_info; \
\
/* this `if' will get evaluated at compile time */ \
- if (!have_sectag) { \
- cell_size = arity; \
+ if (have_sectag) { \
+ cell_size = 1; \
} else { \
- cell_size = 1 + arity; \
+ cell_size = 0; \
} \
+ cell_size += MR_cell_size_for_args(arity, arg_locns); \
cell_size += MR_SIZE_SLOT_SIZE; \
\
if (exist_info == NULL) { \
@@ -286,6 +289,21 @@ try_again:
} \
\
for (i = 0; i < arity; i++) { \
+ if (arg_locns != NULL && \
+ arg_locns[i].MR_arg_bits != 0) \
+ { \
+ /* \
+ ** Copy fields holding packed arguments when \
+ ** we encounter the first argument. \
+ */ \
+ if (arg_locns[i].MR_arg_shift == 0) { \
+ MR_field(0, new_data, cur_slot) = \
+ data_value[cur_slot]; \
+ cur_slot++; \
+ } \
+ continue; \
+ } \
+ \
if (MR_arg_type_may_contain_var(functor_desc, i)) { \
MR_Word *parent_data = (MR_Word *) new_data; \
if (have_sectag) { \
@@ -333,15 +351,20 @@ try_again:
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
{
const MR_DuFunctorDesc *functor_desc;
+ const MR_DuArgLocn *arg_locns;
const MR_DuExistInfo *exist_info;
int arity;
functor_desc = ptag_layout->MR_sectag_alternatives[0];
arity = functor_desc->MR_du_functor_orig_arity;
+ arg_locns = functor_desc->MR_du_functor_arg_locns;
exist_info = functor_desc->MR_du_functor_exist_info;
if (arity != 1) {
MR_fatal_error("arity != 1 in direct arg tag functor");
}
+ if (arg_locns != NULL) {
+ MR_fatal_error("arg_locns in direct arg tag functor");
+ }
if (exist_info != NULL) {
MR_fatal_error("exist_info in direct arg tag functor");
}
diff --git a/runtime/mercury_dotnet.cs.in b/runtime/mercury_dotnet.cs.in
index fdf9db7..fab5885 100644
--- a/runtime/mercury_dotnet.cs.in
+++ b/runtime/mercury_dotnet.cs.in
@@ -1,5 +1,5 @@
//
-// Copyright (C) 2003-2004, 2010 The University of Melbourne.
+// Copyright (C) 2003-2004, 2010-2011 The University of Melbourne.
// This file may only be copied under the terms of the GNU Library General
// Public License - see the file COPYING.LIB in the Mercury distribution.
//
@@ -667,6 +667,7 @@ public class DuFunctorDesc {
public int du_functor_ordinal;
public PseudoTypeInfo[] du_functor_arg_types;
public string[] du_functor_arg_names;
+ public DuArgLocn[] du_functor_arg_locns;
public DuExistInfo du_functor_exist_info;
public DuFunctorDesc() {
@@ -683,6 +684,7 @@ public class DuFunctorDesc {
// XXX why do we need to use object here?
object arg_types,
object arg_names,
+ object arg_locns,
object exist_info)
{
du_functor_name = functor_name;
@@ -695,6 +697,7 @@ public class DuFunctorDesc {
du_functor_ordinal = ordinal;
du_functor_arg_types = (PseudoTypeInfo []) arg_types;
du_functor_arg_names = (string[]) arg_names;
+ du_functor_arg_locns = (DuArgLocn[]) arg_locns;
du_functor_exist_info = (DuExistInfo) exist_info;
}
}
@@ -722,6 +725,18 @@ public class DuPtagLayout {
}
}
+public class DuArgLocn {
+ public int arg_offset;
+ public int arg_shift;
+ public int arg_bits;
+
+ public DuArgLocn(int arg_offset, int arg_shift, int arg_bits) {
+ this.arg_offset = arg_offset;
+ this.arg_shift = arg_shift;
+ this.arg_bits = arg_bits;
+ }
+}
+
public class DuExistInfo {
public int exist_typeinfos_plain;
public int exist_typeinfos_in_tci;
diff --git a/runtime/mercury_grade.h b/runtime/mercury_grade.h
index 96b6586..671e3ab 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 v17_
+#define MR_GRADE_PART_0 v18_
#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_arg_body.h b/runtime/mercury_ml_arg_body.h
index 5bf6e1e..c052c94 100644
--- a/runtime/mercury_ml_arg_body.h
+++ b/runtime/mercury_ml_arg_body.h
@@ -48,28 +48,35 @@
#define arg_func MR_arg
#endif
- MR_TypeInfo type_info;
- MR_TypeInfo arg_type_info;
- MR_Word *argument_ptr;
- MR_bool success;
+ MR_TypeInfo type_info;
+ MR_TypeInfo arg_type_info;
+ MR_Word *argument_ptr;
+ const MR_DuArgLocn *arg_locn_ptr;
+ MR_Word value;
+ MR_bool success;
type_info = (MR_TypeInfo) TYPEINFO_ARG;
MR_save_transient_registers();
success = arg_func(type_info, &TERM_ARG, SELECTOR_ARG, &arg_type_info,
- &argument_ptr, NONCANON);
+ &argument_ptr, &arg_locn_ptr, NONCANON);
MR_restore_transient_registers();
if (success) {
+ value = *argument_ptr;
+ if (arg_locn_ptr != NULL) {
+ value = MR_unpack_arg(value, arg_locn_ptr);
+ }
+
/*
** The following code is what *should* be here. The reason it is
** commented out, and the code to create a univ used instead, is
** the typechecking bug reported on 30 Jan, 2002.
**
- ** SELECTED_ARG = *argument_ptr;
+ ** SELECTED_ARG = value;
** SELECTED_TYPE_INFO = arg_type_info;
*/
- MR_new_univ_on_hp(SELECTED_ARG, arg_type_info, *argument_ptr);
+ MR_new_univ_on_hp(SELECTED_ARG, arg_type_info, value);
}
#ifdef SAVE_SUCCESS
diff --git a/runtime/mercury_ml_expand_body.h b/runtime/mercury_ml_expand_body.h
index c6eb568..c64c0e6 100644
--- a/runtime/mercury_ml_expand_body.h
+++ b/runtime/mercury_ml_expand_body.h
@@ -81,12 +81,15 @@
** The variants that return all the arguments do so in a field of type
** MR_Expand_Args_Fields. Its arg_type_infos subfield will contain a pointer
** to an array of arity MR_TypeInfos, one for each user-visible field of the
-** cell. The arg_values field will contain a pointer to a block of
-** arity + num_extra_args MR_Words, one for each field of the cell,
-** whether user-visible or not. The first num_extra_args words will be
+** cell. The arg_values field will contain a pointer to a block of MR_Words,
+** one for each field of the cell. The first num_extra_args words will be
** the type infos and/or typeclass infos added by the implementation to
-** describe the types of the existentially typed fields, while the last
-** arity words will be the user-visible fields themselves.
+** describe the types of the existentially typed fields, while the rest
+** will hold the user-visible constructor arguments, some of which may be
+** _packed_. The caller must unpack the actual values using the arg_locns
+** field. arg_locns will be NULL if there is no argument packing, or
+** otherwise point to an array of MR_DuArgLocns, one for every user-visible
+** argument.
**
** If the can_free_arg_type_infos field is true, then the array returned
** in the arg_type_infos field was allocated by this function, and should be
@@ -184,13 +187,8 @@
} while (0)
#define handle_type_functor_number(tci, ordinal) \
do { \
- if ((tci)->MR_type_ctor_version >= \
- MR_RTTI_VERSION__FUNCTOR_NUMBERS \
- && (tci)->MR_type_ctor_functor_number_map) \
- { \
- expand_info->functor_number = \
- (tci)->MR_type_ctor_functor_number_map[ordinal]; \
- } \
+ expand_info->functor_number = \
+ (tci)->MR_type_ctor_functor_number_map[ordinal]; \
} while (0)
#else /* EXPAND_FUNCTOR_FIELD */
#define handle_functor_name(name) \
@@ -211,6 +209,7 @@
#define handle_zero_arity_all_args() \
do { \
expand_info->EXPAND_ARGS_FIELD.arg_values = NULL; \
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL; \
expand_info->EXPAND_ARGS_FIELD.arg_type_infos = NULL; \
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0; \
} while (0)
@@ -551,6 +550,8 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
expand_info->EXPAND_ARGS_FIELD.num_extra_args = extra_args;
expand_info->EXPAND_ARGS_FIELD.arg_values = arg_vector;
+ expand_info->EXPAND_ARGS_FIELD.arg_locns =
+ functor_desc->MR_du_functor_arg_locns;
expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos =
MR_TRUE;
expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
@@ -593,9 +594,21 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
#endif /* EXPAND_NAMED_ARG */
if (0 <= chosen && chosen < expand_info->arity) {
+ const MR_DuArgLocn *arg_locn;
+ int slot;
+
+ if (functor_desc->MR_du_functor_arg_locns == NULL) {
+ arg_locn = NULL;
+ slot = extra_args + chosen;
+ } else {
+ arg_locn = &functor_desc->MR_du_functor_arg_locns[chosen];
+ slot = extra_args + arg_locn->MR_arg_offset;
+ }
+
expand_info->chosen_index_exists = MR_TRUE;
- expand_info->chosen_value_ptr =
- &arg_vector[extra_args + chosen];
+ expand_info->chosen_value_ptr = &arg_vector[slot];
+ expand_info->chosen_arg_locn = arg_locn;
+
if (MR_arg_type_may_contain_var(functor_desc, chosen)) {
expand_info->chosen_type_info =
MR_create_type_info_maybe_existq(
@@ -637,6 +650,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
#ifdef EXPAND_ARGS_FIELD
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
expand_info->EXPAND_ARGS_FIELD.arg_values = data_word_ptr;
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL;
expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos = MR_TRUE;
expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
MR_GC_NEW_ARRAY(MR_TypeInfo, 1);
@@ -661,6 +675,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
if (chosen == 0) {
expand_info->chosen_index_exists = MR_TRUE;
expand_info->chosen_value_ptr = data_word_ptr;
+ expand_info->chosen_arg_locn = NULL;
expand_info->chosen_type_info =
MR_create_type_info(
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
@@ -694,6 +709,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
#ifdef EXPAND_ARGS_FIELD
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
expand_info->EXPAND_ARGS_FIELD.arg_values = data_word_ptr;
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL;
expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos = MR_TRUE;
expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
MR_GC_NEW_ARRAY(MR_TypeInfo, 1);
@@ -717,6 +733,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
if (chosen == 0) {
expand_info->chosen_index_exists = MR_TRUE;
expand_info->chosen_value_ptr = data_word_ptr;
+ expand_info->chosen_arg_locn = NULL;
expand_info->chosen_type_info =
MR_pseudo_type_info_is_ground(
MR_type_ctor_layout(type_ctor_info).MR_layout_notag
@@ -907,6 +924,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
expand_info->EXPAND_ARGS_FIELD.arg_values = &closure->
MR_closure_hidden_args_0[0];
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL;
expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
MR_GC_NEW_ARRAY(MR_TypeInfo, num_args);
expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos =
@@ -930,6 +948,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
expand_info->chosen_index_exists = MR_TRUE;
expand_info->chosen_value_ptr =
&closure->MR_closure_hidden_args_0[chosen];
+ expand_info->chosen_arg_locn = NULL;
/* the following code could be improved */
type_params = MR_materialize_closure_type_params(closure);
expand_info->chosen_type_info =
@@ -965,6 +984,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
expand_info->EXPAND_ARGS_FIELD.arg_values =
(MR_Word *) *data_word_ptr;
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL;
/*
** Type-infos are normally counted from one, but
@@ -982,6 +1002,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
arg_vector = (MR_Word *) *data_word_ptr;
expand_info->chosen_index_exists = MR_TRUE;
expand_info->chosen_value_ptr = &arg_vector[chosen];
+ expand_info->chosen_arg_locn = NULL;
expand_info->chosen_type_info =
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info)[chosen + 1];
} else {
@@ -1105,6 +1126,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
expand_info->EXPAND_ARGS_FIELD.arg_values = arg_type_infos;
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL;
expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
MR_GC_NEW_ARRAY(MR_TypeInfo, num_args);
@@ -1128,6 +1150,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
arg_vector = (MR_Word *) data_type_info;
expand_info->chosen_index_exists = MR_TRUE;
expand_info->chosen_value_ptr = &arg_type_infos[chosen];
+ expand_info->chosen_arg_locn = NULL;
expand_info->chosen_type_info = type_info;
} else {
expand_info->chosen_index_exists = MR_FALSE;
@@ -1215,6 +1238,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
expand_info->EXPAND_ARGS_FIELD.arg_values = arg_type_infos;
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL;
expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
MR_GC_NEW_ARRAY(MR_TypeInfo, num_args);
@@ -1238,6 +1262,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
arg_vector = (MR_Word *) data_pseudo_type_info;
expand_info->chosen_index_exists = MR_TRUE;
expand_info->chosen_value_ptr = &arg_type_infos[chosen];
+ expand_info->chosen_arg_locn = NULL;
expand_info->chosen_type_info = type_info;
} else {
expand_info->chosen_index_exists = MR_FALSE;
@@ -1337,6 +1362,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
expand_info->EXPAND_ARGS_FIELD.num_extra_args = 0;
expand_info->EXPAND_ARGS_FIELD.arg_values =
&array->elements[0];
+ expand_info->EXPAND_ARGS_FIELD.arg_locns = NULL;
expand_info->EXPAND_ARGS_FIELD.can_free_arg_type_infos =
MR_TRUE;
expand_info->EXPAND_ARGS_FIELD.arg_type_infos =
@@ -1354,6 +1380,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
params = MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info);
expand_info->chosen_value_ptr = &array->elements[chosen];
+ expand_info->chosen_arg_locn = NULL;
expand_info->chosen_type_info = params[1];
expand_info->chosen_index_exists = MR_TRUE;
} else {
diff --git a/runtime/mercury_table_type_body.h b/runtime/mercury_table_type_body.h
index 8b94e69..a05ace2 100644
--- a/runtime/mercury_table_type_body.h
+++ b/runtime/mercury_table_type_body.h
@@ -221,6 +221,18 @@
}
for (i = 0; i < functor_desc->MR_du_functor_orig_arity; i++) {
+ const MR_DuArgLocn *arg_locn;
+ MR_Word arg_value;
+
+ if (functor_desc->MR_du_functor_arg_locns != NULL) {
+ arg_locn = &functor_desc->MR_du_functor_arg_locns[i];
+ arg_value = arg_vector[meta_args +
+ arg_locn->MR_arg_offset];
+ arg_value = MR_unpack_arg(arg_value, arg_locn);
+ } else {
+ arg_value = arg_vector[meta_args + i];
+ }
+
if (MR_arg_type_may_contain_var(functor_desc, i)) {
arg_type_info = MR_make_type_info_maybe_existq(
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
@@ -234,7 +246,7 @@
MR_table_record_arg_lookup();
MR_TABLE_ANY(STATS, DEBUG, BACK, "du arg",
table_next, table,
- arg_type_info, arg_vector[meta_args + i]);
+ arg_type_info, arg_value);
table = table_next;
}
diff --git a/runtime/mercury_type_info.c b/runtime/mercury_type_info.c
index 27217de..0d3d9d5 100644
--- a/runtime/mercury_type_info.c
+++ b/runtime/mercury_type_info.c
@@ -904,7 +904,15 @@ MR_typeclass_ref_error(MR_Word tci, int n, const char *msg)
return 0;
}
-/*---------------------------------------------------------------------------*/
+int
+MR_cell_size_for_args(int arity, const MR_DuArgLocn *arg_locns)
+{
+ if (arg_locns == NULL) {
+ return arity;
+ } else {
+ return arg_locns[arity - 1].MR_arg_offset + 1;
+ }
+}
void
MR_print_type(FILE *fp, MR_TypeInfo type_info)
diff --git a/runtime/mercury_type_info.h b/runtime/mercury_type_info.h
index c12974e..359d4c5 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__DIRECT_ARG
+#define MR_RTTI_VERSION MR_RTTI_VERSION__ARG_WIDTHS
#define MR_RTTI_VERSION__INITIAL 2
#define MR_RTTI_VERSION__USEREQ 3
#define MR_RTTI_VERSION__CLEAN_LAYOUT 4
@@ -86,6 +86,7 @@
#define MR_RTTI_VERSION__FUNCTOR_NUMBERS 12
#define MR_RTTI_VERSION__BITMAP 13
#define MR_RTTI_VERSION__DIRECT_ARG 14
+#define MR_RTTI_VERSION__ARG_WIDTHS 15
/*
** Check that the RTTI version is in a sensible range.
@@ -101,7 +102,7 @@
*/
#define MR_TYPE_CTOR_INFO_CHECK_RTTI_VERSION_RANGE(typector) \
- assert((typector)->MR_type_ctor_version >= MR_RTTI_VERSION__FUNCTOR_NUMBERS)
+ assert((typector)->MR_type_ctor_version >= MR_RTTI_VERSION__ARG_WIDTHS)
/*---------------------------------------------------------------------------*/
@@ -865,12 +866,17 @@ typedef struct {
** compiler-recorded information, these macros return conservative answers
** for any argument whose type is not represented in this bit vector.
**
-** The arg_name field points to an array of field names, one for each
+** The arg_names field points to an array of field names, one for each
** visible argument. If no argument has a name, this field will be NULL.
**
** If the functor has any arguments whose types include existentially
** quantified type variables, the exist_info field will point to information
** about those type variables; otherwise, the exist_info field will be NULL.
+**
+** If every argument occupies exactly one word each, then the arg_locns
+** field will be NULL. Otherwise, it points to an array of MR_DuArgLocn
+** structures, describing the location and packing scheme of each visible
+** argument.
*/
typedef enum {
@@ -882,6 +888,18 @@ typedef enum {
} MR_Sectag_Locn;
typedef struct {
+ MR_int_least16_t MR_arg_offset; /* not including extra args */
+ MR_int_least8_t MR_arg_shift;
+ MR_int_least8_t MR_arg_bits;
+ /*
+ ** If MR_arg_bits is zero then the argument occupies the entire word.
+ ** Otherwise MR_arg_bits is non-zero and gives the number of bits used by
+ ** the argument. Storing the bit-mask would be more useful, but would not
+ ** be as compact.
+ */
+} MR_DuArgLocn;
+
+typedef struct {
MR_ConstString MR_du_functor_name;
MR_int_least16_t MR_du_functor_orig_arity;
MR_int_least16_t MR_du_functor_arg_type_contains_var;
@@ -891,6 +909,7 @@ typedef struct {
MR_int_least32_t MR_du_functor_ordinal;
const MR_PseudoTypeInfo *MR_du_functor_arg_types;
const MR_ConstString *MR_du_functor_arg_names;
+ const MR_DuArgLocn *MR_du_functor_arg_locns;
const MR_DuExistInfo *MR_du_functor_exist_info;
} MR_DuFunctorDesc;
@@ -924,6 +943,12 @@ typedef const MR_DuFunctorDesc *MR_DuFunctorDescPtr;
#define MR_some_arg_type_contains_var(functor_desc) \
((functor_desc)->MR_du_functor_arg_type_contains_var > 0)
+#define MR_unpack_arg(val, arg_locn) \
+ ((arg_locn)->MR_arg_bits == 0 \
+ ? (val) \
+ : ((val) >> (arg_locn)->MR_arg_shift) & \
+ ((MR_Word) (1 << (arg_locn)->MR_arg_bits) - 1))
+
/*---------------------------------------------------------------------------*/
typedef struct {
@@ -1403,7 +1428,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__DIRECT_ARG, \
+ MR_RTTI_VERSION__ARG_WIDTHS, \
-1, \
MR_PASTE2(MR_TYPECTOR_REP_, cr), \
MR_DEFINE_TYPE_CTOR_INFO_CODE(u), \
@@ -1897,6 +1922,17 @@ extern MR_Word MR_pseudo_type_info_vector_to_pseudo_type_info_list(
const MR_PseudoTypeInfo *arg_pseudo_type_infos);
/*
+** MR_cell_size_for_args:
+**
+** Return the number of words required to hold the visible arguments of a
+** constructor. That is, it does not count extra arguments, an optional
+** secondary tag, or the additional slot for term size profiling.
+*/
+
+extern int MR_cell_size_for_args(int arity,
+ const MR_DuArgLocn *arg_locns);
+
+/*
** MR_print_type:
**
** Print a representation of the type represented by the given typeinfo to the
diff --git a/tests/hard_coded/Mercury.options b/tests/hard_coded/Mercury.options
index 3d9a64a..f13f090 100644
--- a/tests/hard_coded/Mercury.options
+++ b/tests/hard_coded/Mercury.options
@@ -51,8 +51,10 @@ MCFLAGS-intermod_multimode_main = --intermodule-optimization
MCFLAGS-lco_mday_bug_1 = --optimize-constructor-last-call
MCFLAGS-lco_mday_bug_2 = --optimize-constructor-last-call
MCFLAGS-lco_no_inline = --optimize-constructor-last-call --no-inline-builtins
+MCFLAGS-lco_pack_args = --optimize-constructor-last-call
MCFLAGS-lookup_switch_simple_non = --no-warn-det-decls-too-lax
MCFLAGS-opt_format = --optimize-format-calls
+MCFLAGS-pack_args_reuse = --structure-reuse
MCFLAGS-reuse_ho = --ctgc --no-optimise-higher-order
MCFLAGS-sharing_comb = --ctgc --structure-sharing-widening 2
MCFLAGS-simplify_multi_arm_switch = -O3
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 5ccabd3..0da1241 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -154,6 +154,7 @@ ORDINARY_PROGS= \
intermod_unused_args \
java_rtti_bug \
join_list \
+ lco_pack_args \
lco_mday_bug_1 \
lco_mday_bug_2 \
lco_no_inline \
@@ -193,6 +194,10 @@ ORDINARY_PROGS= \
one_member \
opt_dup_bug \
opt_format \
+ pack_args \
+ pack_args_copy \
+ pack_args_intermod1 \
+ pack_args_reuse \
ppc_bug \
pprint_test \
pprint_test2 \
diff --git a/tests/hard_coded/deconstruct_arg.exp b/tests/hard_coded/deconstruct_arg.exp
index afaea87..d4af6b7 100644
--- a/tests/hard_coded/deconstruct_arg.exp
+++ b/tests/hard_coded/deconstruct_arg.exp
@@ -4,6 +4,9 @@ deconstruct argument 1 of apple([]) doesn't exist
deconstruct argument 2 of apple([]) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor apple arity 1
[[]]
deconstruct limited deconstruct 3 of apple([])
@@ -15,6 +18,9 @@ deconstruct argument 1 of apple([9, 5, 1]) doesn't exist
deconstruct argument 2 of apple([9, 5, 1]) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor apple arity 1
[[9, 5, 1]]
deconstruct limited deconstruct 3 of apple([9, 5, 1])
@@ -26,6 +32,9 @@ deconstruct argument 1 of zop(3.3, 2.03) is 2.03
deconstruct argument 2 of zop(3.3, 2.03) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor zop arity 2
[3.3, 2.03]
deconstruct limited deconstruct 3 of zop(3.3, 2.03)
@@ -37,6 +46,9 @@ deconstruct argument 1 of zap(50, 51.0, 52) is 51.0
deconstruct argument 2 of zap(50, 51.0, 52) is 52
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor zap arity 3
[50, 51.0, 52]
deconstruct limited deconstruct 3 of zap(50, 51.0, 52)
@@ -48,6 +60,9 @@ deconstruct argument 1 of zip(50, 51, 52, 53) is 51
deconstruct argument 2 of zip(50, 51, 52, 53) is 52
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor zip arity 4
[50, 51, 52, 53]
deconstruct limited deconstruct 3 of zip(50, 51, 52, 53)
@@ -59,6 +74,9 @@ deconstruct argument 1 of wombat doesn't exist
deconstruct argument 2 of wombat doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor wombat arity 0
[]
deconstruct limited deconstruct 3 of wombat
@@ -70,6 +88,9 @@ deconstruct argument 1 of qwerty(5) doesn't exist
deconstruct argument 2 of qwerty(5) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor qwerty arity 1
[5]
deconstruct limited deconstruct 3 of qwerty(5)
@@ -81,6 +102,9 @@ deconstruct argument 1 of moomoo(50, "moo.") is "moo."
deconstruct argument 2 of moomoo(50, "moo.") doesn't exist
deconstruct argument 'moo' is 50
deconstruct argument 'mooo!' is "moo."
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor moomoo arity 2
[50, "moo."]
deconstruct limited deconstruct 3 of moomoo(50, "moo.")
@@ -92,6 +116,9 @@ deconstruct argument 1 of a doesn't exist
deconstruct argument 2 of a doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor 'a' arity 0
[]
deconstruct limited deconstruct 3 of a
@@ -103,6 +130,9 @@ deconstruct argument 1 of 0.12345678901234566 doesn't exist
deconstruct argument 2 of 0.12345678901234566 doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor 0.12345678901234566 arity 0
[]
deconstruct limited deconstruct 3 of 0.12345678901234566
@@ -114,6 +144,9 @@ deconstruct argument 1 of 4 doesn't exist
deconstruct argument 2 of 4 doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor 4 arity 0
[]
deconstruct limited deconstruct 3 of 4
@@ -125,6 +158,9 @@ deconstruct argument 1 of ["hi! I\'m a univ!"] doesn't exist
deconstruct argument 2 of ["hi! I\'m a univ!"] doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor univ_cons arity 1
[["hi! I\'m a univ!"]]
deconstruct limited deconstruct 3 of ["hi! I\'m a univ!"]
@@ -136,6 +172,9 @@ deconstruct argument 1 of '<<deconstruct_arg.set/1>>' doesn't exist
deconstruct argument 2 of '<<deconstruct_arg.set/1>>' doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor set_rep arity 1
[[1, 2, 3, 3]]
deconstruct limited deconstruct 3 of '<<deconstruct_arg.set/1>>'
@@ -147,21 +186,27 @@ deconstruct argument 1 of '<<predicate>>' doesn't exist
deconstruct argument 2 of '<<predicate>>' doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor newline arity 0
[]
deconstruct limited deconstruct 3 of '<<predicate>>'
functor newline arity 0 []
-deconstruct functor: lambda_deconstruct_arg_m_114/1
+deconstruct functor: lambda_deconstruct_arg_m_121/1
deconstruct argument 0 of '<<predicate>>' is [1, 2]
deconstruct argument 1 of '<<predicate>>' doesn't exist
deconstruct argument 2 of '<<predicate>>' doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
-deconstruct deconstruct: functor lambda_deconstruct_arg_m_114 arity 1
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
+deconstruct deconstruct: functor lambda_deconstruct_arg_m_121 arity 1
[[1, 2]]
deconstruct limited deconstruct 3 of '<<predicate>>'
-functor lambda_deconstruct_arg_m_114 arity 1 [[1, 2]]
+functor lambda_deconstruct_arg_m_121 arity 1 [[1, 2]]
deconstruct functor: {}/2
deconstruct argument 0 of {1, 'b'} is 1
@@ -169,6 +214,9 @@ deconstruct argument 1 of {1, 'b'} is 'b'
deconstruct argument 2 of {1, 'b'} doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor {} arity 2
[1, 'b']
deconstruct limited deconstruct 3 of {1, 'b'}
@@ -180,6 +228,9 @@ deconstruct argument 1 of {1, 'b', "third"} is 'b'
deconstruct argument 2 of {1, 'b', "third"} is "third"
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor {} arity 3
[1, 'b', "third"]
deconstruct limited deconstruct 3 of {1, 'b', "third"}
@@ -191,6 +242,9 @@ deconstruct argument 1 of {1, 'b', "third", {1, 2, 3, 4}} is 'b'
deconstruct argument 2 of {1, 'b', "third", {1, 2, 3, 4}} is "third"
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor {} arity 4
[1, 'b', "third", {1, 2, 3, 4}]
deconstruct limited deconstruct 3 of {1, 'b', "third", {1, 2, 3, 4}}
@@ -202,6 +256,9 @@ deconstruct argument 1 of array([1000, 2000]) is 2000
deconstruct argument 2 of array([1000, 2000]) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<array>> arity 2
[1000, 2000]
deconstruct limited deconstruct 3 of array([1000, 2000])
@@ -213,6 +270,9 @@ deconstruct argument 1 of array([100, 200, 300]) is 200
deconstruct argument 2 of array([100, 200, 300]) is 300
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<array>> arity 3
[100, 200, 300]
deconstruct limited deconstruct 3 of array([100, 200, 300])
@@ -224,8 +284,25 @@ deconstruct argument 1 of array([10, 20, 30, 40]) is 20
deconstruct argument 2 of array([10, 20, 30, 40]) is 30
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<array>> arity 4
[10, 20, 30, 40]
deconstruct limited deconstruct 3 of array([10, 20, 30, 40])
failed
+deconstruct functor: packed/5
+deconstruct argument 0 of packed(100, one, two, three, "four") is 100
+deconstruct argument 1 of packed(100, one, two, three, "four") is one
+deconstruct argument 2 of packed(100, one, two, three, "four") is two
+deconstruct argument 'moo' doesn't exist
+deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' is 100
+deconstruct argument 'packed2' is one
+deconstruct argument 'packed3' is two
+deconstruct deconstruct: functor packed arity 5
+[100, one, two, three, "four"]
+deconstruct limited deconstruct 3 of packed(100, one, two, three, "four")
+failed
+
diff --git a/tests/hard_coded/deconstruct_arg.exp2 b/tests/hard_coded/deconstruct_arg.exp2
index a925d24..c59f29d 100644
--- a/tests/hard_coded/deconstruct_arg.exp2
+++ b/tests/hard_coded/deconstruct_arg.exp2
@@ -4,6 +4,9 @@ deconstruct argument 1 of apple([]) doesn't exist
deconstruct argument 2 of apple([]) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor apple arity 1
[[]]
deconstruct limited deconstruct 3 of apple([])
@@ -15,6 +18,9 @@ deconstruct argument 1 of apple([9, 5, 1]) doesn't exist
deconstruct argument 2 of apple([9, 5, 1]) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor apple arity 1
[[9, 5, 1]]
deconstruct limited deconstruct 3 of apple([9, 5, 1])
@@ -26,6 +32,9 @@ deconstruct argument 1 of zop(3.3, 2.03) is 2.03
deconstruct argument 2 of zop(3.3, 2.03) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor zop arity 2
[3.3, 2.03]
deconstruct limited deconstruct 3 of zop(3.3, 2.03)
@@ -37,6 +46,9 @@ deconstruct argument 1 of zap(50, 51.0, 52) is 51.0
deconstruct argument 2 of zap(50, 51.0, 52) is 52
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor zap arity 3
[50, 51.0, 52]
deconstruct limited deconstruct 3 of zap(50, 51.0, 52)
@@ -48,6 +60,9 @@ deconstruct argument 1 of zip(50, 51, 52, 53) is 51
deconstruct argument 2 of zip(50, 51, 52, 53) is 52
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor zip arity 4
[50, 51, 52, 53]
deconstruct limited deconstruct 3 of zip(50, 51, 52, 53)
@@ -59,6 +74,9 @@ deconstruct argument 1 of wombat doesn't exist
deconstruct argument 2 of wombat doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor wombat arity 0
[]
deconstruct limited deconstruct 3 of wombat
@@ -70,6 +88,9 @@ deconstruct argument 1 of qwerty(5) doesn't exist
deconstruct argument 2 of qwerty(5) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor qwerty arity 1
[5]
deconstruct limited deconstruct 3 of qwerty(5)
@@ -81,6 +102,9 @@ deconstruct argument 1 of moomoo(50, "moo.") is "moo."
deconstruct argument 2 of moomoo(50, "moo.") doesn't exist
deconstruct argument 'moo' is 50
deconstruct argument 'mooo!' is "moo."
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor moomoo arity 2
[50, "moo."]
deconstruct limited deconstruct 3 of moomoo(50, "moo.")
@@ -92,6 +116,9 @@ deconstruct argument 1 of a doesn't exist
deconstruct argument 2 of a doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor 'a' arity 0
[]
deconstruct limited deconstruct 3 of a
@@ -103,6 +130,9 @@ deconstruct argument 1 of 0.12345678901234566 doesn't exist
deconstruct argument 2 of 0.12345678901234566 doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor 0.12345678901234566 arity 0
[]
deconstruct limited deconstruct 3 of 0.12345678901234566
@@ -114,6 +144,9 @@ deconstruct argument 1 of 4 doesn't exist
deconstruct argument 2 of 4 doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor 4 arity 0
[]
deconstruct limited deconstruct 3 of 4
@@ -125,6 +158,9 @@ deconstruct argument 1 of ["hi! I\'m a univ!"] doesn't exist
deconstruct argument 2 of ["hi! I\'m a univ!"] doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor univ_cons arity 1
[["hi! I\'m a univ!"]]
deconstruct limited deconstruct 3 of ["hi! I\'m a univ!"]
@@ -136,6 +172,9 @@ deconstruct argument 1 of '<<deconstruct_arg.set/1>>' doesn't exist
deconstruct argument 2 of '<<deconstruct_arg.set/1>>' doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor set_rep arity 1
[[1, 2, 3, 3]]
deconstruct limited deconstruct 3 of '<<deconstruct_arg.set/1>>'
@@ -147,6 +186,9 @@ deconstruct argument 1 of '<<predicate>>' doesn't exist
deconstruct argument 2 of '<<predicate>>' doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<predicate>> arity 0
[]
deconstruct limited deconstruct 3 of '<<predicate>>'
@@ -158,6 +200,9 @@ deconstruct argument 1 of '<<predicate>>' doesn't exist
deconstruct argument 2 of '<<predicate>>' doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<predicate>> arity 0
[]
deconstruct limited deconstruct 3 of '<<predicate>>'
@@ -169,6 +214,9 @@ deconstruct argument 1 of {1, 'b'} is 'b'
deconstruct argument 2 of {1, 'b'} doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor {} arity 2
[1, 'b']
deconstruct limited deconstruct 3 of {1, 'b'}
@@ -180,6 +228,9 @@ deconstruct argument 1 of {1, 'b', "third"} is 'b'
deconstruct argument 2 of {1, 'b', "third"} is "third"
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor {} arity 3
[1, 'b', "third"]
deconstruct limited deconstruct 3 of {1, 'b', "third"}
@@ -191,6 +242,9 @@ deconstruct argument 1 of {1, 'b', "third", {1, 2, 3, 4}} is 'b'
deconstruct argument 2 of {1, 'b', "third", {1, 2, 3, 4}} is "third"
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor {} arity 4
[1, 'b', "third", {1, 2, 3, 4}]
deconstruct limited deconstruct 3 of {1, 'b', "third", {1, 2, 3, 4}}
@@ -202,6 +256,9 @@ deconstruct argument 1 of array([1000, 2000]) is 2000
deconstruct argument 2 of array([1000, 2000]) doesn't exist
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<array>> arity 2
[1000, 2000]
deconstruct limited deconstruct 3 of array([1000, 2000])
@@ -213,6 +270,9 @@ deconstruct argument 1 of array([100, 200, 300]) is 200
deconstruct argument 2 of array([100, 200, 300]) is 300
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<array>> arity 3
[100, 200, 300]
deconstruct limited deconstruct 3 of array([100, 200, 300])
@@ -224,8 +284,25 @@ deconstruct argument 1 of array([10, 20, 30, 40]) is 20
deconstruct argument 2 of array([10, 20, 30, 40]) is 30
deconstruct argument 'moo' doesn't exist
deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' doesn't exist
+deconstruct argument 'packed2' doesn't exist
+deconstruct argument 'packed3' doesn't exist
deconstruct deconstruct: functor <<array>> arity 4
[10, 20, 30, 40]
deconstruct limited deconstruct 3 of array([10, 20, 30, 40])
failed
+deconstruct functor: packed/5
+deconstruct argument 0 of packed(100, one, two, three, "four") is 100
+deconstruct argument 1 of packed(100, one, two, three, "four") is one
+deconstruct argument 2 of packed(100, one, two, three, "four") is two
+deconstruct argument 'moo' doesn't exist
+deconstruct argument 'mooo!' doesn't exist
+deconstruct argument 'packed1' is 100
+deconstruct argument 'packed2' is one
+deconstruct argument 'packed3' is two
+deconstruct deconstruct: functor packed arity 5
+[100, one, two, three, "four"]
+deconstruct limited deconstruct 3 of packed(100, one, two, three, "four")
+failed
+
diff --git a/tests/hard_coded/deconstruct_arg.m b/tests/hard_coded/deconstruct_arg.m
index 7977528..af0a70b 100644
--- a/tests/hard_coded/deconstruct_arg.m
+++ b/tests/hard_coded/deconstruct_arg.m
@@ -45,6 +45,13 @@
; moomoo(
moo :: int,
'mooo!' :: string
+ )
+ ; packed(
+ packed1 :: int,
+ packed2 :: enum,
+ packed3 :: enum,
+ packed4 :: enum,
+ packed5 :: string
).
:- type poly(A, B)
@@ -119,7 +126,9 @@ main -->
% test arrays
test_all(array([1000, 2000])), newline,
test_all(array([100, 200, 300])), newline,
- test_all(array([10, 20, 30, 40])), newline.
+ test_all(array([10, 20, 30, 40])), newline,
+ % test packed fields
+ test_all(packed(100, one, two, three, "four")), newline.
%-----------------------------------------------------------------------------%
@@ -132,6 +141,9 @@ test_all(T) -->
test_deconstruct_arg(T, 2),
test_deconstruct_named_arg(T, "moo"),
test_deconstruct_named_arg(T, "mooo!"),
+ test_deconstruct_named_arg(T, "packed1"),
+ test_deconstruct_named_arg(T, "packed2"),
+ test_deconstruct_named_arg(T, "packed3"),
test_deconstruct_deconstruct(T),
test_deconstruct_limited_deconstruct(T, 3).
diff --git a/tests/hard_coded/lco_pack_args.exp b/tests/hard_coded/lco_pack_args.exp
new file mode 100644
index 0000000..387e4b3
--- /dev/null
+++ b/tests/hard_coded/lco_pack_args.exp
@@ -0,0 +1 @@
+thing(enum1, enum1, thing(enum2, enum2, thing(enum3, enum3, nil, enum3, enum3), enum2, enum2), enum1, enum1)
diff --git a/tests/hard_coded/lco_pack_args.m b/tests/hard_coded/lco_pack_args.m
new file mode 100644
index 0000000..9c8bcdc
--- /dev/null
+++ b/tests/hard_coded/lco_pack_args.m
@@ -0,0 +1,39 @@
+%-----------------------------------------------------------------------------%
+
+:- module lco_pack_args.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+
+:- type thing
+ ---> thing(enum, enum, thing, enum, enum) % 5 words -> 3 words
+ ; nil.
+
+:- type enum
+ ---> enum1
+ ; enum2
+ ; enum3.
+
+:- pred gen(list(enum)::in, thing::out) is det.
+
+gen([], nil).
+gen([E | Es], T) :-
+ gen(Es, Tail),
+ T = thing(E, E, Tail, E, E).
+
+main(!IO) :-
+ gen([enum1, enum2, enum3], T),
+ io.write(T, !IO),
+ io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/pack_args.exp b/tests/hard_coded/pack_args.exp
new file mode 100644
index 0000000..699b6b1
--- /dev/null
+++ b/tests/hard_coded/pack_args.exp
@@ -0,0 +1,3 @@
+ant, bat, 1000, string, cat, dog, eel, fox
+pug, owl, 1000, string, newt, moa, lark, jay
+pug, owl, 1000, string, newt, moa, lark, jay
diff --git a/tests/hard_coded/pack_args.m b/tests/hard_coded/pack_args.m
new file mode 100644
index 0000000..bc63f2d
--- /dev/null
+++ b/tests/hard_coded/pack_args.m
@@ -0,0 +1,86 @@
+%-----------------------------------------------------------------------------%
+
+:- module pack_args.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- type animal
+ ---> ant % 0
+ ; bat % 1
+ ; cat % 2
+ ; dog % 3
+ ; eel % 4
+ ; fox % 5
+ ; gnu % 6
+ ; hog % 7
+ ; ibis % 8
+ ; jay % 9
+ ; kea % 10
+ ; lark % 11
+ ; moa % 12
+ ; newt % 13
+ ; owl % 14
+ ; pug. % 15
+
+:- type struct
+ ---> struct(
+ animal, animal, % word 0
+ int, % word 1
+ string, % word 2
+ animal, animal, animal, animal % word 3
+ ).
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ Static = struct(ant, bat, 1000, "string", cat, dog, eel, fox),
+ write_struct(Static, !IO),
+ io.nl(!IO),
+
+ Dynamic = struct(ani(pug), ani(owl), 1000, "string",
+ ani(newt), ani(moa), lark, jay),
+ write_struct(Dynamic, !IO),
+ io.nl(!IO),
+
+ Dynamic2 = struct(ani(pug), _, _, _, _, _, _, _),
+ Dynamic2 = struct(_, ani(owl), _, _, _, _, _, _),
+ Dynamic2 = struct(_, _, 1000, _, _, _, _, _),
+ Dynamic2 = struct(_, _, _, "string", _, _, _, _),
+ Dynamic2 = struct(_, _, _, _, ani(newt), moa, lark, _),
+ Dynamic2 = struct(_, _, _, _, _, _, _, jay),
+ write_struct(Dynamic2, !IO),
+ io.nl(!IO).
+
+:- func ani(animal) = animal.
+:- pragma no_inline(ani/1).
+
+ani(X) = X.
+
+:- pred write_struct(struct::in, io::di, io::uo) is det.
+:- pragma no_inline(write_struct/3).
+
+write_struct(struct(A, B, I, S, C, D, E, F), !IO) :-
+ write_animal(A, !IO), write_string(", ", !IO),
+ write_animal(B, !IO), write_string(", ", !IO),
+ write_int(I, !IO), write_string(", ", !IO),
+ write_string(S, !IO), write_string(", ", !IO),
+ write_animal(C, !IO), write_string(", ", !IO),
+ write_animal(D, !IO), write_string(", ", !IO),
+ write_animal(E, !IO), write_string(", ", !IO),
+ write_animal(F, !IO).
+
+:- pred write_animal(animal::in, io::di, io::uo) is det.
+
+write_animal(Animal, !IO) :-
+ write(Animal, !IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/pack_args_copy.exp b/tests/hard_coded/pack_args_copy.exp
new file mode 100644
index 0000000..45d3b15
--- /dev/null
+++ b/tests/hard_coded/pack_args_copy.exp
@@ -0,0 +1,2 @@
+struct(aa, bb, "string", cc, dd)
+struct(aa, bb, "string", cc, dd)
diff --git a/tests/hard_coded/pack_args_copy.m b/tests/hard_coded/pack_args_copy.m
new file mode 100644
index 0000000..fafd4cb
--- /dev/null
+++ b/tests/hard_coded/pack_args_copy.m
@@ -0,0 +1,32 @@
+%-----------------------------------------------------------------------------%
+
+:- module pack_args_copy.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- type enum ---> aa ; bb ; cc ; dd.
+:- type enum(T) ---> aa ; bb ; cc ; dd.
+
+:- type struct(T)
+ ---> struct(enum(T), enum, T, enum(T), enum(T)).
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ S0 = struct(aa, bb, "string", cc, dd),
+ copy(S0, S),
+ io.write(S0, !IO),
+ io.nl(!IO),
+ io.write(S, !IO),
+ io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/pack_args_intermod1.exp b/tests/hard_coded/pack_args_intermod1.exp
new file mode 100644
index 0000000..071e9b7
--- /dev/null
+++ b/tests/hard_coded/pack_args_intermod1.exp
@@ -0,0 +1 @@
+hog, gnu, 1000, string, fox, eel, dog, cat
diff --git a/tests/hard_coded/pack_args_intermod1.m b/tests/hard_coded/pack_args_intermod1.m
new file mode 100644
index 0000000..1cd3793
--- /dev/null
+++ b/tests/hard_coded/pack_args_intermod1.m
@@ -0,0 +1,30 @@
+%-----------------------------------------------------------------------------%
+
+:- module pack_args_intermod1.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module pack_args_intermod2.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ % Construct here.
+ Dynamic = struct(
+ ani(70), ani(60), 1000, "string",
+ ani(50), ani(40), ani(30), ani(20)
+ ),
+ % Deconstruct there.
+ pack_args_intermod2.write_struct(Dynamic, !IO),
+ io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/pack_args_intermod2.m b/tests/hard_coded/pack_args_intermod2.m
new file mode 100644
index 0000000..a59f93e
--- /dev/null
+++ b/tests/hard_coded/pack_args_intermod2.m
@@ -0,0 +1,64 @@
+%-----------------------------------------------------------------------------%
+
+:- module pack_args_intermod2.
+:- interface.
+
+:- import_module io.
+
+:- type animal.
+
+:- type struct
+ ---> struct(
+ animal, animal, % word 0
+ int, % word 1
+ string, % word 2
+ animal, animal, animal, animal % word 3
+ ).
+
+:- func ani(int) = animal.
+
+:- pred write_struct(struct::in, io::di, io::uo) is det.
+
+:- pred write_animal(animal::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- type animal
+ ---> ant % 0
+ ; bat % 1
+ ; cat % 2
+ ; dog % 3
+ ; eel % 4
+ ; fox % 5
+ ; gnu % 6
+ ; hog. % 7
+
+ani(I) =
+ ( I = 0 -> ant
+ ; I = 10 -> bat
+ ; I = 20 -> cat
+ ; I = 30 -> dog
+ ; I = 40 -> eel
+ ; I = 50 -> fox
+ ; I = 60 -> gnu
+ ; hog
+ ).
+
+write_struct(struct(A, B, I, S, C, D, E, F), !IO) :-
+ write_animal(A, !IO), write_string(", ", !IO),
+ write_animal(B, !IO), write_string(", ", !IO),
+ write_int(I, !IO), write_string(", ", !IO),
+ write_string(S, !IO), write_string(", ", !IO),
+ write_animal(C, !IO), write_string(", ", !IO),
+ write_animal(D, !IO), write_string(", ", !IO),
+ write_animal(E, !IO), write_string(", ", !IO),
+ write_animal(F, !IO).
+
+write_animal(Animal, !IO) :-
+ write(Animal, !IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/pack_args_reuse.exp b/tests/hard_coded/pack_args_reuse.exp
new file mode 100644
index 0000000..adbbb95
--- /dev/null
+++ b/tests/hard_coded/pack_args_reuse.exp
@@ -0,0 +1 @@
+struct(aa, xx, cc, "str", dd, ee)
diff --git a/tests/hard_coded/pack_args_reuse.m b/tests/hard_coded/pack_args_reuse.m
new file mode 100644
index 0000000..70b9556
--- /dev/null
+++ b/tests/hard_coded/pack_args_reuse.m
@@ -0,0 +1,50 @@
+%-----------------------------------------------------------------------------%
+% Check structure reuse takes into account argument packing.
+
+:- module pack_args_reuse.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- type struct
+ ---> struct(enum, enum, enum, string, enum, enum). % 3 words
+
+:- inst uniq_struct
+ == unique(struct(ground, ground, ground, ground, ground, ground)).
+
+:- type enum
+ ---> aa ; bb ; cc ; dd ; ee ; xx.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ T0 = struct(aa, bb, cc, str, dd, ee),
+ update2(xx, T0, T),
+ io.write(T, !IO),
+ nl(!IO).
+
+:- pred update2(enum::in, struct::di(uniq_struct), struct::out(uniq_struct))
+ is det.
+:- pragma no_inline(update2/3).
+
+update2(X, T0, T) :-
+ T0 = struct(A, _, C, D, E, F),
+ % field 0 (A,X,C) needs update
+ % field 1 (D) does not need update
+ % field 2 (E,F) does not need update
+ T = struct(A, X, C, D, E, F).
+
+:- func str = string.
+:- pragma no_inline(str/0).
+
+str = "str".
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/hard_coded/store_ref.exp b/tests/hard_coded/store_ref.exp
new file mode 100644
index 0000000..da8053c
--- /dev/null
+++ b/tests/hard_coded/store_ref.exp
@@ -0,0 +1,5 @@
+{"struct", 7}
+struct(1, 2.2, enum1, enum2, enum3, "four", {5, 6})
+{1, 2.2, enum1, enum2, "four", {5, 6}}
+{2.2, 3.3}
+{enum2, enum3}
diff --git a/tests/hard_coded/store_ref.m b/tests/hard_coded/store_ref.m
new file mode 100644
index 0000000..74dcfac
--- /dev/null
+++ b/tests/hard_coded/store_ref.m
@@ -0,0 +1,70 @@
+% Test store references (bleh!)
+
+:- module store_ref.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module store.
+
+:- type enum
+ ---> enum1
+ ; enum2
+ ; enum3.
+
+:- type struct
+ ---> unused_struct(int, int)
+ ; struct(int, float, enum, enum, enum, string, {int, int}).
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ Term = struct(1, 2.2, enum1, enum2, enum3, "four", {5, 6}),
+ new_ref(Term, TermRef, !IO),
+ ref_functor(TermRef, Functor, Arity, !IO),
+ io.write({Functor, Arity}, !IO),
+ io.nl(!IO),
+ copy_ref_value(TermRef, CopyTerm, !IO),
+ io.write(CopyTerm, !IO),
+ io.nl(!IO),
+
+ arg_ref(TermRef, 0, IntRef, !IO),
+ arg_ref(TermRef, 1, FloatRef, !IO),
+ arg_ref(TermRef, 2, EnumRefA, !IO),
+ arg_ref(TermRef, 3, EnumRefB, !IO),
+ arg_ref(TermRef, 5, StringRef, !IO),
+ arg_ref(TermRef, 6, TupleRef, !IO),
+ copy_ref_value(IntRef, Int : int, !IO),
+ copy_ref_value(FloatRef, Float : float, !IO),
+ copy_ref_value(EnumRefA, EnumA : enum, !IO),
+ copy_ref_value(EnumRefB, EnumB : enum, !IO),
+ copy_ref_value(StringRef, String : string, !IO),
+ copy_ref_value(TupleRef, Tuple : {int, int}, !IO),
+ io.write({Int, Float, EnumA, EnumB, String, Tuple}, !IO),
+ io.nl(!IO),
+
+ copy(Term, TermA),
+ new_arg_ref(TermA, 1, NewFloatRef, !IO),
+ copy_ref_value(NewFloatRef, NewFloatA, !IO),
+ set_ref_value(NewFloatRef, 3.3, !IO),
+ copy_ref_value(NewFloatRef, NewFloatB, !IO),
+ io.write({NewFloatA, NewFloatB}, !IO),
+ io.nl(!IO),
+
+ copy(Term, TermB),
+ new_arg_ref(TermB, 3, NewEnumRef, !IO), % enum2
+ copy_ref_value(NewEnumRef, NewEnumA, !IO),
+ set_ref_value(NewEnumRef, enum3, !IO),
+ copy_ref_value(NewEnumRef, NewEnumB, !IO),
+ io.write({NewEnumA, NewEnumB}, !IO),
+ io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile
index 3c21529..62fd46a 100644
--- a/tests/invalid/Mmakefile
+++ b/tests/invalid/Mmakefile
@@ -251,6 +251,7 @@ SINGLEMODULE= \
user_eq_dummy \
uu_type \
vars_in_wrong_places \
+ where_abstract_enum \
where_direct_arg \
where_direct_arg2 \
with_type \
diff --git a/tests/invalid/where_abstract_enum.err_exp b/tests/invalid/where_abstract_enum.err_exp
new file mode 100644
index 0000000..bb749a3
--- /dev/null
+++ b/tests/invalid/where_abstract_enum.err_exp
@@ -0,0 +1,3 @@
+where_abstract_enum.m:011: Error: invalid argument for type_is_abstract_enum.
+where_abstract_enum.m:013: Error: invalid `where ...' attributes for abstract
+where_abstract_enum.m:013: non-solver type.
diff --git a/tests/invalid/where_abstract_enum.m b/tests/invalid/where_abstract_enum.m
new file mode 100644
index 0000000..8a1118f
--- /dev/null
+++ b/tests/invalid/where_abstract_enum.m
@@ -0,0 +1,20 @@
+%-----------------------------------------------------------------------------%
+
+:- module where_abstract_enum.
+:- interface.
+
+:- type abs1
+ ---> abs1
+ ; abs2
+ ; abs3.
+
+:- type abs2 where type_is_abstract_enum.
+
+:- type abs3 where blah.
+
+:- implementation.
+
+:- type abs1 where type_is_abstract_enum(3).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/invalid/where_direct_arg.err_exp b/tests/invalid/where_direct_arg.err_exp
index 91e8017..acc593a 100644
--- a/tests/invalid/where_direct_arg.err_exp
+++ b/tests/invalid/where_direct_arg.err_exp
@@ -3,7 +3,7 @@ where_direct_arg.m:012: symbol whose arity is not 1.
where_direct_arg.m:012: Error: the `direct_arg' attribute lists the function
where_direct_arg.m:012: symbol `where_direct_arg.nonexistent'/1 which is not
where_direct_arg.m:012: in the type definition.
-where_direct_arg.m:016: Error: only solver types can be defined by a `where'
-where_direct_arg.m:016: block alone.
+where_direct_arg.m:016: Error: invalid `where ...' attributes for abstract
+where_direct_arg.m:016: non-solver type.
where_direct_arg.m:018: Error: solver type definitions cannot have `direct_arg'
where_direct_arg.m:018: attributes.
diff --git a/tests/tabling/Mmakefile b/tests/tabling/Mmakefile
index 2e7e49e..ea52404 100644
--- a/tests/tabling/Mmakefile
+++ b/tests/tabling/Mmakefile
@@ -23,6 +23,7 @@ SIMPLE_NONLOOP_PROGS = \
mercury_java_parser_dead_proc_elim_bug \
mercury_java_parser_dead_proc_elim_bug2 \
oota \
+ pack_args_memo \
reset_stats_intermod \
specified_hidden_arg \
table_foreign_output \
diff --git a/tests/tabling/pack_args_memo.exp b/tests/tabling/pack_args_memo.exp
new file mode 100644
index 0000000..e2a2797
--- /dev/null
+++ b/tests/tabling/pack_args_memo.exp
@@ -0,0 +1,2 @@
+struct(aa, bb, cc, dd)
+struct(aa, bb, cc, dd)
diff --git a/tests/tabling/pack_args_memo.m b/tests/tabling/pack_args_memo.m
new file mode 100644
index 0000000..f23ad7c
--- /dev/null
+++ b/tests/tabling/pack_args_memo.m
@@ -0,0 +1,42 @@
+%-----------------------------------------------------------------------------%
+
+:- module pack_args_memo.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+
+:- type struct
+ ---> struct(enum, enum, enum, enum).
+
+:- type enum
+ ---> aa ; bb ; cc ; dd.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ F = struct(aa, bb, cc, dd),
+ copy(F, Fcopy),
+ G1 = id(F),
+ G2 = id(Fcopy),
+ write(G1, !IO),
+ nl(!IO),
+ write(G2, !IO),
+ nl(!IO).
+
+:- func id(struct) = struct.
+:- pragma memo(id/1).
+:- pragma no_inline(id/1).
+
+id(X) = X.
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/trace/mercury_trace_vars.c b/trace/mercury_trace_vars.c
index 6a9fc34..6a17c03 100644
--- a/trace/mercury_trace_vars.c
+++ b/trace/mercury_trace_vars.c
@@ -1809,11 +1809,12 @@ char *
MR_select_specified_subterm(char *path, MR_TypeInfo type_info, MR_Word *value,
MR_TypeInfo *sub_type_info, MR_Word **sub_value)
{
- MR_TypeInfo new_type_info;
- MR_Word *new_value;
- char *old_path;
- int arg_num;
- int len;
+ MR_TypeInfo new_type_info;
+ MR_Word *new_value;
+ const MR_DuArgLocn *arg_locn;
+ char *old_path;
+ int arg_num;
+ int len;
if (path == NULL) {
*sub_value = value;
@@ -1861,10 +1862,18 @@ MR_select_specified_subterm(char *path, MR_TypeInfo type_info, MR_Word *value,
}
if (MR_arg(type_info, value, arg_num, &new_type_info, &new_value,
- MR_NONCANON_CC))
+ &arg_locn, MR_NONCANON_CC))
{
type_info = new_type_info;
- value = new_value;
+ if (arg_locn == NULL) {
+ value = new_value;
+ } else {
+ MR_Word storage;
+
+ MR_incr_hp(storage, 1);
+ ((MR_Word *) storage)[0] = MR_unpack_arg(*new_value, arg_locn);
+ value = (MR_Word *) storage;
+ }
} else {
return old_path;
}
--------------------------------------------------------------------------
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