MR_TypeCtorDesc
MR_make_type_ctor_desc_pseudo(MR_PseudoTypeInfo pseudo,
MR_TypeCtorInfo type_ctor_info)
{
MR_TypeCtorDesc type_ctor_desc;
if (MR_TYPE_CTOR_INFO_IS_HO_PRED(type_ctor_info)) {
type_ctor_desc = MR_TYPECTOR_DESC_MAKE_PRED(
MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo));
if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
}
} else if (MR_TYPE_CTOR_INFO_IS_HO_FUNC(type_ctor_info)) {
type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FUNC(
MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo));
if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
}
} else if (MR_TYPE_CTOR_INFO_IS_TUPLE(type_ctor_info)) {
type_ctor_desc = MR_TYPECTOR_DESC_MAKE_TUPLE(
MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo));
if (! MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
MR_fatal_error("MR_make_type_ctor_desc - arity out of range.");
}
} else {
type_ctor_desc = MR_TYPECTOR_DESC_MAKE_FIXED_ARITY(type_ctor_info);
}
return type_ctor_desc;
}
void
MR_STM_detach_waiter(MR_STM_Var *var, MR_STM_ConditionVar *cvar)
{
MR_STM_Waiter *curr_waiter;
MR_assert(var != NULL);
MR_assert(var->MR_STM_var_waiters != NULL);
curr_waiter = var->MR_STM_var_waiters;
while (curr_waiter != NULL) {
if (curr_waiter->MR_STM_cond_var == cvar) {
if (curr_waiter == var->MR_STM_var_waiters) {
var->MR_STM_var_waiters =
var->MR_STM_var_waiters->MR_STM_waiter_next;
}
if (curr_waiter->MR_STM_waiter_prev != NULL) {
curr_waiter->MR_STM_waiter_prev->MR_STM_waiter_next =
curr_waiter->MR_STM_waiter_next;
}
if (curr_waiter->MR_STM_waiter_next != NULL) {
curr_waiter->MR_STM_waiter_next->MR_STM_waiter_prev =
curr_waiter->MR_STM_waiter_prev;
}
curr_waiter = NULL;
return;
}
curr_waiter = curr_waiter->MR_STM_waiter_next;
}
MR_fatal_error("MR_STM_detach_waiter: Thread ID not in wait queue");
}
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;
}
}
/*
** MR_STM_block_thread is called to block the thread in high level C grades,
** using POSIX thread facilities, as there is a POSIX thread for every
** Mercury thread in these grades. The low level C grade equivalent of this
** code is defined in the stm_builtin library module.
*/
void
MR_STM_block_thread(MR_STM_TransLog *tlog)
{
#if defined(MR_THREAD_SAFE)
MR_STM_ConditionVar *thread_condvar;
thread_condvar = MR_GC_NEW_ATTRIB(MR_STM_ConditionVar,
MR_ALLOC_SITE_RUNTIME);
MR_STM_condvar_init(thread_condvar);
MR_STM_wait(tlog, thread_condvar);
#if defined(MR_STM_DEBUG)
fprintf(stderr, "STM BLOCKING: log <0x%.8lx>\n", (MR_Word)tlog);
#endif
MR_STM_condvar_wait(thread_condvar, &MR_STM_lock);
#if defined(MR_STM_DEBUG)
fprintf(stderr, "STM RESCHEDULING: log <0x%.8lx>\n", (MR_Word)tlog);
#endif
MR_STM_unwait(tlog, thread_condvar);
MR_UNLOCK(&MR_STM_lock, "MR_STM_block_thread");
MR_GC_free_attrib(thread_condvar);
#else
MR_fatal_error("Blocking thread in non-parallel grade");
#endif
}
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_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;
}
}
int
MR_compare_type_ctor_info(MR_TypeCtorInfo tci1, MR_TypeCtorInfo tci2)
{
int i;
int comp;
MR_ConstString modulename1;
MR_ConstString modulename2;
MR_ConstString typename1;
MR_ConstString typename2;
int arity1;
int arity2;
/*
** We are relying on the fact that type_ctor_infos are always
** statically allocated to ensure that two type_ctor_infos are
** for the same type iff their address is the same.
**
** The casts to (MR_Unsigned) here are in the hope of increasing
** the chance that this will work on a segmented architecture.
*/
if ((MR_Unsigned) tci1 == (MR_Unsigned) tci2) {
return MR_COMPARE_EQUAL;
}
modulename1 = tci1->MR_type_ctor_module_name;
modulename2 = tci2->MR_type_ctor_module_name;
comp = strcmp(modulename1, modulename2);
if (comp < 0) {
return MR_COMPARE_LESS;
} else if (comp > 0) {
return MR_COMPARE_GREATER;
}
typename1 = tci1->MR_type_ctor_name;
typename2 = tci2->MR_type_ctor_name;
comp = strcmp(typename1, typename2);
if (comp < 0) {
return MR_COMPARE_LESS;
} else if (comp > 0) {
return MR_COMPARE_GREATER;
}
arity1 = tci1->MR_type_ctor_arity;
arity2 = tci2->MR_type_ctor_arity;
if (arity1 < arity2) {
return MR_COMPARE_LESS;
} else if (arity1 > arity2) {
return MR_COMPARE_GREATER;
}
MR_fatal_error("type_ctor_info match at distinct addresses");
}
MR_Unsigned *
MR_trace_lookup_trace_count(const MR_LabelLayout *label_layout)
{
const MR_ModuleLayout *module_layout;
const MR_ProcLayout *proc_layout;
MR_uint_least16_t label_number;
proc_layout = label_layout->MR_sll_entry;
if (! MR_PROC_LAYOUT_HAS_EXEC_TRACE(proc_layout)) {
MR_fatal_error("MR_trace_lookup_trace_count: no exec trace");
}
module_layout = proc_layout->MR_sle_module_layout;
label_number = label_layout->MR_sll_label_num_in_module;
if (label_number >= module_layout->MR_ml_num_label_exec_counts) {
MR_fatal_error("MR_trace_lookup_trace_count: invalid label number");
}
return &(module_layout->MR_ml_label_exec_count[label_number]);
}
MR_Code *
MR_trace_count(const MR_LabelLayout *label_layout)
{
MR_Unsigned *exec_count;
exec_count = MR_trace_lookup_trace_count(label_layout);
#ifdef MR_TRACE_COUNT_DEBUG
{
const MR_LabelLayout *call_label_layout;
MR_uint_least16_t call_label_number;
const MR_ModuleLayout *module_layout;
const MR_ProcLayout *proc_layout;
proc_layout = label_layout->MR_sll_entry;
module_layout = proc_layout->MR_sle_module_layout;
call_label_layout = proc_layout->MR_sle_call_label;
if (label_layout != call_label_layout) {
/*
** We should only get here if we have executed the call label,
** which means its count should be nonzero.
*/
call_label_number = call_label_layout->MR_sll_label_num_in_module;
if (call_label_number >=
module_layout->MR_ml_num_label_exec_counts)
{
MR_fatal_error("MR_trace_count: invalid call label number");
}
if (module_layout->MR_ml_label_exec_count[call_label_number] == 0)
{
MR_fatal_error("MR_trace_count: call label count is zero");
}
}
}
#endif
*exec_count += 1;
return NULL;
}
void
MR_tracing_not_enabled(void)
{
MR_fatal_error("This executable is not set up for debugging.\n"
"Rebuild the <main>_init.c file, "
"and give the `-t' (or `--trace')\n"
"option to c2init when you do so. "
"If you are using mmake, you\n"
"can do this by including "
"`-t' (or `--trace') in C2INITFLAGS.\n"
"For further details, please see the \"Debugging\" chapter "
"of the\n"
"Mercury User's Guide.\n");
}
void
MR_goto_msg(FILE *fp, const MR_Code *addr)
{
if (!MR_lld_print_enabled) {
return;
}
if (addr == NULL) {
fprintf(fp, "\ngoto NULL\n");
MR_fatal_error("MR_goto_msg: NULL");
}
fprintf(fp, "\ngoto ");
MR_printlabel(fp, addr);
}
static MR_TypeInfo
MR_get_arg_type_info(const MR_TypeInfoParams params,
const MR_PseudoTypeInfo pseudo_type_info, const MR_Word *data_value,
const MR_DuFunctorDesc *functor_desc)
{
MR_Unsigned arg_num;
const MR_DuExistInfo *exist_info;
MR_DuExistLocn exist_locn;
int exist_varnum;
int slot;
int offset;
/*
** Most changes here should also be reflected in
** MR_get_arg_pseudo_type_info above.
*/
arg_num = (MR_Unsigned) pseudo_type_info;
if (MR_TYPE_VARIABLE_IS_UNIV_QUANT(pseudo_type_info)) {
/*
** This is a universally quantified type variable.
*/
return params[arg_num];
}
/*
** This is an existentially quantified type variable.
*/
exist_info = functor_desc->MR_du_functor_exist_info;
if (exist_info == NULL) {
MR_fatal_error("MR_get_arg_type_info: no exist_info");
}
exist_varnum = arg_num - MR_PSEUDOTYPEINFO_EXIST_VAR_BASE - 1;
exist_locn = exist_info->MR_exist_typeinfo_locns[exist_varnum];
slot = exist_locn.MR_exist_arg_num;
offset = exist_locn.MR_exist_offset_in_tci;
if (offset < 0) {
return (MR_TypeInfo) data_value[slot];
} else {
return (MR_TypeInfo) MR_typeclass_info_param_type_info(
data_value[slot], offset);
}
}
void
MR_do_insert_entry_label(const char *name, MR_Code *addr,
const MR_ProcLayout *entry_layout)
{
MR_do_init_label_tables();
#ifdef MR_MPROF_PROFILE_CALLS
if (MR_profiling) {
MR_prof_output_addr_decl(name, addr);
}
#endif /* MR_MPROF_PROFILE_CALLS */
#ifdef MR_LOWLEVEL_DEBUG
if (MR_progdebug) {
/*
** We can't assume that MR_LOWLEVEL_DEBUG was turned on in the code
** that generated the call to this function just because
** MR_LOWLEVEL_DEBUG is turned on here.
*/
if (name != NULL) {
printf("recording entry label %s at %p\n", name, addr);
} else {
printf("recording entry label at %p\n", addr);
}
}
#endif /* MR_LOWLEVEL_DEBUG */
#ifdef MR_NEED_ENTRY_LABEL_ARRAY
if (entry_array_next >= entry_array_size) {
entry_array_size *= 2;
entry_array = realloc(entry_array,
entry_array_size * sizeof(MR_Entry));
if (entry_array == NULL) {
MR_fatal_error("run out of memory for entry label array");
}
}
entry_array[entry_array_next].MR_entry_addr = addr;
entry_array[entry_array_next].MR_entry_name = name;
entry_array[entry_array_next].MR_entry_layout = entry_layout;
entry_array_next++;
entry_array_sorted = MR_FALSE;
#endif /* MR_NEED_ENTRY_LABEL_ARRAY */
}
static void
MR_update_enabled_action(MR_SpyPoint *point, const MR_LabelLayout *layout,
MR_TracePort port, MR_bool *enabled_ptr, MR_SpyAction *action_ptr,
MR_SpyPrintList *print_list_ptr)
{
if (point->MR_spy_enabled && MR_spy_cond_is_true(point, layout)) {
if (point->MR_spy_ignore_count == 0) {
*enabled_ptr = MR_TRUE;
*action_ptr = MR_max(*action_ptr, point->MR_spy_action);
if (*print_list_ptr == NULL) {
*print_list_ptr = point->MR_spy_print_list;
}
} else if (point->MR_spy_ignore_count > 0) {
switch (point->MR_spy_ignore_when) {
case MR_SPY_DONT_IGNORE:
break;
case MR_SPY_IGNORE_ENTRY:
if (port == MR_PORT_CALL) {
--point->MR_spy_ignore_count;
}
break;
case MR_SPY_IGNORE_INTERFACE:
if (MR_port_is_interface(port)) {
--point->MR_spy_ignore_count;
}
break;
case MR_SPY_IGNORE_ALL:
--point->MR_spy_ignore_count;
break;
default:
MR_fatal_error("MR_update_enabled_action: "
"invalid ignore_when");
}
}
}
}
MR_Word
MR_typeclass_ref_error(MR_Word tci, int n, const char *msg)
{
fprintf(stderr,
"n1: # of extra instance args: %" MR_INTEGER_LENGTH_MODIFIER "d\n",
MR_typeclass_info_num_extra_instance_args(tci));
fprintf(stderr,
"n1-n2: # of instance type vars: %" MR_INTEGER_LENGTH_MODIFIER "d\n",
MR_typeclass_info_num_instance_type_vars(tci));
fprintf(stderr,
"n2: # of instance constraints: %" MR_INTEGER_LENGTH_MODIFIER "d\n",
MR_typeclass_info_num_instance_constraints(tci));
fprintf(stderr,
"n3: # of superclasses: %" MR_INTEGER_LENGTH_MODIFIER "d\n",
MR_typeclass_info_num_superclasses(tci));
fprintf(stderr,
"n4: # of parameters: %" MR_INTEGER_LENGTH_MODIFIER "d\n",
MR_typeclass_info_num_params(tci));
fprintf(stderr, "access parameters: %s, %d\n", msg, n);
MR_fatal_error("typeclass_info reference error");
/* not reached */
return 0;
}
MR_bool MR_CALL
mercury__builtin__unify_2_p_0(MR_Mercury_Type_Info ti, MR_Box x, MR_Box y)
{
MR_TypeInfo type_info;
MR_TypeCtorInfo type_ctor_info;
MR_TypeCtorRep type_ctor_rep;
int arity;
MR_TypeInfoParams params;
MR_Mercury_Type_Info *args;
MR_ProcAddr unify_pred;
type_info = (MR_TypeInfo) ti;
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
// Tuple and higher-order types do not have a fixed arity,
// so they need to be special cased here.
type_ctor_rep = MR_type_ctor_rep(type_ctor_info);
if (type_ctor_rep == MR_TYPECTOR_REP_TUPLE) {
if (MR_special_pred_hooks.MR_unify_tuple_pred != NULL) {
return MR_special_pred_hooks.MR_unify_tuple_pred(ti,
(MR_Word) x, (MR_Word) y);
}
} else if (type_ctor_rep == MR_TYPECTOR_REP_PRED) {
return mercury__builtin____Unify____pred_0_0((MR_Pred) x, (MR_Pred) y);
} else if (type_ctor_rep == MR_TYPECTOR_REP_FUNC) {
return mercury__builtin____Unify____pred_0_0((MR_Pred) x, (MR_Pred) y);
}
arity = type_ctor_info->MR_type_ctor_arity;
params = MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info);
args = (MR_Mercury_Type_Info *) params;
unify_pred = type_ctor_info->MR_type_ctor_unify_pred;
// Cast unify_pred to the right type and then call it,
// passing the right number of type_info arguments.
switch (arity) {
case 0:
return ((MR_UnifyFunc_0 *) unify_pred)(x, y);
case 1:
return ((MR_UnifyFunc_1 *) unify_pred)(args[1], x, y);
case 2:
return ((MR_UnifyFunc_2 *) unify_pred)(args[1], args[2], x, y);
case 3:
return ((MR_UnifyFunc_3 *) unify_pred)(args[1], args[2], args[3],
x, y);
case 4:
return ((MR_UnifyFunc_4 *) unify_pred)(args[1], args[2], args[3],
args[4], x, y);
case 5:
return ((MR_UnifyFunc_5 *) unify_pred)(args[1], args[2], args[3],
args[4], args[5], x, y);
default:
MR_fatal_error("unify/2: type arity > 5 not supported");
}
}
void MR_CALL
mercury__builtin__compare_3_p_0(MR_Mercury_Type_Info ti,
MR_Comparison_Result *res, MR_Box x, MR_Box y)
{
MR_TypeInfo type_info;
MR_TypeCtorInfo type_ctor_info;
MR_TypeCtorRep type_ctor_rep;
int arity;
MR_TypeInfoParams params;
MR_Mercury_Type_Info *args;
MR_ProcAddr compare_pred;
type_info = (MR_TypeInfo) ti;
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
// Tuple and higher-order types do not have a fixed arity,
// so they need to be special cased here.
type_ctor_rep = MR_type_ctor_rep(type_ctor_info);
if (type_ctor_rep == MR_TYPECTOR_REP_TUPLE) {
if (MR_special_pred_hooks.MR_compare_tuple_pred != NULL) {
MR_special_pred_hooks.MR_compare_tuple_pred(ti, res,
(MR_Word) x, (MR_Word) y);
return;
}
} else if (type_ctor_rep == MR_TYPECTOR_REP_PRED) {
mercury__builtin____Compare____pred_0_0(res, (MR_Pred) x, (MR_Pred) y);
return;
} else if (type_ctor_rep == MR_TYPECTOR_REP_FUNC) {
mercury__builtin____Compare____pred_0_0(res, (MR_Pred) x, (MR_Pred) y);
return;
}
arity = type_ctor_info->MR_type_ctor_arity;
params = MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info);
args = (MR_Mercury_Type_Info *) params;
compare_pred = type_ctor_info->MR_type_ctor_compare_pred;
// Cast compare_pre to the right type and then call it,
// passing the right number of type_info arguments.
switch (arity) {
case 0:
((MR_CompareFunc_0 *) compare_pred)(res, x, y);
break;
case 1:
((MR_CompareFunc_1 *) compare_pred)(args[1], res, x, y);
break;
case 2:
((MR_CompareFunc_2 *) compare_pred)(args[1], args[2], res, x, y);
break;
case 3:
((MR_CompareFunc_3 *) compare_pred)(args[1], args[2], args[3],
res, x, y);
break;
case 4:
((MR_CompareFunc_4 *) compare_pred)(args[1], args[2], args[3],
args[4], res, x, y);
break;
case 5:
((MR_CompareFunc_5 *) compare_pred)(args[1], args[2], args[3],
args[4], args[5], res, x, y);
break;
default:
MR_fatal_error("compare/3: type arity > 5 not supported");
}
}
void
MR_untrail_to(MR_TrailEntry *old_trail_ptr, MR_untrail_reason reason)
{
MR_TrailEntry *tr_ptr;
MR_TrailEntry *tr_base;
/* Not needed, since MR_trail_ptr is never a real reg: */
/* MR_restore_transient_registers(); */
tr_ptr = MR_trail_ptr;
switch (reason) {
case MR_solve:
case MR_commit:
/* Just handle the function trail entries */
tr_base = MR_TRAIL_BASE;
while (tr_ptr != old_trail_ptr) {
tr_ptr--;
if (MR_get_trail_entry_kind(tr_ptr) == MR_func_entry) {
(*MR_get_trail_entry_untrail_func(tr_ptr))(
MR_get_trail_entry_datum(tr_ptr), reason);
}
/*
** When we are using trail segments it is possible that
** `old_trail_ptr' is not a location on the current trail segment.
** We need to walk backwards through all the previous segments
** (invoking function trail entries as we go) until we find it.
*/
#if defined(MR_TRAIL_SEGMENTS)
if (tr_ptr == tr_base
&& tr_ptr != old_trail_ptr)
{
MR_MemoryZones *prev_zones;
MR_MemoryZone *zone;
prev_zones = MR_PREV_TRAIL_ZONES;
zone = prev_zones->MR_zones_head;
tr_ptr = (MR_TrailEntry *) zone->MR_zone_end;
while (tr_ptr != old_trail_ptr) {
tr_ptr--;
if (MR_get_trail_entry_kind(tr_ptr) == MR_func_entry) {
(*MR_get_trail_entry_untrail_func(tr_ptr))(
MR_get_trail_entry_datum(tr_ptr), reason);
}
if (tr_ptr == (MR_TrailEntry *) zone->MR_zone_min
&& tr_ptr != old_trail_ptr)
{
prev_zones = prev_zones->MR_zones_tail;
zone = prev_zones->MR_zones_head;
tr_ptr = (MR_TrailEntry *) zone->MR_zone_end;
}
}
break;
}
#endif
}
/*
** NB. We do _not_ reset the trail pointer here. Doing so would be
** unsafe, for `mdi' modes, because we may still need to restore
** the value if/when we backtrack to a choicepoint prior to the one
** we're cutting away.
*/
break;
case MR_undo:
case MR_exception:
case MR_retry:
/* Handle both function and value trail entries */
tr_base = MR_TRAIL_BASE;
while (tr_ptr != old_trail_ptr) {
tr_ptr--;
if (MR_get_trail_entry_kind(tr_ptr) == MR_func_entry) {
(*MR_get_trail_entry_untrail_func(tr_ptr))(
MR_get_trail_entry_datum(tr_ptr), reason);
} else {
*MR_get_trail_entry_address(tr_ptr) =
MR_get_trail_entry_value(tr_ptr);
}
#if defined(MR_TRAIL_SEGMENTS)
if (tr_ptr == tr_base
&& tr_ptr != old_trail_ptr)
{
MR_pop_trail_segment();
tr_ptr = MR_trail_ptr;
tr_base = MR_TRAIL_BASE;
}
#endif
}
MR_trail_ptr = tr_ptr;
/* Not needed, since MR_trail_ptr is never a real reg: */
/* MR_save_transient_registers(); */
break;
default:
MR_fatal_error("unknown MR_untrail_reason");
}
}
void
MR_agc_dump_stack_frames(MR_Internal *label, MR_MemoryZone *heap_zone,
MR_Word *stack_pointer, MR_Word *current_frame)
{
MR_Word saved_regs[MR_MAX_FAKE_REG];
int i;
int short_var_count;
int long_var_count;
MR_Word *type_params;
MR_TypeInfo type_info;
MR_Word value;
const MR_ProcLayout *entry_layout;
const MR_LabelLayout *layout;
const MR_Code *success_ip;
MR_bool top_frame;
layout = label->MR_internal_layout;
success_ip = label->MR_internal_addr;
entry_layout = layout->MR_sll_entry;
// For each stack frame...
top_frame = MR_TRUE;
while (MR_DETISM_DET_STACK(entry_layout->MR_sle_detism)) {
if (label->MR_internal_name != NULL) {
fprintf(stderr, " label: %s\n", label->MR_internal_name);
} else {
fprintf(stderr, " label: %p\n", label->MR_internal_addr);
}
if (success_ip == MR_stack_trace_bottom_ip) {
break;
}
MR_dump_live_variables(layout, heap_zone, top_frame,
stack_pointer, current_frame);
// Move to the next stack frame.
{
MR_LongLval location;
MR_LongLvalType type;
int number;
location = entry_layout->MR_sle_succip_locn;
type = MR_LONG_LVAL_TYPE(location);
number = MR_LONG_LVAL_NUMBER(location);
if (type != MR_LONG_LVAL_TYPE_STACKVAR) {
MR_fatal_error("can only handle stackvars");
}
success_ip = (MR_Code *) MR_based_stackvar(stack_pointer, number);
stack_pointer = stack_pointer - entry_layout->MR_sle_stack_slots;
label = MR_lookup_internal_by_addr(success_ip);
}
top_frame = MR_FALSE;
layout = label->MR_internal_layout;
if (layout != NULL) {
entry_layout = layout->MR_sll_entry;
}
}
}
static unsigned
MR_trace_write_label_exec_counts_for_file(FILE *fp,
const MR_ModuleLayout *module, const MR_ModuleFileLayout *file,
const char *module_name, MR_bool coverage_test)
{
const MR_LabelLayout *label;
const MR_ProcLayout *prev_proc;
const MR_ProcLayout *proc;
const MR_UserProcId *id;
MR_TracePort port;
int num_labels;
int label_num;
int label_index;
unsigned num_written;
MR_Unsigned exec_count;
MR_PathPort path_port;
fputs("file ", fp);
MR_trace_write_quoted_atom(fp, file->MR_mfl_filename);
fputc('\n', fp);
prev_proc = NULL;
num_labels = file->MR_mfl_label_count;
num_written = 0;
for (label_num = 0; label_num < num_labels; label_num++) {
label = file->MR_mfl_label_layout[label_num];
proc = label->MR_sll_entry;
label_index = label->MR_sll_label_num_in_module;
exec_count = module->MR_ml_label_exec_count[label_index];
if (! MR_PROC_LAYOUT_IS_UCI(proc) && label_index > 0 &&
(exec_count > 0 || coverage_test))
{
num_written++;
id = &proc->MR_sle_user;
if (proc != prev_proc) {
if (MR_strdiff(module_name, id->MR_user_def_module)) {
MR_fatal_error(
"MR_trace_write_label_exec_counts_for_file: "
"module name mismatch");
}
if (id->MR_user_pred_or_func == MR_PREDICATE) {
fputs("pproc", fp);
} else {
fputs("fproc", fp);
}
if (MR_strdiff(module_name, id->MR_user_decl_module)) {
/* turn pproc/fproc into pprocdecl/fprocdecl */
fputs("decl ", fp);
MR_trace_write_quoted_atom(fp, id->MR_user_decl_module);
}
fputc(' ', fp);
MR_trace_write_quoted_atom(fp, id->MR_user_name);
fprintf(fp, " %d %d\n", id->MR_user_arity, id->MR_user_mode);
}
port = label->MR_sll_port;
path_port = MR_named_count_port[port];
switch (path_port) {
case PORT_ONLY:
fputs(MR_actual_port_names[port], fp);
break;
case PATH_ONLY:
putc('<', fp);
fputs(MR_label_goal_path(label), fp);
putc('>', fp);
break;
case PORT_AND_PATH:
fputs(MR_actual_port_names[port], fp);
putc(' ', fp);
putc('<', fp);
fputs(MR_label_goal_path(label), fp);
putc('>', fp);
break;
default:
MR_fatal_error(
"MR_trace_write_label_exec_counts_for_file: "
"bad path_port");
break;
}
putc(' ', fp);
fprintf(fp, "%d", file->MR_mfl_label_lineno[label_num]);
if (exec_count > 0) {
putc(' ', fp);
fprintf(fp, "%" MR_INTEGER_LENGTH_MODIFIER "u", exec_count);
}
putc('\n', fp);
prev_proc = proc;
}
}
return num_written;
}
void
MR_trace_record_label_exec_counts(void *dummy)
{
FILE *fp;
char *name;
unsigned name_len;
MR_bool summarize;
MR_bool keep;
char *slash;
const char *program_name;
program_name = MR_copy_string(MR_progname);
slash = strrchr(program_name, '/');
if (slash != NULL) {
program_name = slash + 1;
}
summarize = MR_FALSE;
keep = MR_FALSE;
if (MR_trace_count_summary_file != NULL) {
if (MR_FILE_EXISTS(MR_trace_count_summary_file)) {
int i;
/* 30 bytes must be enough for the dot, the value of i, and '\0' */
name_len = strlen(MR_trace_count_summary_file) + 30;
name = MR_malloc(name_len);
fp = NULL;
/* search for a suffix that doesn't exist yet */
for (i = 1; i <= MR_trace_count_summary_max; i++) {
snprintf(name, name_len, "%s.%d",
MR_trace_count_summary_file, i);
if (! MR_FILE_EXISTS(name)) {
/* file doesn't exist, commit to this one */
if (i == MR_trace_count_summary_max) {
summarize = MR_TRUE;
}
break;
}
}
} else {
/*
** The summary file doesn't yet exist, create it.
*/
name = MR_copy_string(MR_trace_count_summary_file);
}
} else if (MR_trace_counts_file) {
name = MR_copy_string(MR_trace_counts_file);
keep = MR_TRUE;
} else {
char *s;
/*
** If no trace counts file name is provided, then we generate
** a file name.
*/
/* 100 bytes must be enough for the process id, dots and '\0' */
name_len = strlen(MERCURY_TRACE_COUNTS_PREFIX) + strlen(program_name)
+ 100;
name = MR_malloc(name_len);
snprintf(name, name_len, ".%s.%s.%d", MERCURY_TRACE_COUNTS_PREFIX,
program_name, getpid());
/* make sure name is an acceptable filename */
for (s = name; *s != '\0'; s++) {
if (*s == '/') {
*s = '_';
}
}
}
fp = fopen(name, "w");
if (fp != NULL) {
unsigned num_written;
num_written = MR_trace_write_label_exec_counts(fp,
program_name, MR_coverage_test_enabled);
(void) fclose(fp);
if (num_written == 0 && !keep) {
/*
** We did not write out any trace counts, so there is nothing
** to gather.
*/
(void) unlink(name);
summarize = MR_FALSE;
}
} else {
fprintf(stderr, "%s: %s\n", name, strerror(errno));
/*
** You can't summarize a file list if you can't create
** one of its files.
*/
summarize = MR_FALSE;
}
free(name);
if (summarize) {
char *cmd;
unsigned cmd_len;
int summary_status;
int mv_status;
int unlink_status;
int i;
const char *old_options;
/* 30 bytes must be enough for the dot, the value of i, and space */
name_len = strlen(MR_trace_count_summary_file) + 30;
name = MR_malloc(name_len);
cmd_len = strlen(MR_trace_count_summary_cmd) + 4;
cmd_len += strlen(MR_trace_count_summary_file)
+ strlen(TEMP_SUFFIX) + 1;
cmd_len += (MR_trace_count_summary_max + 1) * name_len;
cmd_len += 100;
cmd = MR_malloc(cmd_len);
strcpy(cmd, MR_trace_count_summary_cmd);
strcat(cmd, " -o ");
strcat(cmd, MR_trace_count_summary_file);
strcat(cmd, TEMP_SUFFIX);
strcat(cmd, " ");
strcat(cmd, MR_trace_count_summary_file);
for (i = 1; i <= MR_trace_count_summary_max; i++) {
snprintf(name, name_len, "%s.%d", MR_trace_count_summary_file, i);
strcat(cmd, " ");
strcat(cmd, name);
}
strcat(cmd, " > /dev/null 2>&1");
old_options = getenv("MERCURY_OPTIONS");
if (old_options != NULL) {
(void) MR_setenv("MERCURY_OPTIONS", "", MR_TRUE);
summary_status = system(cmd);
(void) MR_setenv("MERCURY_OPTIONS", old_options, MR_TRUE);
} else {
summary_status = system(cmd);
}
if (summary_status == 0) {
strcpy(cmd, "mv ");
strcat(cmd, MR_trace_count_summary_file);
strcat(cmd, TEMP_SUFFIX);
strcat(cmd, " ");
strcat(cmd, MR_trace_count_summary_file);
mv_status = system(cmd);
if (mv_status == 0) {
/* delete all files whose data is now in the summary file */
for (i = 1; i <= MR_trace_count_summary_max; i++) {
snprintf(name, name_len, "%s.%d",
MR_trace_count_summary_file, i);
unlink_status = unlink(name);
if (unlink_status != 0) {
MR_fatal_error(
"couldn't create summary of trace data");
}
}
} else {
MR_fatal_error("couldn't create summary of trace data");
}
} else {
MR_fatal_error("couldn't create summary of trace data");
}
free(name);
free(cmd);
}
}
int
MR_get_num_functors(MR_TypeInfo type_info)
{
MR_TypeCtorInfo type_ctor_info;
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
if (! MR_type_ctor_has_valid_rep(type_ctor_info)) {
MR_fatal_error("MR_get_num_functors: term of unknown representation");
}
switch (MR_type_ctor_rep(type_ctor_info)) {
case MR_TYPECTOR_REP_DU:
case MR_TYPECTOR_REP_DU_USEREQ:
case MR_TYPECTOR_REP_RESERVED_ADDR:
case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
case MR_TYPECTOR_REP_ENUM:
case MR_TYPECTOR_REP_ENUM_USEREQ:
case MR_TYPECTOR_REP_DUMMY:
case MR_TYPECTOR_REP_FOREIGN_ENUM:
case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
return MR_type_ctor_num_functors(type_ctor_info);
case MR_TYPECTOR_REP_NOTAG:
case MR_TYPECTOR_REP_NOTAG_USEREQ:
case MR_TYPECTOR_REP_NOTAG_GROUND:
case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
case MR_TYPECTOR_REP_TUPLE:
return 1;
case MR_TYPECTOR_REP_EQUIV_GROUND:
case MR_TYPECTOR_REP_EQUIV:
return MR_get_num_functors(
MR_create_type_info((MR_TypeInfo *) type_info,
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv));
case MR_TYPECTOR_REP_INT:
case MR_TYPECTOR_REP_UINT:
case MR_TYPECTOR_REP_CHAR:
case MR_TYPECTOR_REP_FLOAT:
case MR_TYPECTOR_REP_STRING:
case MR_TYPECTOR_REP_BITMAP:
case MR_TYPECTOR_REP_FUNC:
case MR_TYPECTOR_REP_PRED:
case MR_TYPECTOR_REP_SUBGOAL:
case MR_TYPECTOR_REP_VOID:
case MR_TYPECTOR_REP_C_POINTER:
case MR_TYPECTOR_REP_STABLE_C_POINTER:
case MR_TYPECTOR_REP_TYPEINFO:
case MR_TYPECTOR_REP_TYPECTORINFO:
case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
case MR_TYPECTOR_REP_TYPEDESC:
case MR_TYPECTOR_REP_TYPECTORDESC:
case MR_TYPECTOR_REP_TYPECLASSINFO:
case MR_TYPECTOR_REP_BASETYPECLASSINFO:
case MR_TYPECTOR_REP_ARRAY:
case MR_TYPECTOR_REP_SUCCIP:
case MR_TYPECTOR_REP_HP:
case MR_TYPECTOR_REP_CURFR:
case MR_TYPECTOR_REP_MAXFR:
case MR_TYPECTOR_REP_REDOFR:
case MR_TYPECTOR_REP_REDOIP:
case MR_TYPECTOR_REP_TRAIL_PTR:
case MR_TYPECTOR_REP_TICKET:
case MR_TYPECTOR_REP_FOREIGN:
case MR_TYPECTOR_REP_STABLE_FOREIGN:
case MR_TYPECTOR_REP_REFERENCE:
return -1;
case MR_TYPECTOR_REP_UNKNOWN:
MR_fatal_error("MR_get_num_functors: unknown type_ctor_rep");
}
MR_fatal_error("MR_get_num_functors: unexpected fallthrough");
}
static int
MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
MR_Construct_Info *construct_info)
{
MR_TypeCtorInfo type_ctor_info;
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
construct_info->type_ctor_rep = MR_type_ctor_rep(type_ctor_info);
if (! MR_type_ctor_has_valid_rep(type_ctor_info)) {
MR_fatal_error("MR_get_functor_info: term of unknown representation");
}
switch (MR_type_ctor_rep(type_ctor_info)) {
case MR_TYPECTOR_REP_RESERVED_ADDR:
case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
case MR_TYPECTOR_REP_DU:
case MR_TYPECTOR_REP_DU_USEREQ:
{
const MR_DuFunctorDesc *functor_desc;
if (functor_number < 0 ||
functor_number >= MR_type_ctor_num_functors(type_ctor_info))
{
MR_fatal_error("MR_get_functor_info: "
"du functor_number out of range");
}
functor_desc = MR_type_ctor_functors(type_ctor_info).
MR_functors_du[functor_number];
construct_info->functor_info.du_functor_desc = functor_desc;
construct_info->functor_name = functor_desc->MR_du_functor_name;
construct_info->arity = functor_desc->MR_du_functor_orig_arity;
construct_info->arg_pseudo_type_infos =
functor_desc->MR_du_functor_arg_types;
construct_info->arg_names =
functor_desc->MR_du_functor_arg_names;
}
return MR_TRUE;
case MR_TYPECTOR_REP_ENUM:
case MR_TYPECTOR_REP_ENUM_USEREQ:
case MR_TYPECTOR_REP_DUMMY:
{
const MR_EnumFunctorDesc *functor_desc;
if (functor_number < 0 ||
functor_number >= MR_type_ctor_num_functors(type_ctor_info))
{
MR_fatal_error("MR_get_functor_info: "
"enum functor_number out of range");
}
functor_desc = MR_type_ctor_functors(type_ctor_info).
MR_functors_enum[functor_number];
construct_info->functor_info.enum_functor_desc = functor_desc;
construct_info->functor_name = functor_desc->MR_enum_functor_name;
construct_info->arity = 0;
construct_info->arg_pseudo_type_infos = NULL;
construct_info->arg_names = NULL;
}
return MR_TRUE;
case MR_TYPECTOR_REP_FOREIGN_ENUM:
case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
{
const MR_ForeignEnumFunctorDesc *functor_desc;
if (functor_number < 0 ||
functor_number >= MR_type_ctor_num_functors(type_ctor_info))
{
MR_fatal_error("MR_get_functor_info: "
"foreign enum functor_number out of range");
}
functor_desc = MR_type_ctor_functors(type_ctor_info).
MR_functors_foreign_enum[functor_number];
construct_info->functor_info.foreign_enum_functor_desc
= functor_desc;
construct_info->functor_name =
functor_desc->MR_foreign_enum_functor_name;
construct_info->arity = 0;
construct_info->arg_pseudo_type_infos = NULL;
construct_info->arg_names = NULL;
}
return MR_TRUE;
case MR_TYPECTOR_REP_NOTAG:
case MR_TYPECTOR_REP_NOTAG_USEREQ:
case MR_TYPECTOR_REP_NOTAG_GROUND:
case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
{
const MR_NotagFunctorDesc *functor_desc;
if (functor_number != 0) {
MR_fatal_error("MR_get_functor_info: "
"notag functor_number out of range");
}
functor_desc = MR_type_ctor_functors(type_ctor_info).
MR_functors_notag;
construct_info->functor_info.notag_functor_desc = functor_desc;
construct_info->functor_name = functor_desc->MR_notag_functor_name;
construct_info->arity = 1;
construct_info->arg_pseudo_type_infos =
&functor_desc->MR_notag_functor_arg_type;
construct_info->arg_names =
&functor_desc->MR_notag_functor_arg_name;
}
return MR_TRUE;
case MR_TYPECTOR_REP_EQUIV_GROUND:
case MR_TYPECTOR_REP_EQUIV:
return MR_get_functor_info(
MR_create_type_info(
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv),
functor_number, construct_info);
case MR_TYPECTOR_REP_TUPLE:
construct_info->functor_name = "{}";
construct_info->arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
// Tuple types don't have pseudo-type_infos for the functors.
construct_info->arg_pseudo_type_infos = NULL;
construct_info->arg_names = NULL;
return MR_TRUE;
case MR_TYPECTOR_REP_INT:
case MR_TYPECTOR_REP_UINT:
case MR_TYPECTOR_REP_CHAR:
case MR_TYPECTOR_REP_FLOAT:
case MR_TYPECTOR_REP_STRING:
case MR_TYPECTOR_REP_BITMAP:
case MR_TYPECTOR_REP_FUNC:
case MR_TYPECTOR_REP_PRED:
case MR_TYPECTOR_REP_SUBGOAL:
case MR_TYPECTOR_REP_VOID:
case MR_TYPECTOR_REP_C_POINTER:
case MR_TYPECTOR_REP_STABLE_C_POINTER:
case MR_TYPECTOR_REP_TYPEINFO:
case MR_TYPECTOR_REP_TYPECTORINFO:
case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
case MR_TYPECTOR_REP_TYPEDESC:
case MR_TYPECTOR_REP_TYPECTORDESC:
case MR_TYPECTOR_REP_TYPECLASSINFO:
case MR_TYPECTOR_REP_BASETYPECLASSINFO:
case MR_TYPECTOR_REP_ARRAY:
case MR_TYPECTOR_REP_SUCCIP:
case MR_TYPECTOR_REP_HP:
case MR_TYPECTOR_REP_CURFR:
case MR_TYPECTOR_REP_MAXFR:
case MR_TYPECTOR_REP_REDOFR:
case MR_TYPECTOR_REP_REDOIP:
case MR_TYPECTOR_REP_TRAIL_PTR:
case MR_TYPECTOR_REP_TICKET:
case MR_TYPECTOR_REP_FOREIGN:
case MR_TYPECTOR_REP_STABLE_FOREIGN:
case MR_TYPECTOR_REP_REFERENCE:
return MR_FALSE;
case MR_TYPECTOR_REP_UNKNOWN:
MR_fatal_error("MR_get_functor_info: unknown type_ctor_rep");
}
MR_fatal_error("MR_get_functor_info: unexpected fallthrough");
}
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;
}
}
void
MR_io_tabling_stats(FILE *fp)
{
const MR_TableIoDecl *table_io_decl;
const MR_ProcLayout *proc_layout;
MR_ConstString proc_name;
int arity;
MR_Word is_func;
int hv;
MR_TrieNode answer_block_trie;
MR_Word *answer_block;
MR_Hash_Table hash_table;
MR_IO_Table_Stats_Hash_Record *hash_record;
MR_IO_Table_Stats_Hash_Record *record;
int num_entries;
int count;
int i;
/*
** Create a fresh new hash table, separate the table created by
** any previous call to this function. We can't use structure assignment,
** as that causes gcc 3.2 to throw a fit.
*/
hash_table.MR_ht_size = MR_io_tabling_stats_table.MR_ht_size;
hash_table.MR_ht_store = NULL;
hash_table.MR_ht_key = MR_io_tabling_stats_table.MR_ht_key;
hash_table.MR_ht_hash = MR_io_tabling_stats_table.MR_ht_hash;
hash_table.MR_ht_equal = MR_io_tabling_stats_table.MR_ht_equal;
MR_init_hash_table(hash_table);
num_entries = 0;
for (i = MR_io_tabling_start; i < MR_io_tabling_counter_hwm; i++) {
MR_TABLE_START_INT(NULL, MR_FALSE, MR_FALSE, answer_block_trie,
(MR_TrieNode) &MR_io_tabling_pointer, MR_io_tabling_start, i);
answer_block = answer_block_trie->MR_answerblock;
if (answer_block == NULL) {
continue;
}
table_io_decl = (const MR_TableIoDecl *) answer_block[0];
proc_layout = table_io_decl->MR_table_io_decl_proc;
hash_record = MR_lookup_hash_table(hash_table, proc_layout);
if (hash_record == NULL) {
hash_record = MR_GC_NEW(MR_IO_Table_Stats_Hash_Record);
hash_record->MR_io_tabling_stats_proc = proc_layout;
hash_record->MR_io_tabling_stats_count = 1;
(void) MR_insert_hash_table(hash_table, hash_record);
num_entries++;
} else {
hash_record->MR_io_tabling_stats_count++;
}
}
MR_io_tabling_stats_sort_arena =
MR_GC_NEW_ARRAY(MR_IO_Table_Stats_Hash_Record, num_entries);
MR_io_tabling_stats_sort_arena_next = 0;
MR_process_all_entries(hash_table, MR_add_to_sort_arena);
if (MR_io_tabling_stats_sort_arena_next != num_entries) {
MR_fatal_error("MR_io_tabling_stats: num_entries mismatch");
}
qsort(MR_io_tabling_stats_sort_arena, num_entries,
sizeof(MR_IO_Table_Stats_Hash_Record), MR_compare_in_sort_arena);
for (i = 0; i < num_entries; i++) {
record = &MR_io_tabling_stats_sort_arena[i];
proc_layout = record->MR_io_tabling_stats_proc;
count = record->MR_io_tabling_stats_count;
MR_generate_proc_name_from_layout(proc_layout, &proc_name, &arity,
&is_func);
fprintf(fp, "%8d %4s %s/%d\n", count, (is_func ? "func" : "pred"),
proc_name, arity);
}
}
MR_Next
MR_trace_cmd_table_io(char **words, int word_count, MR_TraceCmdInfo *cmd,
MR_EventInfo *event_info, MR_Code **jumpaddr)
{
if (word_count == 1) {
if (! MR_io_tabling_allowed) {
fprintf(MR_mdb_err,
"This executable wasn't prepared for I/O tabling.\n");
return KEEP_INTERACTING;
}
if (MR_io_tabling_phase == MR_IO_TABLING_BEFORE) {
fprintf(MR_mdb_out, "I/O tabling has not yet started.\n");
} else if (MR_io_tabling_phase == MR_IO_TABLING_DURING) {
fprintf(MR_mdb_out, "I/O tabling has started.\n");
} else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER) {
fprintf(MR_mdb_out, "I/O tabling has stopped.\n");
} else {
MR_fatal_error("I/O tabling in impossible phase.\n");
}
} else if (word_count == 2 &&
(MR_streq(words[1], "start") || MR_streq(words[1], "begin")))
{
if (! MR_io_tabling_allowed) {
fprintf(MR_mdb_err,
"This executable wasn't prepared for I/O tabling.\n");
return KEEP_INTERACTING;
}
if (MR_io_tabling_phase == MR_IO_TABLING_BEFORE) {
MR_io_tabling_phase = MR_IO_TABLING_DURING;
MR_io_tabling_start = MR_io_tabling_counter;
MR_io_tabling_end = MR_IO_ACTION_MAX;
MR_io_tabling_start_event_num = event_info->MR_event_number;
#ifdef MR_DEBUG_RETRY
MR_io_tabling_debug = MR_TRUE;
#endif
fprintf(MR_mdb_out, "I/O tabling started.\n");
} else if (MR_io_tabling_phase == MR_IO_TABLING_DURING) {
fprintf(MR_mdb_out, "I/O tabling has already started.\n");
} else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER) {
fprintf(MR_mdb_out, "I/O tabling has already stopped.\n");
} else {
MR_fatal_error("I/O tabling in impossible phase.\n");
}
} else if (word_count == 2 &&
(MR_streq(words[1], "stop") || MR_streq(words[1], "end")))
{
if (! MR_io_tabling_allowed) {
fprintf(MR_mdb_err,
"This executable wasn't prepared for I/O tabling.\n");
return KEEP_INTERACTING;
}
if (MR_io_tabling_phase == MR_IO_TABLING_BEFORE) {
fprintf(MR_mdb_out, "I/O tabling has not yet started.\n");
} else if (MR_io_tabling_phase == MR_IO_TABLING_DURING) {
MR_io_tabling_phase = MR_IO_TABLING_AFTER;
MR_io_tabling_end = MR_io_tabling_counter_hwm;
MR_io_tabling_stop_event_num = event_info->MR_event_number;
fprintf(MR_mdb_out, "I/O tabling stopped.\n");
} else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER) {
fprintf(MR_mdb_out, "I/O tabling has already stopped.\n");
} else {
MR_fatal_error("I/O tabling in impossible phase.\n");
}
} else if (word_count == 2 && MR_streq(words[1], "stats")) {
if (! MR_io_tabling_allowed) {
fprintf(MR_mdb_err,
"This executable wasn't prepared for I/O tabling.\n");
return KEEP_INTERACTING;
}
fprintf(MR_mdb_out, "phase = %d\n", MR_io_tabling_phase);
MR_print_unsigned_var(MR_mdb_out, "counter", MR_io_tabling_counter);
MR_print_unsigned_var(MR_mdb_out, "hwm", MR_io_tabling_counter_hwm);
MR_print_unsigned_var(MR_mdb_out, "start", MR_io_tabling_start);
MR_print_unsigned_var(MR_mdb_out, "end", MR_io_tabling_end);
} else if (word_count == 2 && MR_streq(words[1], "allow")) {
/*
** The "table_io allow" command allows the programmer to give
** the command "table_io start" even in grades in which there
** is no guarantee that all I/O primitives are tabled. It is
** for developers only, because if it is used on programs in
** which some but not all I/O primitives are tabled, the
** results of turning on I/O tabling can be weird.
*/
MR_io_tabling_allowed = MR_TRUE;
} else {
MR_trace_usage_cur_cmd();
}
return KEEP_INTERACTING;
}
MR_Next
MR_trace_cmd_retry(char **words, int word_count, MR_TraceCmdInfo *cmd,
MR_EventInfo *event_info, MR_Code **jumpaddr)
{
MR_Level n;
MR_Level ancestor_level;
MR_RetryAcrossIo across_io;
const char *problem;
MR_RetryResult result;
MR_bool assume_all_io_is_tabled;
MR_bool unsafe_retry;
ancestor_level = 0;
across_io = MR_RETRY_IO_INTERACTIVE;
assume_all_io_is_tabled = MR_FALSE;
if (! MR_trace_options_retry(&across_io, &assume_all_io_is_tabled,
&words, &word_count))
{
; /* the usage message has already been printed */
} else if (word_count == 2 &&
( MR_streq(words[1], "clique") || MR_streq(words[1], "clentry")))
{
if (MR_find_clique_entry_mdb(event_info, MR_CLIQUE_ENTRY_FRAME,
&ancestor_level))
{
/* the error message has already been printed */
return KEEP_INTERACTING;
}
} else if (word_count == 2 && MR_streq(words[1], "clparent")) {
if (MR_find_clique_entry_mdb(event_info, MR_CLIQUE_ENTRY_PARENT_FRAME,
&ancestor_level))
{
/* the error message has already been printed */
return KEEP_INTERACTING;
}
} else if (word_count == 2 && MR_trace_is_natural_number(words[1], &n)) {
ancestor_level = n;
} else if (word_count == 1) {
ancestor_level = 0;
} else {
MR_trace_usage_cur_cmd();
return KEEP_INTERACTING;
}
if (ancestor_level == 0 && MR_port_is_entry(event_info->MR_trace_port)) {
MR_trace_do_noop();
return KEEP_INTERACTING;
}
result = MR_trace_retry(event_info, ancestor_level,
across_io, assume_all_io_is_tabled, MR_UNTABLED_IO_RETRY_MESSAGE,
&unsafe_retry, &problem, MR_mdb_in, MR_mdb_out, jumpaddr);
switch (result) {
case MR_RETRY_OK_DIRECT:
cmd->MR_trace_cmd = MR_CMD_GOTO;
cmd->MR_trace_stop_event = MR_trace_event_number + 1;
cmd->MR_trace_strict = MR_FALSE;
cmd->MR_trace_print_level = MR_default_print_level;
return STOP_INTERACTING;
case MR_RETRY_OK_FINISH_FIRST:
cmd->MR_trace_cmd = MR_CMD_FINISH;
cmd->MR_trace_stop_depth = event_info->MR_call_depth - ancestor_level;
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_PRINT_LEVEL_NONE;
/* Arrange to retry the call once it is finished. */
/* XXX we should use the same options as the original retry */
MR_insert_command_line_at_head("retry -o");
return STOP_INTERACTING;
case MR_RETRY_OK_FAIL_FIRST:
cmd->MR_trace_cmd = MR_CMD_FAIL;
cmd->MR_trace_stop_depth = event_info->MR_call_depth - ancestor_level;
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_PRINT_LEVEL_NONE;
/* Arrange to retry the call once it is finished. */
/* XXX we should use the same options as the original retry */
MR_insert_command_line_at_head("retry -o");
return STOP_INTERACTING;
case MR_RETRY_ERROR:
fflush(MR_mdb_out);
fprintf(MR_mdb_err, "%s\n", problem);
return KEEP_INTERACTING;
}
MR_fatal_error("unrecognized retry result");
}
MR_ConstString
MR_name_in_string_table(const char *string_table, MR_Integer string_table_size,
MR_uint_least32_t name_code, int *should_copy)
{
/*
** The encoding decoded here is create by lookup_string_in_table
** in compiler/stack_layout.m. The code here and there must be kept
** in sync.
*/
if ((name_code & 0x1) != 0) {
static char buf[MR_MAX_VARNAME_SIZE];
int kind;
int n;
int offset;
name_code >>= 1;
kind = name_code & 0x1f;
name_code >>= 5;
n = name_code & 0x3ff;
offset = name_code >> 10;
switch (kind) {
case 0:
if (n == 0) {
#ifdef MR_HAVE_SNPRINTF
snprintf(buf, MR_MAX_VARNAME_SIZE, "STATE_VARIABLE_%s",
string_table + offset);
#else
sprintf(buf, "STATE_VARIABLE_%s",
string_table + offset);
#endif
} else {
#ifdef MR_HAVE_SNPRINTF
snprintf(buf, MR_MAX_VARNAME_SIZE, "STATE_VARIABLE_%s_%d",
string_table + offset, n - 1);
#else
sprintf(buf, "STATE_VARIABLE_%s_%d",
string_table + offset, n - 1);
#endif
}
break;
case 1:
#ifdef MR_HAVE_SNPRINTF
snprintf(buf, MR_MAX_VARNAME_SIZE, "TypeCtorInfo_%d", n);
#else
sprintf(buf, "TypeCtorInfo_%d", n);
#endif
break;
case 2:
#ifdef MR_HAVE_SNPRINTF
snprintf(buf, MR_MAX_VARNAME_SIZE, "TypeInfo_%d", n);
#else
sprintf(buf, "TypeInfo_%d", n);
#endif
break;
case 3:
#ifdef MR_HAVE_SNPRINTF
snprintf(buf, MR_MAX_VARNAME_SIZE, "BaseTypeClassInfo_for_%s",
string_table + offset);
#else
sprintf(buf, "BaseTypeClassInfo_for_%s",
string_table + offset);
#endif
break;
case 4:
#ifdef MR_HAVE_SNPRINTF
snprintf(buf, MR_MAX_VARNAME_SIZE, "TypeClassInfo_for_%s",
string_table + offset);
#else
sprintf(buf, "TypeClassInfo_for_%s",
string_table + offset);
#endif
break;
case 5:
#ifdef MR_HAVE_SNPRINTF
snprintf(buf, MR_MAX_VARNAME_SIZE, "PolyConst%d", n);
#else
sprintf(buf, "PolyConst%d", n);
#endif
break;
default:
MR_fatal_error("MR_hlds_var_name: unknown kind");
break;
}
if (should_copy != NULL) {
*should_copy = MR_TRUE;
}
return buf;
} else {
