mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-15 22:03:26 +00:00
Code Issues Projects Releases Wiki Activity
Files
1cfbebfe8c90e9095720b2e97c532efb51f44474
mercury/runtime/mercury_layout_util.c
Zoltan Somogyi 8d57bbfb27 Fix the failure of the user event related test cases on saturn and other 
Estimated hours taken: 0.5
Branches: main

Fix the failure of the user event related test cases on saturn and other
64 bit machines. The problem was that MR_LongLvals, which were 32 bits
in size, were being asked store pointers to closures, which on these
platforms are 64 bits. The fix is to make MR_LongLvals contain MR_Unsigneds,
whose size adjusts to the platform.

runtime/mercury_stack_layout.h:
	Make the change described above.

	Change the macros for looking up long and short lval descriptions
	to return the semantic types MR_LongLval and MR_ShortLval, not the
	physical types they are equivalent to. This will make similar problems
	easier to spot in future.

runtime/mercury_layout_util.c:
trace/mercury_trace.c:
	Conform to the change to mercury_stack_layout.h.

compiler/stack_layout.m:
	Give the size of the rvals represent MR_LongLvals as unsigned,
	not as uint_least32_t.
2007-01-08 09:15:22 +00:00

948 lines
27 KiB
C
Raw Blame History

/*
** vim: ts=4 sw=4 expandtab
*/
/*
** Copyright (C) 1998-2007 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)
{
/*
** 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.
*/
int i;
MR_restore_transient_registers();
MR_save_registers();
for (i = 0; i <= max_mr_num; i++) {
saved_regs[i] = MR_fake_reg[i];
}
}
void
MR_copy_saved_regs_to_regs(int max_mr_num, MR_Word *saved_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];
}
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].MR_long_lval != 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, &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].MR_long_lval != 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].MR_long_lval != 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].MR_long_lval != 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)
{
if (MR_LONG_LVAL_TYPE(locn) == MR_LONG_LVAL_TYPE_R) {
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_bool *succeeded)
{
return MR_lookup_long_lval_base(locn, saved_regs,
MR_saved_sp(saved_regs), MR_saved_curfr(saved_regs), succeeded);
}
static MR_Word
MR_lookup_closure_long_lval(MR_LongLval locn, MR_Closure *closure,
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("closure r%d\n", locn_num);
}
if (locn_num <= closure->MR_closure_num_hidden_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);
}
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_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.MR_long_lval = locn_num;
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
sublocn.MR_long_lval =
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:
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_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.MR_long_lval = locn_num;
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
sublocn.MR_long_lval =
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:
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_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.MR_long_lval = locn_num;
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
sublocn.MR_long_lval =
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:
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_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);
}
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_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.MR_long_lval = locn_num;
offset = MR_LONG_LVAL_INDIRECT_OFFSET(indirect_lval);
sublocn.MR_long_lval =
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, 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:
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_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),
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_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;
pseudo_type_info = MR_var_pti(label_layout, i);
*type_info = MR_create_type_info(type_params, pseudo_type_info);
if (i < MR_long_desc_var_count(label_layout)) {
if (MR_print_locn) {
printf("looking up long lval\n");
}
long_locn.MR_long_lval =
MR_long_desc_var_locn(label_layout, i).MR_long_lval;
*value = MR_lookup_long_lval_base(long_locn,
saved_regs, base_sp, base_curfr, &succeeded);
} else {
if (MR_print_locn) {
printf("looking up short lval\n");
}
short_locn = MR_short_desc_var_locn(label_layout, i),
*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