mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-11 20:03:28 +00:00
b86f973fa9
Branches: main Allow the use of Mercury abstract machine float registers for passing double-precision float arguments in higher order calls. In of itself this is not so useful for typical Mercury code. However, as all non-local procedures are potentially the targets of higher order calls, without this change first order calls to non-local procedures could not use float registers either. That is the actual motivation for this change. The basic mechanism is straightforward. As before, do_call_closure_* is invoked to place the closure's hidden arguments into r1, ..., rN, and extra input arguments shifted into rN+1, etc. With float registers, extra input arguments may also be in f1, f2, etc. and the closure may also have hidden float arguments. Optimising for calls, we order the closure's hidden arguments so that all float register arguments come after all regular register arguments in the vector. Having the arguments out of order does complicate code which needs to deconstruct closures, but that is not so important. Polymorphism complicates things. A closure with type pred(float) may be passed to a procedure expecting pred(T). Due to the `float' argument type, the closure expects its argument in a float register. But when passed to the procedure, the polymorphic argument type means it would be called with the argument in a regular register. Higher-order insts already contain information about the calling convention, without which a higher-order term cannot be called. We extend higher-order insts to include information about the register class required for each argument. For example, we can distinguish between: pred(in) is semidet /* arg regs: [reg_f] */ and pred(in) is semidet /* arg regs: [reg_r] */ Using this information, we can create a wrapper around a higher-order variable if it appears in a context requiring a different calling convention. We do this in a new HLDS pass, called float_regs.m. Note: Mercury code has a tendency to lose insts for higher-order terms, then "recover" them by hacky means. The float_regs pass depends on higher-order insts; it is impossible to create a wrapper for a procedure without knowing how to call it. The float_regs pass will report errors which we otherwise accepted, due to higher-order insts being unavailable. It should be possible for the user to adjust the code to satisfy the pass, though the user may not understand why it should be necessary. In most cases, it probably really *is* unnecessary. We may be able to make the float_regs pass more tolerant of missing higher-order insts in the future. Class method calls do not use float registers because I didn't want to deal with them yet. compiler/options.m: compiler/handle_options.m: Always enable float registers in low-level C grades when floats are wider than a word. compiler/make_hlds_passes.m: Always allow double word floats to be stored unboxed in cells on C grades. compiler/hlds_goal.m: Add an extra field to `generic_call' which gives the register class to use for each argument. This is set by the float_regs pass. compiler/prog_data.m: Add an extra field to `pred_inst_info' which records the register class to use for each argument. This is set by the float_regs pass. compiler/hlds_pred.m: Add a field to `proc_sub_info' which lists the headvars which must be passed via regular registers despite their types. Add a field to `pred_sub_info' to record the original unsubstituted argument types for instance method predicates. compiler/check_typeclass.m: In the pred_info of an instance method predicate, record the original argument types before substituting the type variables for the instance. compiler/float_regs.m: compiler/transform_hlds.m: Add the new HLDS pass. compiler/mercury_compile_middle_passes.m: Run the new pass if float registers are enabled. compiler/lambda.m: Export the predicate to produce a predicate from a lambda. This is reused by float_regs.m to create wrapper closures. Add an argument to `expand_lambda' to set the reg_r_headvars field on the newly created procedure. Delete some unused fields from `lambda_info'. compiler/arg_info.m: Make `generate_proc_arg_info' no longer always use regular registers for calls to exported procedures. Do always use regular registers for class methods calls. Add a version of `make_arg_infos' which takes an explicit list of argument registers. Rename the previous version. Add `generic_call_arg_reg_types' to return the argument registers for a generic call. Add a version of `compute_in_and_out_vars' which additionally separates arguments for float and regular registers. compiler/call_gen.m: Use float registers for argument passing in higher-order calls, as directed by the new field in `generic_call'. compiler/code_util.m: Add a function to encode the number of regular and float register arguments when making a higher-order call. compiler/llds.m: Say that the `do_call_closure_N' functions only work for zero float register arguments. compiler/follow_vars.m: compiler/interval.m: Account for the use of float registers by generic call goals in these passes. compiler/unify_gen.m: Move float register arguments to the end of a closure's hidden arguments vector, after regular register arguments. Count hidden regular and float register arguments separately, but encode them in the same word in the closure. This is preferable to using two words because it reduces the differences between grades with and without float registers present. Disable generating code which creates a closure from an existing closure, if float registers exist. That code does not understand the reordered hidden arguments vector yet. compiler/continuation_info.m: Replace an argument's type_info in the closure layout if the argument is a float *and* is passed via a regular register, when floats are normally passed via float registers. Instead, give it the type_info for `private_builtin.float_box'. compiler/builtin_lib_types.m: Add function to return the type of `private_builtin.float_box/0'. compiler/hlds_out_goal.m: compiler/hlds_out_pred.m: compiler/mercury_to_mercury.m: Dump the new fields added to `generic_call', `pred_inst_info' and `proc_sub_info'. compiler/prog_type.m: Add helper predicate. compiler/*.m: Conform to changes. library/private_builtin.m: Add a type `float_box'. runtime/mercury_ho_call.h: Describe the modified closure representation. Rename the field which counts the number of hidden arguments to prevent it being used incorrectly, as it now encodes two numbers (potentially). Add macros to unpack the encoded field. runtime/mercury_ho_call.c: Update the description of how higher-order calls work. Update code which extracts closure arguments to take account the arguments being reordered in the hidden arguments vector. runtime/mercury_deep_copy.c: runtime/mercury_deep_copy_body.h: runtime/mercury_layout_util.c: runtime/mercury_ml_expand_body.h: Update code which extracts closure arguments to take account the arguments being reordered in the hidden arguments vector. runtime/mercury_type_info.c: runtime/mercury_type_info.h: Add helper function. tools/make_spec_ho_call: Update the generated do_call_closure_* functions to place float register arguments. tests/hard_coded/Mercury.options: tests/hard_coded/Mmakefile: tests/hard_coded/ho_float_reg.exp: tests/hard_coded/ho_float_reg.m: Add new test case. tests/hard_coded/copy_pred.exp: tests/hard_coded/copy_pred.m: tests/hard_coded/deconstruct_arg.exp: tests/hard_coded/deconstruct_arg.exp2: tests/hard_coded/deconstruct_arg.m: Extend test cases with float arguments in closures. tests/debugger/higher_order.exp2: Add alternative output, changed due to closure wrapping. tests/hard_coded/ho_univ_to_type.m: Adjust test case so that the float_regs pass does not report errors about missing higher-order insts. compiler/notes/compiler_design.html: Describe the new module. Delete a duplicated paragraph. compiler/notes/todo.html: TODO: Delete one hundred billion year old todos.
1068 lines
31 KiB
C
1068 lines
31 KiB
C
/*
|
|
** vim: ts=4 sw=4 expandtab
|
|
*/
|
|
/*
|
|
** Copyright (C) 1998-2007, 2009, 2012 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 implements utilities that can be useful
|
|
** for both the internal and external debuggers.
|
|
**
|
|
** Main authors: Zoltan Somogyi and Fergus Henderson.
|
|
*/
|
|
|
|
#include "mercury_imp.h"
|
|
#include "mercury_stack_layout.h"
|
|
#include "mercury_layout_util.h"
|
|
|
|
static MR_Word MR_lookup_closure_long_lval(MR_LongLval locn,
|
|
MR_Closure *closure, MR_bool *succeeded);
|
|
static MR_Word MR_lookup_typeclass_info_long_lval(MR_LongLval locn,
|
|
MR_Word typeclass_info, MR_bool *succeeded);
|
|
static MR_Word MR_lookup_answer_block_long_lval(MR_LongLval locn,
|
|
MR_Word *answer_block, int block_size, MR_bool *succeeded);
|
|
|
|
void
|
|
MR_copy_regs_to_saved_regs(int max_mr_num, MR_Word *saved_regs,
|
|
int max_f_num, MR_Float *saved_f_regs)
|
|
{
|
|
/*
|
|
** In the process of browsing within the debugger, we call Mercury,
|
|
** which may clobber the contents of the virtual machine registers,
|
|
** both control and general purpose, and both real and virtual
|
|
** registers. We must therefore save and restore these.
|
|
** We store them in the saved_regs array.
|
|
**
|
|
** The call to MR_trace will clobber the transient registers
|
|
** on architectures that have them. The compiler generated code
|
|
** will therefore call MR_save_transient_registers to save the
|
|
** transient registers in the fake_reg array. We here restore them
|
|
** to the real registers, save them with the other registers back in
|
|
** fake_reg, and then copy all fake_reg entries to saved_regs.
|
|
**
|
|
** If float registers are used, we must save them as well.
|
|
** We never use real machine registers for floats so we just have
|
|
** to copy them from the MR_float_reg array.
|
|
*/
|
|
|
|
int i;
|
|
|
|
MR_restore_transient_registers();
|
|
MR_save_registers();
|
|
|
|
for (i = 0; i <= max_mr_num; i++) {
|
|
saved_regs[i] = MR_fake_reg[i];
|
|
}
|
|
|
|
#ifdef MR_BOXED_FLOAT
|
|
for (i = 0; i <= max_f_num; i++) {
|
|
saved_f_regs[i] = MR_float_reg[i];
|
|
}
|
|
#else
|
|
(void) max_f_num;
|
|
(void) saved_f_regs;
|
|
#endif
|
|
}
|
|
|
|
void
|
|
MR_copy_saved_regs_to_regs(int max_mr_num, MR_Word *saved_regs,
|
|
int max_f_num, MR_Float *saved_f_regs)
|
|
{
|
|
/*
|
|
** We execute the converse procedure to MR_copy_regs_to_saved_regs.
|
|
** The MR_save_transient_registers is there so that a call to the
|
|
** MR_restore_transient_registers macro after MR_trace will do the
|
|
** right thing.
|
|
*/
|
|
|
|
int i;
|
|
|
|
for (i = 0; i <= max_mr_num; i++) {
|
|
MR_fake_reg[i] = saved_regs[i];
|
|
}
|
|
|
|
#ifdef MR_BOXED_FLOAT
|
|
for (i = 0; i <= max_f_num; i++) {
|
|
MR_float_reg[i] = saved_f_regs[i];
|
|
}
|
|
#else
|
|
(void) max_f_num;
|
|
(void) saved_f_regs;
|
|
#endif
|
|
|
|
MR_restore_registers();
|
|
MR_save_transient_registers();
|
|
}
|
|
|
|
MR_TypeInfoParams
|
|
MR_materialize_type_params(const MR_LabelLayout *label_layout,
|
|
MR_Word *saved_regs)
|
|
{
|
|
return MR_materialize_type_params_base(label_layout, saved_regs,
|
|
MR_saved_sp(saved_regs), MR_saved_curfr(saved_regs));
|
|
}
|
|
|
|
MR_TypeInfoParams
|
|
MR_materialize_type_params_base(const MR_LabelLayout *label_layout,
|
|
MR_Word *saved_regs, MR_Word *base_sp, MR_Word *base_curfr)
|
|
{
|
|
const MR_TypeParamLocns *tvar_locns;
|
|
|
|
tvar_locns = label_layout->MR_sll_tvars;
|
|
if (tvar_locns != NULL) {
|
|
MR_TypeInfoParams type_params;
|
|
MR_bool succeeded;
|
|
MR_Integer count;
|
|
int i;
|
|
|
|
count = tvar_locns->MR_tp_param_count;
|
|
type_params = (MR_TypeInfoParams) MR_NEW_ARRAY(MR_Word, count + 1);
|
|
|
|
for (i = 0; i < count; i++) {
|
|
if (tvar_locns->MR_tp_param_locns[i] != 0) {
|
|
type_params[i + 1] = (MR_TypeInfo)
|
|
MR_lookup_long_lval_base(tvar_locns->MR_tp_param_locns[i],
|
|
saved_regs, base_sp, base_curfr, NULL, &succeeded);
|
|
if (! succeeded) {
|
|
MR_fatal_error("missing type param in "
|
|
"MR_materialize_type_params_base");
|
|
}
|
|
}
|
|
}
|
|
|
|
return type_params;
|
|
|
|
} else {
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
MR_TypeInfoParams
|
|
MR_materialize_closure_type_params(MR_Closure *closure)
|
|
{
|
|
const MR_TypeParamLocns *tvar_locns;
|
|
|
|
tvar_locns = closure->MR_closure_layout->MR_closure_type_params;
|
|
if (tvar_locns != NULL) {
|
|
MR_TypeInfoParams type_params;
|
|
MR_bool succeeded;
|
|
MR_Integer count;
|
|
int i;
|
|
|
|
count = tvar_locns->MR_tp_param_count;
|
|
type_params = (MR_TypeInfoParams) MR_NEW_ARRAY(MR_Word, count + 1);
|
|
|
|
for (i = 0; i < count; i++) {
|
|
if (tvar_locns->MR_tp_param_locns[i] != 0) {
|
|
type_params[i + 1] = (MR_TypeInfo)
|
|
MR_lookup_closure_long_lval(
|
|
tvar_locns->MR_tp_param_locns[i], closure, &succeeded);
|
|
if (! succeeded) {
|
|
MR_fatal_error("missing type param in "
|
|
"MR_materialize_closure_type_params");
|
|
}
|
|
}
|
|
}
|
|
|
|
return type_params;
|
|
} else {
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
MR_TypeInfoParams
|
|
MR_materialize_typeclass_info_type_params(MR_Word typeclass_info,
|
|
MR_Closure_Layout *closure_layout)
|
|
{
|
|
const MR_TypeParamLocns *tvar_locns;
|
|
|
|
tvar_locns = closure_layout->MR_closure_type_params;
|
|
if (tvar_locns != NULL) {
|
|
MR_TypeInfoParams type_params;
|
|
MR_bool succeeded;
|
|
MR_Integer count;
|
|
int i;
|
|
|
|
count = tvar_locns->MR_tp_param_count;
|
|
type_params = (MR_TypeInfoParams) MR_NEW_ARRAY(MR_Word, count + 1);
|
|
|
|
for (i = 0; i < count; i++) {
|
|
if (tvar_locns->MR_tp_param_locns[i] != 0)
|
|
{
|
|
type_params[i + 1] = (MR_TypeInfo)
|
|
MR_lookup_typeclass_info_long_lval(
|
|
tvar_locns->MR_tp_param_locns[i],
|
|
typeclass_info, &succeeded);
|
|
if (! succeeded) {
|
|
MR_fatal_error("missing type param in "
|
|
"MR_materialize_typeclass_info_type_params");
|
|
}
|
|
}
|
|
}
|
|
|
|
return type_params;
|
|
} else {
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
MR_TypeInfoParams
|
|
MR_materialize_answer_block_type_params(const MR_TypeParamLocns *tvar_locns,
|
|
MR_Word *answer_block, int block_size)
|
|
{
|
|
if (tvar_locns != NULL) {
|
|
MR_TypeInfoParams type_params;
|
|
MR_bool succeeded;
|
|
MR_Integer count;
|
|
int i;
|
|
|
|
count = tvar_locns->MR_tp_param_count;
|
|
type_params = (MR_TypeInfoParams) MR_NEW_ARRAY(MR_Word, count + 1);
|
|
|
|
for (i = 0; i < count; i++) {
|
|
if (tvar_locns->MR_tp_param_locns[i] != 0) {
|
|
type_params[i + 1] = (MR_TypeInfo)
|
|
MR_lookup_answer_block_long_lval(
|
|
tvar_locns->MR_tp_param_locns[i], answer_block,
|
|
block_size, &succeeded);
|
|
if (! succeeded) {
|
|
MR_fatal_error("missing type param in "
|
|
"MR_materialize_answer_block_type_params");
|
|
}
|
|
}
|
|
}
|
|
|
|
return type_params;
|
|
} else {
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
int
|
|
MR_get_register_number_long(MR_LongLval locn)
|
|
{
|
|
MR_LongLvalType type;
|
|
|
|
type = MR_LONG_LVAL_TYPE(locn);
|
|
if (type == MR_LONG_LVAL_TYPE_R || type == MR_LONG_LVAL_TYPE_F) {
|
|
return MR_LONG_LVAL_NUMBER(locn);
|
|
} else {
|
|
return -1;
|
|
}
|
|
}
|
|
|
|
int
|
|
MR_get_register_number_short(MR_ShortLval locn)
|
|
{
|
|
if (MR_SHORT_LVAL_TYPE(locn) == MR_SHORT_LVAL_TYPE_R) {
|
|
return locn >> MR_SHORT_LVAL_TAGBITS;
|
|
} else {
|
|
return -1;
|
|
}
|
|
}
|
|
|
|
#ifdef MR_DEBUG_LVAL_REP
|
|
#define MR_print_locn MR_printlocndebug
|
|
#else
|
|
#define MR_print_locn MR_FALSE
|
|
#endif
|
|
|
|
MR_Word
|
|
MR_lookup_long_lval(MR_LongLval locn, MR_Word *saved_regs,
|
|
MR_Float *saved_f_regs, MR_bool *succeeded)
|
|
{
|
|
return MR_lookup_long_lval_base(locn, saved_regs,
|
|
MR_saved_sp(saved_regs), MR_saved_curfr(saved_regs),
|
|
saved_f_regs, succeeded);
|
|
}
|
|
|
|
static MR_Word
|
|
MR_lookup_closure_long_lval(MR_LongLval locn, MR_Closure *closure,
|
|
MR_bool *succeeded)
|
|
{
|
|
int locn_num;
|
|
int num_r_args;
|
|
int num_f_args;
|
|
int offset;
|
|
MR_Word value;
|
|
MR_Word baseaddr;
|
|
MR_LongLval indirect_lval;
|
|
MR_LongLval sublocn;
|
|
|
|
*succeeded = MR_FALSE;
|
|
value = 0;
|
|
|
|
locn_num = (int) MR_LONG_LVAL_NUMBER(locn);
|
|
switch (MR_LONG_LVAL_TYPE(locn)) {
|
|
case MR_LONG_LVAL_TYPE_R:
|
|
if (MR_print_locn) {
|
|
printf("closure r%d\n", locn_num);
|
|
}
|
|
num_r_args = MR_closure_num_hidden_r_args(closure);
|
|
if (locn_num <= num_r_args) {
|
|
value = closure->MR_closure_hidden_args(locn_num);
|
|
*succeeded = MR_TRUE;
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_F:
|
|
if (MR_print_locn) {
|
|
printf("closure f%d\n", locn_num);
|
|
}
|
|
num_r_args = MR_closure_num_hidden_r_args(closure);
|
|
num_f_args = MR_closure_num_hidden_f_args(closure);
|
|
if (locn_num <= num_f_args) {
|
|
value = closure->MR_closure_hidden_args(num_r_args + locn_num);
|
|
*succeeded = MR_TRUE;
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("closure stackvar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("closure framevar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("closure double stackvar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("closure double framevar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SUCCIP:
|
|
if (MR_print_locn) {
|
|
printf("closure succip\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_MAXFR:
|
|
if (MR_print_locn) {
|
|
printf("closure maxfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CURFR:
|
|
if (MR_print_locn) {
|
|
printf("closure curfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_HP:
|
|
if (MR_print_locn) {
|
|
printf("closure hp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SP:
|
|
if (MR_print_locn) {
|
|
printf("closure sp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_INDIRECT:
|
|
indirect_lval = locn_num;
|
|
|
|
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
|
|
sublocn = MR_LONG_LVAL_INDIRECT_BASE_LVAL_INT(indirect_lval);
|
|
|
|
if (MR_print_locn) {
|
|
printf("closure offset %d from ", offset);
|
|
}
|
|
baseaddr = MR_lookup_closure_long_lval(sublocn, closure,
|
|
succeeded);
|
|
if (! *succeeded) {
|
|
break;
|
|
}
|
|
value = MR_typeclass_info_param_type_info(baseaddr, offset);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CONS_0:
|
|
case MR_LONG_LVAL_TYPE_CONS_1:
|
|
case MR_LONG_LVAL_TYPE_CONS_2:
|
|
case MR_LONG_LVAL_TYPE_CONS_3:
|
|
case MR_LONG_LVAL_TYPE_CONS_4:
|
|
case MR_LONG_LVAL_TYPE_CONS_5:
|
|
case MR_LONG_LVAL_TYPE_CONS_6:
|
|
case MR_LONG_LVAL_TYPE_CONS_7:
|
|
value = MR_LONG_LVAL_CONST(locn);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_UNKNOWN:
|
|
if (MR_print_locn) {
|
|
printf("closure unknown\n");
|
|
}
|
|
break;
|
|
|
|
default:
|
|
if (MR_print_locn) {
|
|
printf("closure DEFAULT\n");
|
|
}
|
|
break;
|
|
}
|
|
|
|
return value;
|
|
}
|
|
|
|
static MR_Word
|
|
MR_lookup_typeclass_info_long_lval(MR_LongLval locn, MR_Word typeclass_info,
|
|
MR_bool *succeeded)
|
|
{
|
|
int locn_num;
|
|
int offset;
|
|
MR_Word value;
|
|
MR_Word baseaddr;
|
|
MR_LongLval indirect_lval;
|
|
MR_LongLval sublocn;
|
|
|
|
*succeeded = MR_FALSE;
|
|
value = 0;
|
|
|
|
locn_num = (int) MR_LONG_LVAL_NUMBER(locn);
|
|
switch (MR_LONG_LVAL_TYPE(locn)) {
|
|
case MR_LONG_LVAL_TYPE_R:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo r%d\n", locn_num);
|
|
}
|
|
if (locn_num <=
|
|
MR_typeclass_info_num_extra_instance_args(typeclass_info))
|
|
{
|
|
value = MR_typeclass_info_arg_typeclass_info(typeclass_info,
|
|
locn_num);
|
|
*succeeded = MR_TRUE;
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_F:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo f%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo stackvar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo framevar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo double stackvar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo double framevar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SUCCIP:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo succip\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_MAXFR:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo maxfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CURFR:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo curfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_HP:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo hp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SP:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo sp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_INDIRECT:
|
|
indirect_lval = locn_num;
|
|
|
|
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
|
|
sublocn = MR_LONG_LVAL_INDIRECT_BASE_LVAL_INT(indirect_lval);
|
|
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo offset %d from ", offset);
|
|
}
|
|
baseaddr = MR_lookup_typeclass_info_long_lval(sublocn,
|
|
typeclass_info, succeeded);
|
|
if (! *succeeded) {
|
|
break;
|
|
}
|
|
value = MR_typeclass_info_param_type_info(baseaddr, offset);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CONS_0:
|
|
case MR_LONG_LVAL_TYPE_CONS_1:
|
|
case MR_LONG_LVAL_TYPE_CONS_2:
|
|
case MR_LONG_LVAL_TYPE_CONS_3:
|
|
case MR_LONG_LVAL_TYPE_CONS_4:
|
|
case MR_LONG_LVAL_TYPE_CONS_5:
|
|
case MR_LONG_LVAL_TYPE_CONS_6:
|
|
case MR_LONG_LVAL_TYPE_CONS_7:
|
|
value = MR_LONG_LVAL_CONST(locn);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_UNKNOWN:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo unknown\n");
|
|
}
|
|
break;
|
|
|
|
default:
|
|
if (MR_print_locn) {
|
|
printf("typeclassinfo DEFAULT\n");
|
|
}
|
|
break;
|
|
}
|
|
|
|
return value;
|
|
}
|
|
|
|
static MR_Word
|
|
MR_lookup_answer_block_long_lval(MR_LongLval locn, MR_Word *answer_block,
|
|
int block_size, MR_bool *succeeded)
|
|
{
|
|
int locn_num;
|
|
int offset;
|
|
MR_Word value;
|
|
MR_Word baseaddr;
|
|
MR_LongLval indirect_lval;
|
|
MR_LongLval sublocn;
|
|
|
|
*succeeded = MR_FALSE;
|
|
value = 0;
|
|
|
|
locn_num = (int) MR_LONG_LVAL_NUMBER(locn);
|
|
switch (MR_LONG_LVAL_TYPE(locn)) {
|
|
case MR_LONG_LVAL_TYPE_R:
|
|
if (MR_print_locn) {
|
|
printf("answer_block r%d\n", locn_num);
|
|
}
|
|
if (locn_num <= block_size) {
|
|
value = answer_block[locn_num];
|
|
*succeeded = MR_TRUE;
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_F:
|
|
if (MR_print_locn) {
|
|
printf("answer_block f%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("answer_block stackvar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("answer_block framevar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("answer_block double stackvar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("answer_block double framevar%d\n", locn_num);
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SUCCIP:
|
|
if (MR_print_locn) {
|
|
printf("answer_block succip\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_MAXFR:
|
|
if (MR_print_locn) {
|
|
printf("answer_block maxfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CURFR:
|
|
if (MR_print_locn) {
|
|
printf("answer_block curfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_HP:
|
|
if (MR_print_locn) {
|
|
printf("answer_block hp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SP:
|
|
if (MR_print_locn) {
|
|
printf("answer_block sp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_INDIRECT:
|
|
indirect_lval = locn_num;
|
|
|
|
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
|
|
sublocn = MR_LONG_LVAL_INDIRECT_BASE_LVAL_INT(indirect_lval);
|
|
|
|
if (MR_print_locn) {
|
|
printf("answer_block offset %d from ", offset);
|
|
}
|
|
baseaddr = MR_lookup_answer_block_long_lval(sublocn, answer_block,
|
|
block_size, succeeded);
|
|
if (! *succeeded) {
|
|
break;
|
|
}
|
|
value = MR_typeclass_info_param_type_info(baseaddr, offset);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CONS_0:
|
|
case MR_LONG_LVAL_TYPE_CONS_1:
|
|
case MR_LONG_LVAL_TYPE_CONS_2:
|
|
case MR_LONG_LVAL_TYPE_CONS_3:
|
|
case MR_LONG_LVAL_TYPE_CONS_4:
|
|
case MR_LONG_LVAL_TYPE_CONS_5:
|
|
case MR_LONG_LVAL_TYPE_CONS_6:
|
|
case MR_LONG_LVAL_TYPE_CONS_7:
|
|
value = MR_LONG_LVAL_CONST(locn);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_UNKNOWN:
|
|
if (MR_print_locn) {
|
|
printf("answer_block unknown\n");
|
|
}
|
|
break;
|
|
|
|
default:
|
|
if (MR_print_locn) {
|
|
printf("answer_block DEFAULT\n");
|
|
}
|
|
break;
|
|
}
|
|
|
|
return value;
|
|
}
|
|
|
|
MR_Word
|
|
MR_lookup_long_lval_base(MR_LongLval locn, MR_Word *saved_regs,
|
|
MR_Word *base_sp, MR_Word *base_curfr, MR_Float *saved_f_regs,
|
|
MR_bool *succeeded)
|
|
{
|
|
int locn_num;
|
|
int offset;
|
|
MR_Word value;
|
|
MR_Word baseaddr;
|
|
MR_LongLval indirect_lval;
|
|
MR_LongLval sublocn;
|
|
|
|
*succeeded = MR_FALSE;
|
|
value = 0;
|
|
|
|
locn_num = (int) MR_LONG_LVAL_NUMBER(locn);
|
|
switch (MR_LONG_LVAL_TYPE(locn)) {
|
|
case MR_LONG_LVAL_TYPE_R:
|
|
if (MR_print_locn) {
|
|
printf("long r%d\n", locn_num);
|
|
}
|
|
if (saved_regs != NULL) {
|
|
value = MR_saved_reg_value(saved_regs, locn_num);
|
|
*succeeded = MR_TRUE;
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_F:
|
|
if (MR_print_locn) {
|
|
printf("long f%d\n", locn_num);
|
|
}
|
|
#ifdef MR_BOXED_FLOAT
|
|
if (saved_f_regs != NULL) {
|
|
MR_Float f = MR_saved_f_reg_value(saved_f_regs, locn_num);
|
|
value = MR_float_to_word(f);
|
|
*succeeded = MR_TRUE;
|
|
}
|
|
#endif
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("long stackvar%d\n", locn_num);
|
|
}
|
|
value = MR_based_stackvar(base_sp, locn_num);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("long framevar%d\n", locn_num);
|
|
}
|
|
value = MR_based_framevar(base_curfr, locn_num);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("long double stackvar%d\n", locn_num);
|
|
}
|
|
#ifdef MR_BOXED_FLOAT
|
|
value = MR_float_to_word(MR_float_from_dword_ptr(
|
|
&MR_based_stackvar(base_sp, locn_num + 1)));
|
|
*succeeded = MR_TRUE;
|
|
#endif
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_DOUBLE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("long double framevar%d\n", locn_num);
|
|
}
|
|
#ifdef MR_BOXED_FLOAT
|
|
value = MR_float_to_word(MR_float_from_dword_ptr(
|
|
&MR_based_framevar(base_sp, locn_num + 1)));
|
|
*succeeded = MR_TRUE;
|
|
#endif
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SUCCIP:
|
|
if (MR_print_locn) {
|
|
printf("long succip\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_MAXFR:
|
|
if (MR_print_locn) {
|
|
printf("long maxfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CURFR:
|
|
if (MR_print_locn) {
|
|
printf("long curfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_HP:
|
|
if (MR_print_locn) {
|
|
printf("long hp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SP:
|
|
if (MR_print_locn) {
|
|
printf("long sp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_INDIRECT:
|
|
indirect_lval = locn_num;
|
|
|
|
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
|
|
sublocn = MR_LONG_LVAL_INDIRECT_BASE_LVAL_INT(indirect_lval);
|
|
|
|
if (MR_print_locn) {
|
|
printf("long offset %d from ", offset);
|
|
}
|
|
baseaddr = MR_lookup_long_lval_base(sublocn, saved_regs,
|
|
base_sp, base_curfr, saved_f_regs, succeeded);
|
|
if (! *succeeded) {
|
|
break;
|
|
}
|
|
value = MR_typeclass_info_param_type_info(baseaddr, offset);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CONS_0:
|
|
case MR_LONG_LVAL_TYPE_CONS_1:
|
|
case MR_LONG_LVAL_TYPE_CONS_2:
|
|
case MR_LONG_LVAL_TYPE_CONS_3:
|
|
case MR_LONG_LVAL_TYPE_CONS_4:
|
|
case MR_LONG_LVAL_TYPE_CONS_5:
|
|
case MR_LONG_LVAL_TYPE_CONS_6:
|
|
case MR_LONG_LVAL_TYPE_CONS_7:
|
|
value = MR_LONG_LVAL_CONST(locn);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_UNKNOWN:
|
|
if (MR_print_locn) {
|
|
printf("long unknown\n");
|
|
}
|
|
break;
|
|
|
|
default:
|
|
if (MR_print_locn) {
|
|
printf("long DEFAULT\n");
|
|
}
|
|
break;
|
|
}
|
|
|
|
return value;
|
|
}
|
|
|
|
MR_Word
|
|
MR_lookup_short_lval(MR_ShortLval locn, MR_Word *saved_regs,
|
|
MR_bool *succeeded)
|
|
{
|
|
return MR_lookup_short_lval_base(locn, saved_regs,
|
|
MR_saved_sp(saved_regs), MR_saved_curfr(saved_regs), succeeded);
|
|
}
|
|
|
|
MR_Word
|
|
MR_lookup_short_lval_base(MR_ShortLval locn, MR_Word *saved_regs,
|
|
MR_Word *base_sp, MR_Word *base_curfr, MR_bool *succeeded)
|
|
{
|
|
int locn_num;
|
|
MR_Word value;
|
|
|
|
*succeeded = MR_FALSE;
|
|
value = 0;
|
|
|
|
locn_num = (int) locn >> MR_SHORT_LVAL_TAGBITS;
|
|
switch (MR_SHORT_LVAL_TYPE(locn)) {
|
|
case MR_SHORT_LVAL_TYPE_R:
|
|
if (MR_print_locn) {
|
|
printf("short r%d\n", locn_num);
|
|
}
|
|
if (saved_regs != NULL) {
|
|
value = MR_saved_reg_value(saved_regs, locn_num);
|
|
*succeeded = MR_TRUE;
|
|
}
|
|
break;
|
|
|
|
case MR_SHORT_LVAL_TYPE_STACKVAR:
|
|
if (MR_print_locn) {
|
|
printf("short stackvar%d\n", locn_num);
|
|
}
|
|
value = MR_based_stackvar(base_sp, locn_num);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_SHORT_LVAL_TYPE_FRAMEVAR:
|
|
if (MR_print_locn) {
|
|
printf("short framevar%d\n", locn_num);
|
|
}
|
|
value = MR_based_framevar(base_curfr, locn_num);
|
|
*succeeded = MR_TRUE;
|
|
break;
|
|
|
|
case MR_SHORT_LVAL_TYPE_SPECIAL:
|
|
switch (locn_num) {
|
|
case MR_LONG_LVAL_TYPE_SUCCIP:
|
|
if (MR_print_locn) {
|
|
printf("short succip\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_MAXFR:
|
|
if (MR_print_locn) {
|
|
printf("short maxfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_CURFR:
|
|
if (MR_print_locn) {
|
|
printf("short curfr\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_HP:
|
|
if (MR_print_locn) {
|
|
printf("short hp\n");
|
|
}
|
|
break;
|
|
|
|
case MR_LONG_LVAL_TYPE_SP:
|
|
if (MR_print_locn) {
|
|
printf("short sp\n");
|
|
}
|
|
break;
|
|
|
|
default:
|
|
if (MR_print_locn) {
|
|
printf("short spec DEFAULT\n");
|
|
}
|
|
}
|
|
|
|
default:
|
|
MR_fatal_error("MR_lookup_short_lval_base: bad type");
|
|
}
|
|
|
|
return value;
|
|
}
|
|
|
|
MR_bool
|
|
MR_get_type_and_value(const MR_LabelLayout *label_layout, int i,
|
|
MR_Word *saved_regs, MR_Float *saved_f_regs,
|
|
MR_TypeInfo *type_params, MR_TypeInfo *type_info,
|
|
MR_Word *value)
|
|
{
|
|
return MR_get_type_and_value_base(label_layout, i, saved_regs,
|
|
MR_saved_sp(saved_regs), MR_saved_curfr(saved_regs), saved_f_regs,
|
|
type_params, type_info, value);
|
|
}
|
|
|
|
MR_bool
|
|
MR_get_type_and_value_base(const MR_LabelLayout *label_layout, int i,
|
|
MR_Word *saved_regs, MR_Word *base_sp, MR_Word *base_curfr,
|
|
MR_Float *saved_f_regs,
|
|
MR_TypeInfo *type_params, MR_TypeInfo *type_info, MR_Word *value)
|
|
{
|
|
MR_PseudoTypeInfo pseudo_type_info;
|
|
MR_bool succeeded;
|
|
MR_LongLval long_locn;
|
|
MR_ShortLval short_locn;
|
|
int num_longs;
|
|
|
|
pseudo_type_info = MR_var_pti(label_layout, i);
|
|
*type_info = MR_create_type_info(type_params, pseudo_type_info);
|
|
|
|
num_longs = MR_long_desc_var_count(label_layout);
|
|
if (i < num_longs) {
|
|
if (MR_print_locn) {
|
|
printf("looking up long lval: ");
|
|
}
|
|
|
|
long_locn = MR_long_desc_var_locn(label_layout, i);
|
|
*value = MR_lookup_long_lval_base(long_locn,
|
|
saved_regs, base_sp, base_curfr, saved_f_regs,
|
|
&succeeded);
|
|
} else {
|
|
if (MR_print_locn) {
|
|
printf("looking up short lval: ");
|
|
}
|
|
|
|
short_locn = MR_short_desc_var_locn(label_layout, i - num_longs),
|
|
*value = MR_lookup_short_lval_base(short_locn,
|
|
saved_regs, base_sp, base_curfr, &succeeded);
|
|
}
|
|
|
|
return succeeded;
|
|
}
|
|
|
|
MR_bool
|
|
MR_get_type(const MR_LabelLayout *label_layout, int i, MR_Word *saved_regs,
|
|
MR_TypeInfo *type_params, MR_TypeInfo *type_info)
|
|
{
|
|
return MR_get_type_base(label_layout, i, saved_regs,
|
|
MR_saved_sp(saved_regs), MR_saved_curfr(saved_regs),
|
|
type_params, type_info);
|
|
}
|
|
|
|
MR_bool
|
|
MR_get_type_base(const MR_LabelLayout *label_layout, int i,
|
|
MR_Word *saved_regs, MR_Word *base_sp, MR_Word *base_curfr,
|
|
MR_TypeInfo *type_params, MR_TypeInfo *type_info)
|
|
{
|
|
MR_PseudoTypeInfo pseudo_type_info;
|
|
|
|
pseudo_type_info = MR_var_pti(label_layout, i);
|
|
*type_info = MR_create_type_info(type_params, pseudo_type_info);
|
|
|
|
return MR_TRUE;
|
|
}
|
|
|
|
void
|
|
MR_write_variable(MR_TypeInfo type_info, MR_Word value)
|
|
{
|
|
MercuryFilePtr stdout_stream;
|
|
|
|
(*MR_io_stdout_stream)(&stdout_stream);
|
|
(*MR_io_print_to_stream)((MR_Word) type_info, stdout_stream, value);
|
|
}
|
|
|
|
void
|
|
MR_generate_proc_name_from_layout(const MR_ProcLayout *proc_layout,
|
|
MR_ConstString *proc_name_ptr, int *arity_ptr, MR_Word *is_func_ptr)
|
|
{
|
|
if (MR_PROC_LAYOUT_IS_UCI(proc_layout)) {
|
|
*proc_name_ptr = proc_layout->MR_sle_proc_id.
|
|
MR_proc_uci.MR_uci_pred_name;
|
|
if (MR_streq(*proc_name_ptr, "__Unify__")) {
|
|
*arity_ptr = 2;
|
|
} else if (MR_streq(*proc_name_ptr, "__Compare__")) {
|
|
*arity_ptr = 3;
|
|
} else if (MR_streq(*proc_name_ptr, "__Index__")) {
|
|
*arity_ptr = 2;
|
|
} else if (MR_streq(*proc_name_ptr, "__Initialise__")) {
|
|
*arity_ptr = 1;
|
|
} else {
|
|
MR_fatal_error("MR_generate_proc_name_from_layout: "
|
|
"bad MR_comp_pred_name");
|
|
}
|
|
*is_func_ptr = MR_BOOL_NO;
|
|
} else {
|
|
*proc_name_ptr = proc_layout->MR_sle_proc_id.MR_proc_user.MR_user_name;
|
|
*arity_ptr = proc_layout->MR_sle_proc_id. MR_proc_user.MR_user_arity;
|
|
if (proc_layout->MR_sle_user.MR_user_pred_or_func == MR_FUNCTION) {
|
|
*is_func_ptr = MR_BOOL_YES;
|
|
} else {
|
|
*is_func_ptr = MR_BOOL_NO;
|
|
}
|
|
}
|
|
}
|
|
|
|
void
|
|
MR_proc_id_arity_addedargs_predfunc(const MR_ProcLayout *proc, int *arity_ptr,
|
|
int *num_added_args_ptr, MR_PredFunc *pred_or_func_ptr)
|
|
{
|
|
if (MR_PROC_LAYOUT_IS_UCI(proc)) {
|
|
/*
|
|
** MR_comp_type_arity is the arity of the type constructor.
|
|
** Each argument of the type constructor adds a typeinfo
|
|
** argument to the headvars for all predicates, unify, compare
|
|
** and index. (The index predicate doesn't need these typeinfos,
|
|
** but it has them anyway.)
|
|
*/
|
|
|
|
*num_added_args_ptr = proc->MR_sle_uci.MR_uci_type_arity;
|
|
*arity_ptr = proc->MR_sle_num_head_vars - *num_added_args_ptr;
|
|
*pred_or_func_ptr = MR_PREDICATE;
|
|
} else {
|
|
*arity_ptr = proc->MR_sle_user.MR_user_arity;
|
|
*num_added_args_ptr = proc->MR_sle_num_head_vars - *arity_ptr;
|
|
*pred_or_func_ptr = proc->MR_sle_user.MR_user_pred_or_func;
|
|
}
|
|
}
|