MR_TypeInfo
MR_make_type(int arity, MR_TypeCtorDesc type_ctor_desc, MR_Word arg_types_list)
{
MR_TypeCtorInfo type_ctor_info;
MR_Word *new_type_info_arena;
MR_Word new_type_info_arena_word;
MR_TypeInfo *new_type_info_args;
int i;
// We need to treat variable-arity types as a special case here.
if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
type_ctor_info = MR_TYPECTOR_DESC_GET_VA_TYPE_CTOR_INFO(
type_ctor_desc);
MR_restore_transient_registers();
MR_offset_incr_hp_msg(new_type_info_arena_word, 0,
MR_var_arity_type_info_size(arity),
MR_ALLOC_SITE_TYPE_INFO, NULL);
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
MR_save_transient_registers();
MR_fill_in_var_arity_type_info(new_type_info_arena, type_ctor_info,
arity, new_type_info_args);
} else {
type_ctor_info =
MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(type_ctor_desc);
if (arity == 0) {
return (MR_TypeInfo) type_ctor_info;
}
MR_restore_transient_registers();
MR_offset_incr_hp_msg(new_type_info_arena_word, 0,
MR_fixed_arity_type_info_size(arity),
MR_ALLOC_SITE_TYPE_INFO, NULL);
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
MR_save_transient_registers();
MR_fill_in_fixed_arity_type_info(new_type_info_arena, type_ctor_info,
new_type_info_args);
}
for (i = 1; i <= arity; i++) {
new_type_info_args[i] = (MR_TypeInfo) MR_list_head(arg_types_list);
arg_types_list = MR_list_tail(arg_types_list);
}
return (MR_TypeInfo) new_type_info_arena;
}
MR_Word
MR_arg_name_vector_to_list(int arity, const MR_ConstString *arg_names)
{
MR_Word arg_names_list;
MR_restore_transient_registers();
arg_names_list = MR_list_empty();
if (arg_names == NULL) {
/* No arguments have names. */
while (arity > 0) {
--arity;
arg_names_list = MR_string_list_cons((MR_Word) NULL,
arg_names_list);
}
} else {
while (arity > 0) {
--arity;
arg_names_list = MR_string_list_cons((MR_Word) arg_names[arity],
arg_names_list);
}
}
MR_save_transient_registers();
return arg_names_list;
}
void
MR_copy_saved_regs_to_regs(int max_mr_num, MR_Word *saved_regs,
int max_f_num, MR_Float *saved_f_regs)
{
/*
** We execute the converse procedure to MR_copy_regs_to_saved_regs.
** The MR_save_transient_registers is there so that a call to the
** MR_restore_transient_registers macro after MR_trace will do the
** right thing.
*/
int i;
for (i = 0; i <= max_mr_num; i++) {
MR_fake_reg[i] = saved_regs[i];
}
#ifdef MR_BOXED_FLOAT
for (i = 0; i <= max_f_num; i++) {
MR_float_reg[i] = saved_f_regs[i];
}
#else
(void) max_f_num;
(void) saved_f_regs;
#endif
MR_restore_registers();
MR_save_transient_registers();
}
MR_Word
MR_pseudo_type_info_vector_to_pseudo_type_info_list(int arity,
MR_TypeInfoParams type_params,
const MR_PseudoTypeInfo *arg_pseudo_type_infos)
{
MR_PseudoTypeInfo pseudo;
MR_PseudoTypeInfo arg_pseudo_type_info;
MR_Word pseudo_type_info_list;
MR_restore_transient_registers();
pseudo_type_info_list = MR_list_empty();
while (--arity >= 0) {
/* Get the argument type_info */
pseudo = arg_pseudo_type_infos[arity];
if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo) &&
MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo))
{
arg_pseudo_type_info = pseudo;
} else {
MR_save_transient_registers();
arg_pseudo_type_info =
MR_create_pseudo_type_info(
(MR_PseudoTypeInfoParams) type_params, pseudo);
MR_restore_transient_registers();
MR_save_transient_registers();
arg_pseudo_type_info =
MR_collapse_equivalences_pseudo(arg_pseudo_type_info);
MR_restore_transient_registers();
}
pseudo_type_info_list = MR_pseudo_type_info_list_cons(
(MR_Word) arg_pseudo_type_info, pseudo_type_info_list);
}
MR_save_transient_registers();
return pseudo_type_info_list;
}
MR_Word
MR_type_params_vector_to_list(int arity, MR_TypeInfoParams type_params)
{
MR_TypeInfo arg_type;
MR_Word type_info_list;
MR_restore_transient_registers();
type_info_list = MR_list_empty();
while (arity > 0) {
type_info_list = MR_type_info_list_cons((MR_Word) type_params[arity],
type_info_list);
--arity;
}
MR_save_transient_registers();
return type_info_list;
}
MR_Word
MR_set_reg(int num, MR_Word val)
{
MR_restore_transient_registers();
switch (num) {
case 1: MR_r1 = val; MR_save_transient_registers(); return val;
case 2: MR_r2 = val; MR_save_transient_registers(); return val;
case 3: MR_r3 = val; MR_save_transient_registers(); return val;
case 4: MR_r4 = val; MR_save_transient_registers(); return val;
case 5: MR_r5 = val; MR_save_transient_registers(); return val;
case 6: MR_r6 = val; MR_save_transient_registers(); return val;
case 7: MR_r7 = val; MR_save_transient_registers(); return val;
case 8: MR_r8 = val; MR_save_transient_registers(); return val;
case 9: MR_r9 = val; MR_save_transient_registers(); return val;
case 10: MR_r10 = val; MR_save_transient_registers(); return val;
case 11: MR_r11 = val; MR_save_transient_registers(); return val;
case 12: MR_r12 = val; MR_save_transient_registers(); return val;
case 13: MR_r13 = val; MR_save_transient_registers(); return val;
case 14: MR_r14 = val; MR_save_transient_registers(); return val;
case 15: MR_r15 = val; MR_save_transient_registers(); return val;
case 16: MR_r16 = val; MR_save_transient_registers(); return val;
case 17: MR_r17 = val; MR_save_transient_registers(); return val;
case 18: MR_r18 = val; MR_save_transient_registers(); return val;
case 19: MR_r19 = val; MR_save_transient_registers(); return val;
case 20: MR_r20 = val; MR_save_transient_registers(); return val;
case 21: MR_r21 = val; MR_save_transient_registers(); return val;
case 22: MR_r22 = val; MR_save_transient_registers(); return val;
case 23: MR_r23 = val; MR_save_transient_registers(); return val;
case 24: MR_r24 = val; MR_save_transient_registers(); return val;
case 25: MR_r25 = val; MR_save_transient_registers(); return val;
case 26: MR_r26 = val; MR_save_transient_registers(); return val;
case 27: MR_r27 = val; MR_save_transient_registers(); return val;
case 28: MR_r28 = val; MR_save_transient_registers(); return val;
case 29: MR_r29 = val; MR_save_transient_registers(); return val;
case 30: MR_r30 = val; MR_save_transient_registers(); return val;
case 31: MR_r31 = val; MR_save_transient_registers(); return val;
case 32: MR_r32 = val; MR_save_transient_registers(); return val;
}
/* NOTREACHED */
fprintf(stderr, "register %d out of range in set_reg\n", num);
abort();
return 0;
}
