MR_TypeInfo
MR_make_type(int arity, MR_TypeCtorDesc type_ctor_desc, MR_Word arg_types_list)
{
MR_TypeCtorInfo type_ctor_info;
MR_Word *new_type_info_arena;
MR_Word new_type_info_arena_word;
MR_TypeInfo *new_type_info_args;
int i;
// We need to treat variable-arity types as a special case here.
if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
type_ctor_info = MR_TYPECTOR_DESC_GET_VA_TYPE_CTOR_INFO(
type_ctor_desc);
MR_restore_transient_registers();
MR_offset_incr_hp_msg(new_type_info_arena_word, 0,
MR_var_arity_type_info_size(arity),
MR_ALLOC_SITE_TYPE_INFO, NULL);
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
MR_save_transient_registers();
MR_fill_in_var_arity_type_info(new_type_info_arena, type_ctor_info,
arity, new_type_info_args);
} else {
type_ctor_info =
MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(type_ctor_desc);
if (arity == 0) {
return (MR_TypeInfo) type_ctor_info;
}
MR_restore_transient_registers();
MR_offset_incr_hp_msg(new_type_info_arena_word, 0,
MR_fixed_arity_type_info_size(arity),
MR_ALLOC_SITE_TYPE_INFO, NULL);
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
MR_save_transient_registers();
MR_fill_in_fixed_arity_type_info(new_type_info_arena, type_ctor_info,
new_type_info_args);
}
for (i = 1; i <= arity; i++) {
new_type_info_args[i] = (MR_TypeInfo) MR_list_head(arg_types_list);
arg_types_list = MR_list_tail(arg_types_list);
}
return (MR_TypeInfo) new_type_info_arena;
}
MR_Word
MR_arg_name_vector_to_list(int arity, const MR_ConstString *arg_names)
{
MR_Word arg_names_list;
MR_restore_transient_registers();
arg_names_list = MR_list_empty();
if (arg_names == NULL) {
/* No arguments have names. */
while (arity > 0) {
--arity;
arg_names_list = MR_string_list_cons((MR_Word) NULL,
arg_names_list);
}
} else {
while (arity > 0) {
--arity;
arg_names_list = MR_string_list_cons((MR_Word) arg_names[arity],
arg_names_list);
}
}
MR_save_transient_registers();
return arg_names_list;
}
void
MR_mkframe_msg(FILE *fp, const char *predname)
{
MR_restore_transient_registers();
if (!MR_lld_print_enabled) {
return;
}
fprintf(fp, "\nnew choice point for procedure %s\n", predname);
fprintf(fp, "new fr: ");
MR_printnondetstack(fp, MR_curfr);
fprintf(fp, "\nprev fr: ");
MR_printnondetstack(fp, MR_prevfr_slot(MR_curfr));
fprintf(fp, "\nsucc fr: ");
MR_printnondetstack(fp, MR_succfr_slot(MR_curfr));
fprintf(fp, "\nsucc ip: ");
MR_printlabel(fp, MR_succip_slot(MR_curfr));
fprintf(fp, "redo fr: ");
MR_printnondetstack(fp, MR_redofr_slot(MR_curfr));
fprintf(fp, "\nredo ip: ");
MR_printlabel(fp, MR_redoip_slot(MR_curfr));
#ifdef MR_USE_MINIMAL_MODEL_OWN_STACKS
fprintf(fp, "\ndet fr: ");
MR_printdetstack(fp, MR_table_detfr_slot(MR_curfr));
#endif
fprintf(fp, "\n");
if (MR_detaildebug) {
MR_dumpnondetstack(fp);
}
fflush(fp);
}
void
MR_tailcall_msg(FILE *fp, const MR_Code *proc)
{
MR_restore_transient_registers();
MR_count_call(fp, proc);
#ifdef MR_DEEP_PROFILING
MR_check_watch_csd_start(proc);
#endif // MR_DEEP_PROFILING
MR_do_watches(fp);
if (!MR_lld_print_enabled) {
return;
}
fprintf(fp, "\ntail call %lu: ", MR_lld_cur_call);
MR_printlabel(fp, proc);
fprintf(fp, "cont ");
MR_printlabel(fp, MR_succip);
if (MR_anyregdebug) {
MR_printregs(fp, "at tailcall:");
}
#ifdef MR_DEEP_PROFILING
MR_print_deep_prof_vars(fp, "MR_tailcall_msg");
#endif
}
void
MR_mkdettempframe_msg(FILE *fp)
{
MR_restore_transient_registers();
if (!MR_lld_print_enabled) {
return;
}
fprintf(fp, "\nnew det temp nondet frame");
fprintf(fp, "\nnew fr: ");
MR_printnondetstack(fp, MR_maxfr);
fprintf(fp, "\nprev fr: ");
MR_printnondetstack(fp, MR_prevfr_slot(MR_maxfr));
fprintf(fp, "\nredo fr: ");
MR_printnondetstack(fp, MR_redofr_slot(MR_maxfr));
fprintf(fp, "\nredo ip: ");
MR_printlabel(fp, MR_redoip_slot(MR_maxfr));
fprintf(fp, "det fr: ");
MR_printdetstack(fp, MR_tmp_detfr_slot(MR_maxfr));
fprintf(fp, "\n");
if (MR_detaildebug) {
MR_dumpnondetstack(fp);
}
}
MR_Word
MR_pseudo_type_info_vector_to_pseudo_type_info_list(int arity,
MR_TypeInfoParams type_params,
const MR_PseudoTypeInfo *arg_pseudo_type_infos)
{
MR_PseudoTypeInfo pseudo;
MR_PseudoTypeInfo arg_pseudo_type_info;
MR_Word pseudo_type_info_list;
MR_restore_transient_registers();
pseudo_type_info_list = MR_list_empty();
while (--arity >= 0) {
/* Get the argument type_info */
pseudo = arg_pseudo_type_infos[arity];
if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo) &&
MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo))
{
arg_pseudo_type_info = pseudo;
} else {
MR_save_transient_registers();
arg_pseudo_type_info =
MR_create_pseudo_type_info(
(MR_PseudoTypeInfoParams) type_params, pseudo);
MR_restore_transient_registers();
MR_save_transient_registers();
arg_pseudo_type_info =
MR_collapse_equivalences_pseudo(arg_pseudo_type_info);
MR_restore_transient_registers();
}
pseudo_type_info_list = MR_pseudo_type_info_list_cons(
(MR_Word) arg_pseudo_type_info, pseudo_type_info_list);
}
MR_save_transient_registers();
return pseudo_type_info_list;
}
MR_Word
MR_set_reg(int num, MR_Word val)
{
MR_restore_transient_registers();
switch (num) {
case 1: MR_r1 = val; MR_save_transient_registers(); return val;
case 2: MR_r2 = val; MR_save_transient_registers(); return val;
case 3: MR_r3 = val; MR_save_transient_registers(); return val;
case 4: MR_r4 = val; MR_save_transient_registers(); return val;
case 5: MR_r5 = val; MR_save_transient_registers(); return val;
case 6: MR_r6 = val; MR_save_transient_registers(); return val;
case 7: MR_r7 = val; MR_save_transient_registers(); return val;
case 8: MR_r8 = val; MR_save_transient_registers(); return val;
case 9: MR_r9 = val; MR_save_transient_registers(); return val;
case 10: MR_r10 = val; MR_save_transient_registers(); return val;
case 11: MR_r11 = val; MR_save_transient_registers(); return val;
case 12: MR_r12 = val; MR_save_transient_registers(); return val;
case 13: MR_r13 = val; MR_save_transient_registers(); return val;
case 14: MR_r14 = val; MR_save_transient_registers(); return val;
case 15: MR_r15 = val; MR_save_transient_registers(); return val;
case 16: MR_r16 = val; MR_save_transient_registers(); return val;
case 17: MR_r17 = val; MR_save_transient_registers(); return val;
case 18: MR_r18 = val; MR_save_transient_registers(); return val;
case 19: MR_r19 = val; MR_save_transient_registers(); return val;
case 20: MR_r20 = val; MR_save_transient_registers(); return val;
case 21: MR_r21 = val; MR_save_transient_registers(); return val;
case 22: MR_r22 = val; MR_save_transient_registers(); return val;
case 23: MR_r23 = val; MR_save_transient_registers(); return val;
case 24: MR_r24 = val; MR_save_transient_registers(); return val;
case 25: MR_r25 = val; MR_save_transient_registers(); return val;
case 26: MR_r26 = val; MR_save_transient_registers(); return val;
case 27: MR_r27 = val; MR_save_transient_registers(); return val;
case 28: MR_r28 = val; MR_save_transient_registers(); return val;
case 29: MR_r29 = val; MR_save_transient_registers(); return val;
case 30: MR_r30 = val; MR_save_transient_registers(); return val;
case 31: MR_r31 = val; MR_save_transient_registers(); return val;
case 32: MR_r32 = val; MR_save_transient_registers(); return val;
}
/* NOTREACHED */
fprintf(stderr, "register %d out of range in set_reg\n", num);
abort();
return 0;
}
MR_Word
MR_get_reg(int num)
{
MR_restore_transient_registers();
switch (num) {
case 1: return MR_r1;
case 2: return MR_r2;
case 3: return MR_r3;
case 4: return MR_r4;
case 5: return MR_r5;
case 6: return MR_r6;
case 7: return MR_r7;
case 8: return MR_r8;
case 9: return MR_r9;
case 10: return MR_r10;
case 11: return MR_r11;
case 12: return MR_r12;
case 13: return MR_r13;
case 14: return MR_r14;
case 15: return MR_r15;
case 16: return MR_r16;
case 17: return MR_r17;
case 18: return MR_r18;
case 19: return MR_r19;
case 20: return MR_r20;
case 21: return MR_r21;
case 22: return MR_r22;
case 23: return MR_r23;
case 24: return MR_r24;
case 25: return MR_r25;
case 26: return MR_r26;
case 27: return MR_r27;
case 28: return MR_r28;
case 29: return MR_r29;
case 30: return MR_r30;
case 31: return MR_r31;
case 32: return MR_r32;
}
/* NOTREACHED */
fprintf(stderr, "register %d out of range in get_reg\n", num);
abort();
return 0;
}
MR_Word
MR_type_params_vector_to_list(int arity, MR_TypeInfoParams type_params)
{
MR_TypeInfo arg_type;
MR_Word type_info_list;
MR_restore_transient_registers();
type_info_list = MR_list_empty();
while (arity > 0) {
type_info_list = MR_type_info_list_cons((MR_Word) type_params[arity],
type_info_list);
--arity;
}
MR_save_transient_registers();
return type_info_list;
}
void
MR_redo_msg(FILE *fp)
{
MR_restore_transient_registers();
MR_do_watches(fp);
if (!MR_lld_print_enabled) {
return;
}
fprintf(fp, "\nredo from procedure");
fprintf(fp, "\ncurr fr: ");
MR_printnondetstack(fp, MR_curfr);
fprintf(fp, "\nredo fr: ");
MR_printnondetstack(fp, MR_maxfr);
fprintf(fp, "\nredo ip: ");
MR_printlabel(fp, MR_redoip_slot(MR_maxfr));
}
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_succeeddiscard_msg(FILE *fp)
{
MR_restore_transient_registers();
MR_do_watches(fp);
if (!MR_lld_print_enabled) {
return;
}
fprintf(fp, "\nsucceeding from procedure\n");
fprintf(fp, "curr fr: ");
MR_printnondetstack(fp, MR_curfr);
fprintf(fp, "succ fr: ");
MR_printnondetstack(fp, MR_succfr_slot(MR_curfr));
fprintf(fp, "succ ip: ");
MR_printlabel(fp, MR_succip_slot(MR_curfr));
if (MR_detaildebug) {
MR_printregs(fp, "registers at success");
}
}
void
MR_printregs(FILE *fp, const char *msg)
{
MR_restore_transient_registers();
fprintf(fp, "\n%s\n", msg);
if (MR_sregdebug) {
fprintf(fp, "%-9s", "succip:");
MR_printlabel(fp, MR_succip);
fprintf(fp, "%-9s", "curfr:");
MR_printnondetstack(fp, MR_curfr);
fprintf(fp, "%-9s", "maxfr:");
MR_printnondetstack(fp, MR_maxfr);
fprintf(fp, "%-9s", "hp:");
MR_printheap(fp, MR_hp);
fprintf(fp, "%-9s", "sp:");
MR_printdetstack(fp, MR_sp);
}
if (MR_ordregdebug) {
MR_print_ordinary_regs(fp);
}
}
static MR_bool
MR_spy_cond_is_true(MR_SpyPoint *point, const MR_LabelLayout *label_layout)
{
int max_mr_num;
MR_Word saved_regs[MR_MAX_FAKE_REG];
int max_f_num;
MR_Float saved_f_regs[MR_MAX_VIRTUAL_F_REG];
const char *problem;
char *bad_path;
MR_TypeInfo type_info;
MR_Word value;
const char *name;
MR_Word *value_ptr;
MR_TypeInfo sub_type_info;
MR_Word *sub_value_ptr;
MR_Word match;
MR_bool saved_trace_func_enabled;
MR_bool retval;
MR_SpyCond *cond;
if (point->MR_spy_cond == NULL) {
return MR_TRUE;
}
MR_restore_transient_registers();
cond = point->MR_spy_cond;
/*
** From this point, returning should be done by setting both
** MR_spy_point_cond_problem and retval, and goto end.
*/
MR_spy_point_cond_bad = cond;
MR_spy_point_cond_problem = "internal error in MR_spy_cond_is_true";
retval = MR_TRUE;
MR_compute_max_mr_num(max_mr_num, label_layout);
max_f_num = label_layout->MR_sll_entry->MR_sle_max_f_num;
/* This also saves the regs in MR_fake_regs. */
MR_copy_regs_to_saved_regs(max_mr_num, saved_regs,
max_f_num, saved_f_regs);
MR_trace_init_point_vars(label_layout, saved_regs, saved_f_regs,
(MR_TracePort) label_layout->MR_sll_port, MR_FALSE);
problem = MR_lookup_unambiguous_var_spec(cond->MR_cond_var_spec,
&type_info, &value, &name);
if (problem != NULL) {
if (cond->MR_cond_require_var) {
MR_spy_point_cond_problem = problem;
retval = MR_TRUE;
} else {
MR_spy_point_cond_problem = NULL;
retval = MR_FALSE;
}
goto end;
}
value_ptr = &value;
bad_path = MR_select_specified_subterm(cond->MR_cond_path,
type_info, value_ptr, &sub_type_info, &sub_value_ptr);
if (bad_path != NULL) {
if (cond->MR_cond_require_var) {
MR_spy_point_cond_problem = MR_trace_bad_path(cond->MR_cond_path,
bad_path);
retval = MR_TRUE;
} else {
MR_spy_point_cond_problem = NULL;
retval = MR_FALSE;
}
goto end;
}
#ifdef MR_DEBUG_SPY_COND
MR_print_cterm(stdout, cond->cond_term);
fprintf(stdout, ": ");
#endif
saved_trace_func_enabled = MR_trace_func_enabled;
MR_trace_func_enabled = MR_FALSE;
MR_TRACE_CALL_MERCURY(
ML_BROWSE_match_with_cterm((MR_Word) sub_type_info, *sub_value_ptr,
cond->MR_cond_term, &match);
);
MR_bool
MR_event_matches_spy_point(const MR_LabelLayout *layout,
MR_TracePort port, MR_SpyAction *action_ptr,
MR_SpyPrintList *print_list_ptr)
{
int slot;
MR_bool enabled;
MR_SpyPoint *point;
MR_SpyAction action;
MR_SpyPrintList print_list;
const MR_LabelLayout *parent;
const MR_UserEvent *user_event;
const MR_UserEventSpec *user_event_spec;
const char *user_event_set;
const char *user_event_name;
const char *problem;
MR_Word *base_sp;
MR_Word *base_curfr;
MR_Level actual_level;
enabled = MR_FALSE;
action = MR_SPY_PRINT;
print_list = NULL;
if (MR_spied_label_next > 0) {
slot = MR_search_spy_table_for_label(layout);
if (slot >= 0) {
point = MR_spy_points[MR_spied_labels[slot].MR_sl_point_num];
if (point->MR_spy_when != MR_SPY_LINENO) {
MR_fatal_error("non-lineno spy point in spied labels array");
}
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
}
if (MR_port_is_interface(port)) {
MR_restore_transient_registers();
base_sp = MR_sp;
base_curfr = MR_curfr;
parent = MR_find_nth_ancestor(layout, 1, &base_sp, &base_curfr,
&actual_level, &problem);
if (parent != NULL && actual_level == 1 &&
0 <= (slot = MR_search_spy_table_for_label(parent)))
{
point = MR_spy_points[MR_spied_labels[slot].MR_sl_point_num];
if (point->MR_spy_when != MR_SPY_LINENO) {
MR_fatal_error("non-lineno spy point in "
"spied labels array");
}
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
}
}
}
user_event = layout->MR_sll_user_event;
if (user_event != NULL) {
user_event_spec = &MR_user_event_spec(layout);
user_event_name = user_event_spec->MR_ues_event_name;
user_event_set = MR_user_event_set_name(layout);
/*
** Check for breakpoints that specify an event name, and possibly
** and event set.
*/
slot = MR_search_spy_table_for_user_event_name(user_event_name);
if (slot >= 0) {
for (point = MR_spied_user_events[slot].MR_sue_points;
point != NULL; point = point->MR_spy_next)
{
if (point->MR_spy_when != MR_SPY_USER_EVENT) {
MR_fatal_error("non-named-user-event spy point "
"in named user event array");
}
if (point->MR_spy_user_event_set == NULL ||
MR_streq(user_event_set, point->MR_spy_user_event_set))
{
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
}
}
}
/*
** Check for breakpoints that specify just an event set.
*/
slot = MR_search_spy_table_for_user_event_set(user_event_set);
if (slot >= 0) {
for (point = MR_spied_user_event_sets[slot].MR_sues_points;
point != NULL; point = point->MR_spy_next)
{
if (point->MR_spy_when != MR_SPY_USER_EVENT_SET) {
MR_fatal_error("non-named-user-event spy point "
"in named user event array");
}
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
}
}
/*
** Check for breakpoints that specify neither event name nor event set.
*/
for (point = MR_spied_universal_user_events; point != NULL;
point = point->MR_spy_next)
{
if (point->MR_spy_when != MR_SPY_USER_EVENT_SET) {
MR_fatal_error("non-unnamed-user-event spy point "
"in unnamed user event list");
}
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
}
}
slot = MR_search_spy_table_for_proc(layout->MR_sll_entry);
if (slot >= 0) {
for (point = MR_spied_procs[slot].MR_sp_points; point != NULL;
point = point->MR_spy_next)
{
switch (point->MR_spy_when) {
case MR_SPY_ALL:
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
break;
case MR_SPY_ENTRY:
if (MR_port_is_entry(port)) {
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
} else {
continue;
}
break;
case MR_SPY_INTERFACE:
if (MR_port_is_interface(port)) {
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
} else {
continue;
}
break;
case MR_SPY_SPECIFIC:
if (layout == point->MR_spy_label) {
MR_update_enabled_action(point, layout, port,
&enabled, &action, &print_list);
} else {
continue;
}
break;
case MR_SPY_LINENO:
MR_fatal_error("lineno spy point in spied procs array");
break;
case MR_SPY_USER_EVENT:
MR_fatal_error("user_event spy point "
"in spied procs array");
break;
case MR_SPY_USER_EVENT_SET:
MR_fatal_error("user_event_set spy point "
"in spied procs array");
break;
default:
MR_fatal_error("bad spy point when in "
"MR_event_matches_spy_point");
}
}
}
if (enabled) {
*action_ptr = action;
*print_list_ptr = print_list;
return MR_TRUE;
} else {
return MR_FALSE;
}
}
MR_bool
MR_default_handler(MR_Word *fault_addr, MR_MemoryZone *zone, void *context)
{
#ifndef MR_CHECK_OVERFLOW_VIA_MPROTECT
return MR_FALSE;
#else
MR_Word *new_zone;
size_t zone_size;
new_zone = (MR_Word *) MR_round_up((MR_Unsigned) fault_addr
+ sizeof(MR_Word), MR_unit);
if (new_zone <= zone->MR_zone_hardmax) {
zone_size = (char *) new_zone - (char *) zone->MR_zone_redzone;
if (MR_memdebug) {
fprintf(stderr, "trying to unprotect %s#%"
MR_INTEGER_LENGTH_MODIFIER "d from %p to %p (%x)\n",
zone->MR_zone_name, zone->MR_zone_id,
(void *) zone->MR_zone_redzone, (void *) new_zone,
(int) zone_size);
}
if (MR_protect_pages((char *) zone->MR_zone_redzone, zone_size,
PROT_READ|PROT_WRITE) < 0)
{
char buf[2560];
sprintf(buf, "Mercury runtime: cannot unprotect %s#%"
MR_INTEGER_LENGTH_MODIFIER "d zone",
zone->MR_zone_name, zone->MR_zone_id);
perror(buf);
exit(1);
}
zone->MR_zone_redzone = new_zone;
if (MR_memdebug) {
fprintf(stderr, "successful: %s#%" MR_INTEGER_LENGTH_MODIFIER
"d redzone now %p to %p\n",
zone->MR_zone_name, zone->MR_zone_id,
(void *) zone->MR_zone_redzone, (void *) zone->MR_zone_top);
}
#if defined(MR_NATIVE_GC) && !defined(MR_HIGHLEVEL_CODE)
MR_schedule_agc(get_pc_from_context(context),
get_sp_from_context(context),
get_curfr_from_context(context));
#endif
return MR_TRUE;
} else {
char buf[2560];
if (MR_memdebug) {
fprintf(stderr, "can't unprotect last page of %s#%"
MR_INTEGER_LENGTH_MODIFIER "d\n",
zone->MR_zone_name, zone->MR_zone_id);
fflush(stdout);
}
#ifdef MR_STACK_EXTEND_DEBUG
MR_restore_transient_registers();
fprintf(stderr, "sp = %p, maxfr = %p\n", MR_sp, MR_maxfr);
MR_debug_memory_zone(stderr, zone);
#endif
sprintf(buf, "\nMercury runtime: memory zone %s#%"
MR_INTEGER_LENGTH_MODIFIER "d overflowed\n",
zone->MR_zone_name, zone->MR_zone_id);
MR_fatal_abort(context, buf, MR_TRUE);
}
return MR_FALSE;
#endif
}
