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 {