MR_PseudoTypeInfo MR_collapse_equivalences_pseudo(MR_PseudoTypeInfo maybe_equiv_pseudo_type_info) { MR_TypeCtorInfo type_ctor_info; if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(maybe_equiv_pseudo_type_info)) { return maybe_equiv_pseudo_type_info; } type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO( maybe_equiv_pseudo_type_info); /* Look past equivalences */ while (MR_type_ctor_rep(type_ctor_info) == MR_TYPECTOR_REP_EQUIV_GROUND || MR_type_ctor_rep(type_ctor_info) == MR_TYPECTOR_REP_EQUIV) { maybe_equiv_pseudo_type_info = MR_create_pseudo_type_info( MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR( maybe_equiv_pseudo_type_info), MR_type_ctor_layout(type_ctor_info).MR_layout_equiv); if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(maybe_equiv_pseudo_type_info)) { return maybe_equiv_pseudo_type_info; } type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO( maybe_equiv_pseudo_type_info); } return maybe_equiv_pseudo_type_info; }
MR_bool MR_pseudo_type_ctor_and_args(MR_PseudoTypeInfo pseudo_type_info, MR_bool collapse_equivalences, MR_TypeCtorDesc *type_ctor_desc_ptr, MR_Word *arg_type_info_list_ptr) { MR_TypeCtorInfo type_ctor_info; MR_TypeCtorDesc type_ctor_desc; MR_Integer arity; if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) { return MR_FALSE; } if (collapse_equivalences) { pseudo_type_info = MR_collapse_equivalences_pseudo(pseudo_type_info); } if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) { return MR_FALSE; } type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pseudo_type_info); type_ctor_desc = MR_make_type_ctor_desc_pseudo(pseudo_type_info, type_ctor_info); *type_ctor_desc_ptr = type_ctor_desc; if (MR_type_ctor_has_variable_arity(type_ctor_info)) { arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc); *arg_type_info_list_ptr = MR_pseudo_type_params_vector_to_list(arity, MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pseudo_type_info)); } else { arity = type_ctor_info->MR_type_ctor_arity; *arg_type_info_list_ptr = MR_pseudo_type_params_vector_to_list(arity, MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pseudo_type_info)); } return MR_TRUE; }
MR_bool MR_unify_pseudo_type_info_float(MR_PseudoTypeInfo pti) { MR_TypeCtorInfo tci1; MR_TypeCtorInfo tci2; if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti)) { return MR_FALSE; } tci1 = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pti); tci2 = (MR_TypeCtorInfo) MR_FLOAT_CTOR_ADDR; return MR_unify_type_ctor_info(tci1, tci2); }
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_bool MR_unify_pseudo_type_info(MR_PseudoTypeInfo pti1, MR_PseudoTypeInfo pti2) { MR_TypeCtorInfo tci1; MR_TypeCtorInfo tci2; MR_PseudoTypeInfo *arg_vector_1; MR_PseudoTypeInfo *arg_vector_2; int num_arg_types_1; int num_arg_types_2; int i; int comp; /* ** Try to optimize a common case: ** If type_info addresses are equal, they must represent the ** same type. */ if (pti1 == pti2) { return MR_TRUE; } /* ** Otherwise, we need to expand equivalence types, if any. */ pti1 = MR_collapse_equivalences_pseudo(pti1); pti2 = MR_collapse_equivalences_pseudo(pti2); /* ** Perhaps they are equal now... */ if (pti1 == pti2) { return MR_TRUE; } /* ** Handle the comparison if either pseudo_type_info is a variable. ** Any non-variable is greater than a variable. */ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti1) && MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti2)) { if ((MR_Integer) pti1 != (MR_Integer) pti2) { return MR_FALSE; } else { return MR_TRUE; } } if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti1)) { return MR_FALSE; } if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pti2)) { return MR_FALSE; } /* ** Otherwise find the type_ctor_infos, and compare those. */ tci1 = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pti1); tci2 = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pti2); if (! MR_unify_type_ctor_info(tci1, tci2)) { return MR_FALSE; } /* ** If the type_ctor_infos are equal, we don't need to compare ** the arity of the types - they must be the same - unless they are ** higher-order (which are all mapped to pred/0 or func/0) or tuples ** (which are all mapped to tuple/0), in which cases we must compare ** the arities before we can check the argument types. */ if (MR_type_ctor_has_variable_arity(tci1)) { num_arg_types_1 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pti1); num_arg_types_2 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pti2); /* Check arity */ if (num_arg_types_1 != num_arg_types_2) { return MR_FALSE; } arg_vector_1 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pti1); arg_vector_2 = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pti2); } else { num_arg_types_1 = tci1->MR_type_ctor_arity; arg_vector_1 = MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pti1); arg_vector_2 = MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pti2); } /* compare the argument types */ for (i = 1; i <= num_arg_types_1; i++) { if (! MR_unify_pseudo_type_info(arg_vector_1[i], arg_vector_2[i])) { return MR_FALSE; } } return MR_TRUE; }