mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-10 11:23:15 +00:00
12281f3419
Branches: main
Implement a type representation optimisation ("direct argument functors"),
where a functor with exactly one argument can be represented by a tagged
pointer to the argument value, which itself does not require the tag bits,
e.g.
:- type maybe_foo ---> yes(foo) ; no.
:- type foo ---> foo(int, int). % aligned pointer
To ensure that all modules which could construct or deconstruct the functor
agree on the type representation, I had planned to automatically output
extra information to .int files to notify importing modules about functors
using the optimised representation:
:- type maybe_foo ---> yes(foo) ; no
where direct_arg is [yes/1].
However, the compiler does not perform enough (or any) semantic analysis
while making interface files. The fallback solution is to only use the
optimised representation when all importing modules can be guaranteed to
import both the top-level type and the argument type, namely, when both
types are exported from the same module. We also allow certain built-in
argument types; currently this only includes tuples.
Non-exported types may use the optimised representation, but when
intermodule optimisation is enabled, they may be written out to .opt files.
Then, we *do* add direct_arg attributes to .opt files to ensure that importing
modules agree on the type representation. The attributes may also be added by
Mercury programmers to source files, which will be copied directly into .int
files without analysis. They will be checked when the module is actually
compiled.
This patch includes work by Zoltan, who independently implemented a version
of this change.
compiler/hlds_data.m:
Record the direct arg functors in hlds_du_type.
Add a new option to cons_tag.
Fix some comments.
compiler/prog_data.m:
compiler/prog_io_type_defn.m:
Parse and record `direct_arg' attributes on type definitions.
compiler/prog_io_pragma.m:
Issue an error if the `direct_arg' attribute is used with a foreign
type.
compiler/make_tags.m:
compiler/mercury_compile_front_end.m:
Add a pass to convert suitable functors to use the direct argument
representation. The argument type must have been added to the type
table, so we do this after all type definitions have been added.
Move code to compute cheaper_tag_test here.
compiler/ml_unify_gen.m:
compiler/unify_gen.m:
Generate different code to construct/deconstruct direct argument
functors.
compiler/intermod.m:
Write `direct_arg' attributes to .opt files for functors
using the direct argument representation.
compiler/mercury_to_mercury.m:
Write out `direct_arg' attributes.
compiler/rtti.m:
compiler/rtti_out.m:
compiler/rtti_to_mlds.m:
Add an option to the types which describe the location of secondary
tag options. The functors which can use the optimised representation
are a subset of those which require no secondary tag.
Output "MR_SECTAG_NONE_DIRECT_ARG" instead of "MR_SECTAG_NONE" in
RTTI structures when applicable.
compiler/add_pragma.m:
compiler/add_type.m:
compiler/bytecode_gen.m:
compiler/check_typeclass.m
compiler/code_info.m:
compiler/equiv_type.m:
compiler/export.m:
compiler/foreign.m:
compiler/hlds_code_util.m:
compiler/hlds_out_module.m:
compiler/inst_check.m:
compiler/ml_proc_gen.m:
compiler/ml_switch_gen.m:
compiler/ml_tag_switch.m:
compiler/ml_type_gen.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/post_term_analysis.m:
compiler/post_typecheck.m:
compiler/recompilation.check.m:
compiler/recompilation.usage.m:
compiler/recompilation.version.m:
compiler/simplify.m:
compiler/structure_reuse.direct.choose_reuse.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/tag_switch.m:
compiler/term_norm.m:
compiler/type_ctor_info.m:
compiler/type_util.m:
compiler/unify_proc.m:
compiler/unused_imports.m:
compiler/xml_documentation.m:
Conform to changes.
Bump RTTI version number.
doc/reference_manual.texi:
Add commented out documentation for `direct_arg' attributes.
library/construct.m:
Handle MR_SECTAG_NONE_DIRECT_ARG in construct.construct/3.
library/private_builtin.m:
Add MR_SECTAG_NONE_DIRECT_ARG constant for Java for consistency,
though it won't be used.
runtime/mercury_grade.h:
Bump binary compatibility version number.
runtime/mercury_type_info.h:
Bump RTTI version number.
Add MR_SECTAG_NONE_DIRECT_ARG.
runtime/mercury_deconstruct.c:
runtime/mercury_deep_copy_body.h:
runtime/mercury_ml_expand_body.h:
runtime/mercury_table_type_body.h:
runtime/mercury_term_size.c:
runtime/mercury_unify_compare_body.h:
Handle MR_SECTAG_NONE_DIRECT_ARG in RTTI code.
tests/debugger/Mmakefile:
tests/debugger/chooser_tag_test.exp:
tests/debugger/chooser_tag_test.inp:
tests/debugger/chooser_tag_test.m:
tests/hard_coded/Mercury.options:
tests/hard_coded/Mmakefile:
tests/hard_coded/construct_test.exp:
tests/hard_coded/construct_test.m:
tests/hard_coded/direct_arg_cyclic1.exp:
tests/hard_coded/direct_arg_cyclic1.m:
tests/hard_coded/direct_arg_cyclic2.m:
tests/hard_coded/direct_arg_cyclic3.m:
tests/hard_coded/direct_arg_intermod1.exp:
tests/hard_coded/direct_arg_intermod1.m:
tests/hard_coded/direct_arg_intermod2.m:
tests/hard_coded/direct_arg_intermod3.m:
tests/hard_coded/direct_arg_parent.exp:
tests/hard_coded/direct_arg_parent.m:
tests/hard_coded/direct_arg_sub.m:
tests/invalid/Mmakefile:
tests/invalid/where_direct_arg.err_exp:
tests/invalid/where_direct_arg.m:
tests/invalid/where_direct_arg2.err_exp:
tests/invalid/where_direct_arg2.m:
Add test cases.
tests/invalid/ee_invalid.err_exp:
Update expected output.
927 lines
36 KiB
C
927 lines
36 KiB
C
/*
|
|
** vim:ts=4 sw=4 expandtab
|
|
*/
|
|
/*
|
|
** Copyright (C) 2000-2005, 2007, 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.
|
|
*/
|
|
|
|
/*
|
|
** This file contains a piece of code that is included by mercury_ho_call.c
|
|
** six times:
|
|
**
|
|
** - as the body of the mercury__builtin__unify_2_0 Mercury procedure,
|
|
** - as the body of the mercury__builtin__compare_3_3 Mercury procedure,
|
|
** - as the body of the mercury__builtin__compare_representation_3_0
|
|
** Mercury procedure,
|
|
** - as the body of the MR_generic_unify C function,
|
|
** - as the body of the MR_generic_compare C function, and
|
|
** - as the body of the MR_generic_compare_representation C function.
|
|
**
|
|
** The inclusions are surrounded by #defines and #undefs of the macros
|
|
** that personalize each copy of the code.
|
|
**
|
|
** The reason why the unify and compare Mercury procedures share code is
|
|
** that unify is mostly just a special case of comparison; it differs only
|
|
** by treating "less than" and "greater than" the same way, and returning
|
|
** its result slightly differently. Likewise, compare_representation
|
|
** is mostly the same as compare.
|
|
**
|
|
** The reason why there is both a Mercury procedure and a C function for
|
|
** unifications and comparisons is that the Mercury procedure needs a
|
|
** mechanism that allows it to unify or compare each argument of a function
|
|
** symbol, and doing it with a loop body that calls a C function is
|
|
** significantly easier to program, and probably more efficient, than
|
|
** using recursion in Mercury. The Mercury procedure and C function share code
|
|
** because they implement the same task.
|
|
**
|
|
** We need separate C functions for unifications and comparison because
|
|
** with --no-special-preds, a type with user-defined equality (but not
|
|
** comparison) has a non-NULL unify_pred field in its type_ctor_info but a
|
|
** NULL compare_pred field. While in principle unification is a special case
|
|
** of comparison, we cannot implement unifications by comparisons for such
|
|
** types: they support unifications but not comparisons. Since we cannot do
|
|
** it for such types, it is simplest not to do it for any types.
|
|
*/
|
|
|
|
#ifdef select_compare_code
|
|
#if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
|
|
#ifdef include_compare_rep_code
|
|
#define return_compare_answer(mod, type, arity, answer) \
|
|
do { \
|
|
compare_call_exit_code(mod, __CompareRep__, type, arity); \
|
|
raw_return_answer(answer); \
|
|
} while (0)
|
|
#else
|
|
#define return_compare_answer(mod, type, arity, answer) \
|
|
do { \
|
|
compare_call_exit_code(mod, __Compare__, type, arity); \
|
|
raw_return_answer(answer); \
|
|
} while (0)
|
|
#endif
|
|
#else
|
|
#define return_compare_answer(mod, type, arity, answer) \
|
|
raw_return_answer(answer)
|
|
#endif
|
|
#else
|
|
#if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
|
|
#define return_unify_answer(mod, type, arity, answer) \
|
|
do { \
|
|
if (answer) { \
|
|
unify_call_exit_code(mod, __Unify__, type, arity); \
|
|
raw_return_answer(MR_TRUE); \
|
|
} else { \
|
|
unify_call_fail_code(mod, __Unify__, type, arity); \
|
|
raw_return_answer(MR_FALSE); \
|
|
} \
|
|
} while (0)
|
|
#else
|
|
#define return_unify_answer(mod, type, arity, answer) \
|
|
raw_return_answer(answer)
|
|
#endif
|
|
#endif
|
|
|
|
DECLARE_LOCALS
|
|
initialize();
|
|
|
|
start_label:
|
|
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
|
|
|
|
#ifdef MR_TYPE_CTOR_STATS
|
|
MR_register_type_ctor_stat(&type_stat_struct, type_ctor_info);
|
|
#endif
|
|
|
|
if (! MR_type_ctor_has_valid_rep(type_ctor_info)) {
|
|
MR_fatal_error(attempt_msg "terms of unknown representation");
|
|
}
|
|
|
|
switch (MR_type_ctor_rep(type_ctor_info)) {
|
|
|
|
#if defined(MR_COMPARE_BY_RTTI) || defined(include_compare_rep_code)
|
|
|
|
case MR_TYPECTOR_REP_EQUIV:
|
|
MR_save_transient_hp();
|
|
type_info = MR_create_type_info(
|
|
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
|
|
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv);
|
|
MR_restore_transient_hp();
|
|
goto start_label;
|
|
|
|
case MR_TYPECTOR_REP_EQUIV_GROUND:
|
|
type_info = (MR_TypeInfo)
|
|
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv;
|
|
goto start_label;
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_NOTAG_USEREQ:
|
|
/* fall through */
|
|
#endif
|
|
case MR_TYPECTOR_REP_NOTAG:
|
|
MR_save_transient_hp();
|
|
type_info = MR_create_type_info(
|
|
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
|
|
MR_type_ctor_layout(type_ctor_info).MR_layout_notag->
|
|
MR_notag_functor_arg_type);
|
|
MR_restore_transient_hp();
|
|
goto start_label;
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
|
|
/* fall through */
|
|
#endif
|
|
case MR_TYPECTOR_REP_NOTAG_GROUND:
|
|
type_info = (MR_TypeInfo) MR_type_ctor_layout(type_ctor_info).
|
|
MR_layout_notag->MR_notag_functor_arg_type;
|
|
goto start_label;
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
|
|
/* fall through */
|
|
#endif
|
|
case MR_TYPECTOR_REP_RESERVED_ADDR:
|
|
MR_fatal_error("sorry, not implemented: "
|
|
"MR_COMPARE_BY_RTTI for RESERVED_ADDR");
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_ARRAY:
|
|
MR_fatal_error("sorry, not implemented: "
|
|
"compare_representation for arrays");
|
|
#endif
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_BITMAP:
|
|
MR_fatal_error("sorry, not implemented: "
|
|
"compare_representation for bitmaps");
|
|
#endif
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_FOREIGN:
|
|
MR_fatal_error("sorry, not implemented: "
|
|
"compare_representation for foreign types");
|
|
#endif
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_DU_USEREQ:
|
|
/* fall through */
|
|
#endif
|
|
case MR_TYPECTOR_REP_DU:
|
|
/*
|
|
** When deep profiling is enabled, we use the call, exit and (for
|
|
** unifications) fail ports of dummy unify, compare and compare_rep
|
|
** predicates for the dummy type_ctor builtin.user_by_rtti/0.
|
|
*/
|
|
|
|
{
|
|
const MR_DuFunctorDesc *functor_desc;
|
|
#ifdef select_compare_code
|
|
const MR_DuFunctorDesc *x_functor_desc;
|
|
const MR_DuFunctorDesc *y_functor_desc;
|
|
const MR_DuPtagLayout *x_ptaglayout;
|
|
const MR_DuPtagLayout *y_ptaglayout;
|
|
#else
|
|
MR_Word x_ptag;
|
|
MR_Word y_ptag;
|
|
MR_Word x_sectag;
|
|
MR_Word y_sectag;
|
|
const MR_DuPtagLayout *ptaglayout;
|
|
#endif
|
|
MR_Word *x_data_value;
|
|
MR_Word *y_data_value;
|
|
const MR_DuExistInfo *exist_info;
|
|
int result;
|
|
int cur_slot;
|
|
int arity;
|
|
int i;
|
|
|
|
#ifdef MR_CHECK_DU_EQ
|
|
#ifdef select_compare_code
|
|
if (x == y) {
|
|
return_compare_answer(builtin, user_by_rtti, 0,
|
|
MR_COMPARE_EQUAL);
|
|
}
|
|
#else
|
|
if (x == y) {
|
|
return_unify_answer(builtin, user_by_rtti, 0, MR_TRUE);
|
|
}
|
|
#endif
|
|
#endif
|
|
|
|
#ifdef select_compare_code
|
|
|
|
#define MR_find_du_functor_desc(data, data_value, functor_desc) \
|
|
do { \
|
|
const MR_DuPtagLayout *ptaglayout; \
|
|
int ptag; \
|
|
int sectag; \
|
|
\
|
|
ptag = MR_tag(data); \
|
|
ptaglayout = &MR_type_ctor_layout(type_ctor_info). \
|
|
MR_layout_du[ptag]; \
|
|
data_value = (MR_Word *) MR_body(data, ptag); \
|
|
\
|
|
switch (ptaglayout->MR_sectag_locn) { \
|
|
case MR_SECTAG_LOCAL: \
|
|
sectag = MR_unmkbody(data_value); \
|
|
break; \
|
|
case MR_SECTAG_REMOTE: \
|
|
sectag = data_value[0]; \
|
|
break; \
|
|
case MR_SECTAG_NONE: \
|
|
case MR_SECTAG_NONE_DIRECT_ARG: \
|
|
sectag = 0; \
|
|
break; \
|
|
case MR_SECTAG_VARIABLE: \
|
|
sectag = 0; /* avoid a warning */ \
|
|
MR_fatal_error("find_du_functor_desc(): " \
|
|
"attempt get functor desc of variable"); \
|
|
default: \
|
|
sectag = 0; /* avoid a warning */ \
|
|
MR_fatal_error("find_du_functor_desc(): " \
|
|
"unrecognised sectag locn"); \
|
|
} \
|
|
\
|
|
functor_desc = ptaglayout->MR_sectag_alternatives[sectag];\
|
|
} while (0)
|
|
|
|
MR_find_du_functor_desc(x, x_data_value, x_functor_desc);
|
|
MR_find_du_functor_desc(y, y_data_value, y_functor_desc);
|
|
|
|
#undef MR_find_du_functor_desc
|
|
|
|
if (x_functor_desc->MR_du_functor_ordinal !=
|
|
y_functor_desc->MR_du_functor_ordinal)
|
|
{
|
|
if (x_functor_desc->MR_du_functor_ordinal <
|
|
y_functor_desc->MR_du_functor_ordinal)
|
|
{
|
|
return_compare_answer(builtin, user_by_rtti, 0,
|
|
MR_COMPARE_LESS);
|
|
} else {
|
|
return_compare_answer(builtin, user_by_rtti, 0,
|
|
MR_COMPARE_GREATER);
|
|
}
|
|
}
|
|
|
|
functor_desc = x_functor_desc;
|
|
#else /* ! select_compare_code */
|
|
x_ptag = MR_tag(x);
|
|
y_ptag = MR_tag(y);
|
|
|
|
if (x_ptag != y_ptag) {
|
|
return_unify_answer(builtin, user_by_rtti, 0, MR_FALSE);
|
|
}
|
|
|
|
ptaglayout = &MR_type_ctor_layout(type_ctor_info).
|
|
MR_layout_du[x_ptag];
|
|
x_data_value = (MR_Word *) MR_body(x, x_ptag);
|
|
y_data_value = (MR_Word *) MR_body(y, y_ptag);
|
|
|
|
switch (ptaglayout->MR_sectag_locn) {
|
|
case MR_SECTAG_LOCAL:
|
|
x_sectag = MR_unmkbody(x_data_value);
|
|
y_sectag = MR_unmkbody(y_data_value);
|
|
|
|
if (x_sectag != y_sectag) {
|
|
return_unify_answer(builtin, user_by_rtti, 0,
|
|
MR_FALSE);
|
|
}
|
|
|
|
break;
|
|
|
|
case MR_SECTAG_REMOTE:
|
|
x_sectag = x_data_value[0];
|
|
y_sectag = y_data_value[0];
|
|
|
|
if (x_sectag != y_sectag) {
|
|
return_unify_answer(builtin, user_by_rtti, 0,
|
|
MR_FALSE);
|
|
}
|
|
|
|
break;
|
|
|
|
case MR_SECTAG_NONE:
|
|
case MR_SECTAG_NONE_DIRECT_ARG:
|
|
x_sectag = 0;
|
|
break;
|
|
|
|
case MR_SECTAG_VARIABLE:
|
|
MR_fatal_error("find_du_functor_desc():"
|
|
"attempt get functor desc of variable");
|
|
}
|
|
|
|
functor_desc = ptaglayout->MR_sectag_alternatives[x_sectag];
|
|
#endif /* select_compare_code */
|
|
|
|
switch (functor_desc->MR_du_functor_sectag_locn) {
|
|
|
|
case MR_SECTAG_NONE_DIRECT_ARG:
|
|
/* the work is done in the switch */
|
|
{
|
|
MR_TypeInfo arg_type_info;
|
|
|
|
arg_type_info = (MR_TypeInfo)
|
|
functor_desc->MR_du_functor_arg_types[0];
|
|
MR_save_transient_registers();
|
|
#ifdef select_compare_code
|
|
#ifdef include_compare_rep_code
|
|
result = MR_generic_compare_representation(
|
|
arg_type_info,
|
|
(MR_Word) x_data_value, (MR_Word) y_data_value);
|
|
#else
|
|
result = MR_generic_compare(arg_type_info,
|
|
(MR_Word) x_data_value, (MR_Word) y_data_value);
|
|
#endif
|
|
#else
|
|
result = MR_generic_unify(arg_type_info,
|
|
(MR_Word) x_data_value, (MR_Word) y_data_value);
|
|
#endif
|
|
MR_restore_transient_registers();
|
|
}
|
|
|
|
#ifdef select_compare_code
|
|
return_compare_answer(builtin, user_by_rtti, 0, result);
|
|
#else
|
|
return_unify_answer(builtin, user_by_rtti, 0, result);
|
|
#endif
|
|
break;
|
|
|
|
case MR_SECTAG_REMOTE:
|
|
cur_slot = 1;
|
|
/* the work is done after the switch */
|
|
break;
|
|
|
|
case MR_SECTAG_NONE:
|
|
case MR_SECTAG_LOCAL:
|
|
cur_slot = 0;
|
|
/* the work is done after the switch */
|
|
break;
|
|
|
|
default:
|
|
MR_fatal_error("bad sectag location in direct arg switch");
|
|
}
|
|
|
|
arity = functor_desc->MR_du_functor_orig_arity;
|
|
exist_info = functor_desc->MR_du_functor_exist_info;
|
|
|
|
if (exist_info != NULL) {
|
|
int num_ti_plain;
|
|
int num_ti_in_tci;
|
|
int num_tci;
|
|
const MR_DuExistLocn *locns;
|
|
MR_TypeInfo x_ti;
|
|
MR_TypeInfo y_ti;
|
|
|
|
num_ti_plain = exist_info->MR_exist_typeinfos_plain;
|
|
num_ti_in_tci = exist_info->MR_exist_typeinfos_in_tci;
|
|
num_tci = exist_info->MR_exist_tcis;
|
|
locns = exist_info->MR_exist_typeinfo_locns;
|
|
|
|
for (i = 0; i < num_ti_plain + num_ti_in_tci; i++) {
|
|
if (locns[i].MR_exist_offset_in_tci < 0) {
|
|
x_ti = (MR_TypeInfo)
|
|
x_data_value[locns[i].MR_exist_arg_num];
|
|
y_ti = (MR_TypeInfo)
|
|
y_data_value[locns[i].MR_exist_arg_num];
|
|
} else {
|
|
x_ti = (MR_TypeInfo)
|
|
MR_typeclass_info_param_type_info(
|
|
x_data_value[locns[i].MR_exist_arg_num],
|
|
locns[i].MR_exist_offset_in_tci);
|
|
y_ti = (MR_TypeInfo)
|
|
MR_typeclass_info_param_type_info(
|
|
y_data_value[locns[i].MR_exist_arg_num],
|
|
locns[i].MR_exist_offset_in_tci);
|
|
}
|
|
MR_save_transient_registers();
|
|
result = MR_compare_type_info(x_ti, y_ti);
|
|
MR_restore_transient_registers();
|
|
if (result != MR_COMPARE_EQUAL) {
|
|
#ifdef select_compare_code
|
|
return_compare_answer(builtin, user_by_rtti, 0,
|
|
result);
|
|
#else
|
|
return_unify_answer(builtin, user_by_rtti, 0,
|
|
MR_FALSE);
|
|
#endif
|
|
}
|
|
}
|
|
|
|
cur_slot += num_ti_plain + num_tci;
|
|
}
|
|
|
|
for (i = 0; i < arity; i++) {
|
|
MR_TypeInfo arg_type_info;
|
|
|
|
if (MR_arg_type_may_contain_var(functor_desc, i)) {
|
|
MR_save_transient_hp();
|
|
arg_type_info = MR_create_type_info_maybe_existq(
|
|
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
|
|
functor_desc->MR_du_functor_arg_types[i],
|
|
x_data_value, functor_desc);
|
|
MR_restore_transient_hp();
|
|
} else {
|
|
arg_type_info = (MR_TypeInfo)
|
|
functor_desc->MR_du_functor_arg_types[i];
|
|
}
|
|
#ifdef select_compare_code
|
|
MR_save_transient_registers();
|
|
#ifdef include_compare_rep_code
|
|
result = MR_generic_compare_representation(arg_type_info,
|
|
x_data_value[cur_slot], y_data_value[cur_slot]);
|
|
#else
|
|
result = MR_generic_compare(arg_type_info,
|
|
x_data_value[cur_slot], y_data_value[cur_slot]);
|
|
#endif
|
|
MR_restore_transient_registers();
|
|
if (result != MR_COMPARE_EQUAL) {
|
|
return_compare_answer(builtin, user_by_rtti, 0,
|
|
result);
|
|
}
|
|
#else
|
|
MR_save_transient_registers();
|
|
result = MR_generic_unify(arg_type_info,
|
|
x_data_value[cur_slot], y_data_value[cur_slot]);
|
|
MR_restore_transient_registers();
|
|
if (! result) {
|
|
return_unify_answer(builtin, user_by_rtti, 0,
|
|
MR_FALSE);
|
|
}
|
|
#endif
|
|
cur_slot++;
|
|
}
|
|
|
|
#ifdef select_compare_code
|
|
return_compare_answer(builtin, user_by_rtti, 0,
|
|
MR_COMPARE_EQUAL);
|
|
#else
|
|
return_unify_answer(builtin, user_by_rtti, 0, MR_TRUE);
|
|
#endif
|
|
}
|
|
|
|
MR_fatal_error(MR_STRINGIFY(start_label) ": unexpected fall thru");
|
|
|
|
#endif /* defined(MR_COMPARE_BY_RTTI) || defined(include_compare_rep_code) */
|
|
|
|
#ifndef include_compare_rep_code
|
|
#ifndef MR_COMPARE_BY_RTTI
|
|
case MR_TYPECTOR_REP_EQUIV:
|
|
case MR_TYPECTOR_REP_EQUIV_GROUND:
|
|
case MR_TYPECTOR_REP_NOTAG:
|
|
case MR_TYPECTOR_REP_NOTAG_GROUND:
|
|
case MR_TYPECTOR_REP_RESERVED_ADDR:
|
|
case MR_TYPECTOR_REP_DU:
|
|
/* fall through */
|
|
#endif
|
|
|
|
case MR_TYPECTOR_REP_ENUM_USEREQ:
|
|
case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
|
|
case MR_TYPECTOR_REP_DU_USEREQ:
|
|
case MR_TYPECTOR_REP_NOTAG_USEREQ:
|
|
case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
|
|
case MR_TYPECTOR_REP_ARRAY:
|
|
case MR_TYPECTOR_REP_BITMAP:
|
|
case MR_TYPECTOR_REP_FOREIGN:
|
|
case MR_TYPECTOR_REP_STABLE_FOREIGN:
|
|
case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
|
|
|
|
/*
|
|
** In deep profiling grades, the caller of builtin.unify or
|
|
** builtin.compare (the predicates this piece of code implements)
|
|
** has prepared for a normal call, which must be followed by
|
|
** the execution of the call port code and then of either the exit
|
|
** or the fail port code.
|
|
**
|
|
** That would be a problem if you wanted to pretest x == y here.
|
|
** First, at the moment there is no simple or fast way
|
|
** to get from the type_ctor_info (which we have) to the proc
|
|
** layout structures of the type's unify or compare predicates
|
|
** (which port codes need). Second, even if we put the addresses
|
|
** of those proc layout structures into the type_ctor_info,
|
|
** incrementing just the call and exit/fail port counts would
|
|
** leave the called predicate's counts inconsistent in cases where
|
|
** the body of that predicate did not have any paths through it
|
|
** without making calls (since those calls are being
|
|
** short-circuited here).
|
|
**
|
|
** Our solution is to check x == y not here, but at the starts of
|
|
** compiler-generated unify and compare predicates. This delays
|
|
** the check until after the extraction of any typeinfos
|
|
** representing the arguments of the main type constructor,
|
|
** but it also ensures that the check is performed not just on the
|
|
** top function symbols of the terms being unified or compared,
|
|
** but on all other function symbols too. Measurements show that
|
|
** the overhead of these extra tests is less than the amount of
|
|
** work that these extra pretests avoid.
|
|
*/
|
|
|
|
#ifndef MR_DEEP_PROFILING
|
|
#if 0
|
|
#ifdef select_compare_code
|
|
if (x == y) {
|
|
raw_return_answer(MR_COMPARE_EQUAL);
|
|
}
|
|
#else
|
|
if (x == y) {
|
|
raw_return_answer(MR_TRUE);
|
|
}
|
|
#endif
|
|
#endif
|
|
#endif
|
|
|
|
/*
|
|
** We call the type-specific compare routine as
|
|
** `CompPred(...ArgTypeInfos..., Result, X, Y)' is det.
|
|
** The ArgTypeInfo arguments are input, and are passed
|
|
** in MR_r1, MR_r2, ... MR_rN. The X and Y arguments are also
|
|
** input, and are passed in MR_rN+1 and MR_rN+2.
|
|
** The Result argument is output in MR_r1.
|
|
**
|
|
** We specialize the case where the type_ctor arity is 0, 1 or 2,
|
|
** in order to avoid the loop. If type_ctors with higher arities
|
|
** were commonly used, we could specialize them too.
|
|
*/
|
|
|
|
if (type_ctor_info->MR_type_ctor_arity == 0) {
|
|
MR_r1 = x;
|
|
MR_r2 = y;
|
|
} else if (type_ctor_info->MR_type_ctor_arity == 1) {
|
|
MR_Word *args_base;
|
|
|
|
args_base = (MR_Word *)
|
|
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info);
|
|
MR_r1 = args_base[1];
|
|
MR_r2 = x;
|
|
MR_r3 = y;
|
|
} else if (type_ctor_info->MR_type_ctor_arity == 2) {
|
|
MR_Word *args_base;
|
|
|
|
args_base = (MR_Word *)
|
|
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info);
|
|
MR_r1 = args_base[1];
|
|
MR_r2 = args_base[2];
|
|
MR_r3 = x;
|
|
MR_r4 = y;
|
|
} else {
|
|
int i;
|
|
int type_arity;
|
|
MR_Word *args_base;
|
|
|
|
type_arity = type_ctor_info->MR_type_ctor_arity;
|
|
args_base = (MR_Word *)
|
|
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info);
|
|
MR_save_registers();
|
|
|
|
/* CompPred(...ArgTypeInfos..., Res, X, Y) * */
|
|
for (i = 1; i <= type_arity; i++) {
|
|
MR_virtual_reg_assign(i, args_base[i]);
|
|
}
|
|
MR_virtual_reg_assign(type_arity + 1, x);
|
|
MR_virtual_reg_assign(type_arity + 2, y);
|
|
|
|
MR_restore_registers();
|
|
}
|
|
|
|
tailcall_user_pred();
|
|
#endif /* !include_compare_rep_code */
|
|
|
|
case MR_TYPECTOR_REP_TUPLE:
|
|
{
|
|
int i;
|
|
int type_arity;
|
|
int result;
|
|
|
|
type_arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
|
|
|
|
for (i = 0; i < type_arity; i++) {
|
|
MR_TypeInfo arg_type_info;
|
|
|
|
/* type_infos are counted from one */
|
|
arg_type_info =
|
|
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info)[i + 1];
|
|
|
|
#ifdef select_compare_code
|
|
MR_save_transient_registers();
|
|
result = MR_generic_compare(arg_type_info,
|
|
((MR_Word *) x)[i], ((MR_Word *) y)[i]);
|
|
MR_restore_transient_registers();
|
|
if (result != MR_COMPARE_EQUAL) {
|
|
return_compare_answer(builtin, tuple, 0, result);
|
|
}
|
|
#else
|
|
MR_save_transient_registers();
|
|
result = MR_generic_unify(arg_type_info,
|
|
((MR_Word *) x)[i], ((MR_Word *) y)[i]);
|
|
MR_restore_transient_registers();
|
|
if (! result) {
|
|
return_unify_answer(builtin, tuple, 0, MR_FALSE);
|
|
}
|
|
#endif
|
|
}
|
|
#ifdef select_compare_code
|
|
return_compare_answer(builtin, tuple, 0, MR_COMPARE_EQUAL);
|
|
#else
|
|
return_unify_answer(builtin, tuple, 0, MR_TRUE);
|
|
#endif
|
|
}
|
|
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_ENUM_USEREQ:
|
|
case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
|
|
/* fall through */
|
|
#endif
|
|
case MR_TYPECTOR_REP_ENUM:
|
|
case MR_TYPECTOR_REP_FOREIGN_ENUM:
|
|
case MR_TYPECTOR_REP_INT:
|
|
case MR_TYPECTOR_REP_CHAR:
|
|
|
|
#ifdef select_compare_code
|
|
if ((MR_Integer) x == (MR_Integer) y) {
|
|
return_compare_answer(builtin, int, 0, MR_COMPARE_EQUAL);
|
|
} else if ((MR_Integer) x < (MR_Integer) y) {
|
|
return_compare_answer(builtin, int, 0, MR_COMPARE_LESS);
|
|
} else {
|
|
return_compare_answer(builtin, int, 0, MR_COMPARE_GREATER);
|
|
}
|
|
#else
|
|
return_unify_answer(builtin, int, 0,
|
|
(MR_Integer) x == (MR_Integer) y);
|
|
#endif
|
|
|
|
case MR_TYPECTOR_REP_DUMMY:
|
|
/*
|
|
** Since dummy types contain only value, all unifies succeed and
|
|
** all comparisons return "equal".
|
|
*/
|
|
#ifdef select_compare_code
|
|
return_compare_answer(builtin, dummy, 0, MR_COMPARE_EQUAL);
|
|
#else
|
|
return_unify_answer(builtin, int, 0, MR_TRUE);
|
|
#endif
|
|
|
|
case MR_TYPECTOR_REP_FLOAT:
|
|
{
|
|
MR_Float fx, fy;
|
|
|
|
fx = MR_word_to_float(x);
|
|
fy = MR_word_to_float(y);
|
|
#ifdef select_compare_code
|
|
if (fx == fy) {
|
|
return_compare_answer(builtin, float, 0, MR_COMPARE_EQUAL);
|
|
} else if (fx < fy) {
|
|
return_compare_answer(builtin, float, 0, MR_COMPARE_LESS);
|
|
} else {
|
|
return_compare_answer(builtin, float, 0,
|
|
MR_COMPARE_GREATER);
|
|
}
|
|
#else
|
|
return_unify_answer(builtin, float, 0, fx == fy);
|
|
#endif
|
|
}
|
|
|
|
case MR_TYPECTOR_REP_STRING:
|
|
{
|
|
int result;
|
|
|
|
result = strcmp((char *) x, (char *) y);
|
|
|
|
#ifdef select_compare_code
|
|
if (result == 0) {
|
|
return_compare_answer(builtin, string, 0,
|
|
MR_COMPARE_EQUAL);
|
|
} else if (result < 0) {
|
|
return_compare_answer(builtin, string, 0,
|
|
MR_COMPARE_LESS);
|
|
} else {
|
|
return_compare_answer(builtin, string, 0,
|
|
MR_COMPARE_GREATER);
|
|
}
|
|
#else
|
|
return_unify_answer(builtin, string, 0, result == 0);
|
|
#endif
|
|
}
|
|
|
|
/*
|
|
** We use the c_pointer statistics for stable_c_pointer
|
|
** until the stable_c_pointer type is actually added,
|
|
** which will be *after* the builtin types' handwritten
|
|
** unify and compare preds are replaced by automatically
|
|
** generated code.
|
|
**
|
|
** XXX This is a temporary measure.
|
|
*/
|
|
#ifdef include_compare_rep_code
|
|
case MR_TYPECTOR_REP_STABLE_FOREIGN: /* fallthru */
|
|
#endif
|
|
case MR_TYPECTOR_REP_STABLE_C_POINTER: /* fallthru */
|
|
case MR_TYPECTOR_REP_C_POINTER:
|
|
#ifdef select_compare_code
|
|
if ((void *) x == (void *) y) {
|
|
return_compare_answer(builtin, c_pointer, 0,
|
|
MR_COMPARE_EQUAL);
|
|
} else if ((void *) x < (void *) y) {
|
|
return_compare_answer(builtin, c_pointer, 0,
|
|
MR_COMPARE_LESS);
|
|
} else {
|
|
return_compare_answer(builtin, c_pointer, 0,
|
|
MR_COMPARE_GREATER);
|
|
}
|
|
#else
|
|
return_unify_answer(builtin, c_pointer, 0,
|
|
(void *) x == (void *) y);
|
|
#endif
|
|
|
|
case MR_TYPECTOR_REP_TYPEINFO:
|
|
{
|
|
#ifdef select_compare_code
|
|
int result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_compare_type_info(
|
|
(MR_TypeInfo) x, (MR_TypeInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_compare_answer(private_builtin, type_info, 1, result);
|
|
#else
|
|
MR_bool result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_unify_type_info(
|
|
(MR_TypeInfo) x, (MR_TypeInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_unify_answer(private_builtin, type_info, 1, result);
|
|
#endif
|
|
}
|
|
|
|
case MR_TYPECTOR_REP_TYPEDESC:
|
|
/*
|
|
** Differs from the code for MR_TYPECTOR_REP_TYPEINFO
|
|
** only in recording profiling information elsewhere.
|
|
*/
|
|
|
|
{
|
|
#ifdef select_compare_code
|
|
int result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_compare_type_info(
|
|
(MR_TypeInfo) x, (MR_TypeInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_compare_answer(type_desc, type_desc, 0, result);
|
|
#else
|
|
MR_bool result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_unify_type_info(
|
|
(MR_TypeInfo) x, (MR_TypeInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_unify_answer(type_desc, type_desc, 0, result);
|
|
#endif
|
|
}
|
|
|
|
case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
|
|
{
|
|
#ifdef select_compare_code
|
|
int result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_compare_pseudo_type_info(
|
|
(MR_PseudoTypeInfo) x, (MR_PseudoTypeInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_compare_answer(type_desc, pseudo_type_desc, 0, result);
|
|
#else
|
|
MR_bool result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_unify_pseudo_type_info(
|
|
(MR_PseudoTypeInfo) x, (MR_PseudoTypeInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_unify_answer(type_desc, pseudo_type_desc, 0, result);
|
|
#endif
|
|
}
|
|
|
|
case MR_TYPECTOR_REP_TYPECTORINFO:
|
|
{
|
|
#ifdef select_compare_code
|
|
int result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_compare_type_ctor_info(
|
|
(MR_TypeCtorInfo) x, (MR_TypeCtorInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_compare_answer(private_builtin, type_ctor_info, 1,
|
|
result);
|
|
#else
|
|
MR_bool result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_unify_type_ctor_info(
|
|
(MR_TypeCtorInfo) x, (MR_TypeCtorInfo) y);
|
|
MR_restore_transient_registers();
|
|
return_unify_answer(private_builtin, type_ctor_info, 1,
|
|
result);
|
|
#endif
|
|
}
|
|
|
|
case MR_TYPECTOR_REP_TYPECTORDESC:
|
|
{
|
|
#ifdef select_compare_code
|
|
int result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_compare_type_ctor_desc(
|
|
(MR_TypeCtorDesc) x, (MR_TypeCtorDesc) y);
|
|
MR_restore_transient_registers();
|
|
return_compare_answer(type_desc, type_ctor_desc, 0, result);
|
|
#else
|
|
MR_bool result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_unify_type_ctor_desc(
|
|
(MR_TypeCtorDesc) x, (MR_TypeCtorDesc) y);
|
|
MR_restore_transient_registers();
|
|
return_unify_answer(type_desc, type_ctor_desc, 0, result);
|
|
#endif
|
|
}
|
|
|
|
case MR_TYPECTOR_REP_VOID:
|
|
MR_fatal_error(attempt_msg "terms of type `void'");
|
|
|
|
case MR_TYPECTOR_REP_FUNC:
|
|
case MR_TYPECTOR_REP_PRED:
|
|
{
|
|
#ifdef include_compare_rep_code
|
|
int result;
|
|
|
|
MR_save_transient_registers();
|
|
result = MR_compare_closures_representation((MR_Closure *) x,
|
|
(MR_Closure *) y);
|
|
MR_restore_transient_registers();
|
|
|
|
if (MR_type_ctor_rep(type_ctor_info) == MR_TYPECTOR_REP_FUNC) {
|
|
return_compare_answer(builtin, func, 0, result);
|
|
} else {
|
|
return_compare_answer(builtin, pred, 0, result);
|
|
}
|
|
#else
|
|
MR_fatal_error(attempt_msg "higher-order terms");
|
|
#endif
|
|
}
|
|
|
|
case MR_TYPECTOR_REP_TYPECLASSINFO:
|
|
MR_fatal_error(attempt_msg "typeclass_infos");
|
|
|
|
case MR_TYPECTOR_REP_BASETYPECLASSINFO:
|
|
MR_fatal_error(attempt_msg "base_typeclass_infos");
|
|
|
|
case MR_TYPECTOR_REP_SUBGOAL:
|
|
MR_fatal_error(attempt_msg "subgoal");
|
|
|
|
case MR_TYPECTOR_REP_HP:
|
|
MR_fatal_error(attempt_msg "hp");
|
|
|
|
case MR_TYPECTOR_REP_SUCCIP:
|
|
MR_fatal_error(attempt_msg "succip");
|
|
|
|
case MR_TYPECTOR_REP_CURFR:
|
|
MR_fatal_error(attempt_msg "curfr");
|
|
|
|
case MR_TYPECTOR_REP_MAXFR:
|
|
MR_fatal_error(attempt_msg "maxfr");
|
|
|
|
case MR_TYPECTOR_REP_REDOFR:
|
|
MR_fatal_error(attempt_msg "redofr");
|
|
|
|
case MR_TYPECTOR_REP_REDOIP:
|
|
MR_fatal_error(attempt_msg "redoip");
|
|
|
|
case MR_TYPECTOR_REP_TICKET:
|
|
MR_fatal_error(attempt_msg "ticket");
|
|
|
|
case MR_TYPECTOR_REP_TRAIL_PTR:
|
|
MR_fatal_error(attempt_msg "trail_ptr");
|
|
|
|
case MR_TYPECTOR_REP_REFERENCE:
|
|
#ifdef select_compare_code
|
|
/*
|
|
** This is not permitted, because keeping the order of references
|
|
** consistent would cause significant difficulty for a copying
|
|
** garbage collector.
|
|
*/
|
|
MR_fatal_error(attempt_msg "terms of a reference type");
|
|
#else
|
|
return_unify_answer(private_builtin, ref, 1,
|
|
(void *) x == (void *) y);
|
|
#endif
|
|
|
|
case MR_TYPECTOR_REP_UNKNOWN:
|
|
MR_fatal_error(attempt_msg "terms of unknown type");
|
|
}
|
|
|
|
MR_fatal_error("got to the end of " MR_STRINGIFY(start_label));
|
|
|
|
#ifdef select_compare_code
|
|
#undef return_compare_answer
|
|
#else
|
|
#undef return_unify_answer
|
|
#endif
|