mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-14 13:23:53 +00:00
Code Issues Projects Releases Wiki Activity
Files
d256d24ea57b79c9cf91a6fc83f882cd50a147d1
mercury/runtime/mercury_layout_util.c
Peter Wang 1094f42cc9 Conform to memory alignment requirements on doubles. 
On some 32-bit architectures, we were violating memory alignment
requirements for double-precision floats, in cell fields and on det and
nondet stacks.  Bug #299.

We now only take the address of a double field when it occurs on an
aligned memory address, i.e. when it starts at an even word offset from
the start of a cell (this assumption is incompatible with term-size
profiling which adds a hidden word before the start of the cell).

For the det stack, we can round up allocations to keep the stack pointer
double-aligned, then allocate slots for doubles at even word offsets
from the stack pointer.

It would be trickier for the nondet stack.  Multiple frame types exist
on the nondet stack, and the different frame types are identified by
their sizes: 3-word and 4-word temporary frames, and 5/6+ word ordinary
frames. Rather than rounding up frame sizes to even numbers of words,
we would probably want to dynamically pad ordinary frame allocations,
such that any doubles in the frame will be at aligned addresses.

However, in this change, we simply store box floats on the nondet stack.

compiler/globals.m:
	Add predicate which returns whether double-width floats
	should be stored on the det stack.

compiler/handle_options.m:
	Disable double-word fields in term-size profiling grades.

compiler/code_info.m:
	Add a predicate to round up det stack frame sizes.

	Remember the width of floats stored on the det stack in
	exprn_opts.

compiler/hlds_llds.m:
compiler/llds.m:
compiler/stack_layout.m:
	Delete the possibility of double-width slots on the nondet
	stack.

	Remember det_stack_float_width in exprn_opts.

compiler/llds_out_data.m:
	Add wrapper macro `MR_dword_ptr' when taking the address of a
	double.

	Only take the address of doubles on the det stack.

compiler/llds_out_instr.m:
compiler/llds_out_util.m:
	Only assign a double field in a single C statement when it is
	aligned.

	Assert that the stack pointer is incremented by an even number,
	if necessary.

compiler/mlds_to_c.m:
	Only take the address of doubles when aligned.

compiler/middle_rec.m:
compiler/proc_gen.m:
	Round up det stack frame allocations to even numbers of words
	when necessary.

compiler/stack_alloc.m:
	Add padding as required so that double-word variables will
	be allocated at even-word offsets from the stack pointer.

compiler/opt_debug.m:
compiler/par_conj_gen.m:
	Conform to changes.

runtime/mercury_conf_param.h:
runtime/mercury_float.h:
	Add macro `MR_dword_ptr' to be wrapped around instances where
	the address of a double is taken. When `MR_DEBUG_DWORD_ALIGNMENT'
	is defined (and using gcc or clang) the address is checked to be
	properly aligned.  Almost all our development is done on x86 or
	x86-64 architecture which do not have strict memory alignment
	requirements, making violations hard to check otherwise.

runtime/mercury_deconstruct.c:
runtime/mercury_layout_util.c:
	Use `MR_float_from_dword' over `MR_float_from_dword_ptr' as the
	former does not require dword alignment.

	Related fix: looking up `double' variables on the nondet stack
	used the stack pointer for the det stack instead.  Fix it,
	though the code now won't be executed after this change.

tests/debugger/nondet_stack.exp5:
	Add new expected output. This is the same as nondet_stack.exp
	except that det stack frames have been rounded up.
2013-10-29 17:30:39 +11:00

1070 lines
31 KiB
C
Raw Blame History

/*
** 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(
MR_based_stackvar(base_sp, locn_num + 1),
MR_based_stackvar(base_sp, locn_num)));
*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(
MR_based_framevar(base_curfr, locn_num + 1),
MR_based_framevar(base_curfr, locn_num)));
*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;
}
}
Reference in New Issue View Git Blame Copy Permalink