diff --git a/compiler/builtin_lib_types.m b/compiler/builtin_lib_types.m index d4203495e..a13a7715b 100644 --- a/compiler/builtin_lib_types.m +++ b/compiler/builtin_lib_types.m @@ -45,6 +45,7 @@ :- func sample_typeclass_info_type = mer_type. :- func type_info_type = mer_type. :- func type_ctor_info_type = mer_type. +:- func typeclass_info_type = mer_type. :- func type_desc_type = mer_type. :- func pseudo_type_desc_type = mer_type. :- func type_ctor_desc_type = mer_type. @@ -67,11 +68,6 @@ % :- func build_type_info_type(mer_type) = mer_type. - % Build the type describing the typeclass_info for the - % given prog_constraint. - % -:- func build_typeclass_info_type = mer_type. - % Check whether a type is either the `type_info' type or the % `type_ctor_info' type introduced by this pass. % @@ -79,7 +75,7 @@ % Check whether a type is the `typeclass_info' type. % -:- pred type_is_typeclass_info(mer_type::in) is semidet. +:- pred type_is_typeclass_info_type(mer_type::in) is semidet. %---------------------------------------------------------------------------% % @@ -205,6 +201,10 @@ type_ctor_info_type = defined_type(Name, [], kind_star) :- BuiltinModule = mercury_private_builtin_module, Name = qualified(BuiltinModule, "type_ctor_info"). +typeclass_info_type = defined_type(Name, [], kind_star) :- + BuiltinModule = mercury_private_builtin_module, + Name = qualified(BuiltinModule, "typeclass_info"). + type_desc_type = defined_type(Name, [], kind_star) :- Module = mercury_std_lib_module_name(unqualified("type_desc")), Name = qualified(Module, "type_desc"). @@ -288,10 +288,7 @@ build_type_info_type(Type) = TypeInfoType :- TypeInfoType = type_info_type ). -build_typeclass_info_type = TypeClassInfoType :- - PrivateBuiltin = mercury_private_builtin_module, - TypeclassInfoTypeName = qualified(PrivateBuiltin, "typeclass_info"), - TypeClassInfoType = defined_type(TypeclassInfoTypeName, [], kind_star). +%---------------------% type_is_type_info_or_ctor_type(TypeInfoType) :- type_to_ctor_and_args(TypeInfoType, TypeCtor, []), @@ -301,8 +298,8 @@ type_is_type_info_or_ctor_type(TypeInfoType) :- ; TypeName = "type_ctor_info" ). -type_is_typeclass_info(TypeClassInfoType) :- - type_to_ctor(TypeClassInfoType, TypeCtor), +type_is_typeclass_info_type(TypeClassInfoType) :- + type_to_ctor_and_args(TypeClassInfoType, TypeCtor, []), TypeCtor = type_ctor(qualified(ModuleName, "typeclass_info"), 0), ModuleName = mercury_private_builtin_module. diff --git a/compiler/float_regs.m b/compiler/float_regs.m index 94a059c59..dd12a6646 100644 --- a/compiler/float_regs.m +++ b/compiler/float_regs.m @@ -1265,15 +1265,15 @@ insert_reg_wrappers_method_call(ClassId, MethodNum, Vars0, Vars, take_non_rtti_types_from_tail([], []). take_non_rtti_types_from_tail([Type | Types0], Types) :- - take_non_rtti_types_from_tail(Types0, Types1), + take_non_rtti_types_from_tail(Types0, TypesTail), ( if - ( type_is_typeclass_info(Type) - ; Type = type_info_type + ( type_is_typeclass_info_type(Type) + ; type_is_type_info_or_ctor_type(Type) ) then - Types = Types1 + Types = TypesTail else - Types = [Type | Types1] + Types = [Type | TypesTail] ). :- pred insert_reg_wrappers_foreign_call(pred_id::in, proc_id::in, diff --git a/compiler/higher_order.m b/compiler/higher_order.m index 6e84dad43..f7ae36f32 100644 --- a/compiler/higher_order.m +++ b/compiler/higher_order.m @@ -1238,7 +1238,7 @@ instance_matches(ClassTypes, Instance, Constraints, UnconstrainedTVarTypes, get_arg_typeclass_infos(ModuleInfo, TypeClassInfoVar, InstanceConstraints, Index, Goals, Vars, !ProcInfo) :- - MakeResultType = (func(_) = build_typeclass_info_type), + MakeResultType = (func(_) = typeclass_info_type), get_typeclass_info_args(ModuleInfo, TypeClassInfoVar, "instance_constraint_from_typeclass_info", MakeResultType, InstanceConstraints, Index, Goals, Vars, !ProcInfo). diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m index cec81d88c..8817b804b 100644 --- a/compiler/ml_type_gen.m +++ b/compiler/ml_type_gen.m @@ -801,7 +801,7 @@ gen_init_tag(Target, CtorClassId, SecondaryTagClassId, TagVal, Context) ml_gen_hld_du_ctor_typeclass_info_field(ModuleInfo, Context, _Constraint, Defn, FieldInfo, !ArgNum) :- - Type = build_typeclass_info_type, + Type = typeclass_info_type, ml_gen_hld_du_ctor_field_gen(ModuleInfo, Context, !.ArgNum, no, Type, aw_full_word, Defn, FieldInfo), !:ArgNum = !.ArgNum + 1. diff --git a/compiler/polymorphism.m b/compiler/polymorphism.m index 4aff52e58..b0c4e523a 100644 --- a/compiler/polymorphism.m +++ b/compiler/polymorphism.m @@ -1649,7 +1649,7 @@ polymorphism_process_foreign_proc_args(PredInfo, Impl, Vars, Args) :- % type_info/typeclass_info vars into the argument type list. TypeInfoTypes = list.map((func(_) = type_info_type), PredTypeVars), - TypeClassInfoType = build_typeclass_info_type, + TypeClassInfoType = typeclass_info_type, list.length(UnivCs, NumUnivCs), list.length(ExistCs, NumExistCs), list.duplicate(NumUnivCs + NumExistCs, TypeClassInfoType, diff --git a/compiler/polymorphism_type_class_info.m b/compiler/polymorphism_type_class_info.m index c3791292e..2fb2050c7 100644 --- a/compiler/polymorphism_type_class_info.m +++ b/compiler/polymorphism_type_class_info.m @@ -663,7 +663,7 @@ construct_typeclass_info(Constraint, BaseVar, BaseConsId, ArgVarsMCAs, new_typeclass_info_var(Constraint, typeclass_info_kind, TypeClassInfoVar, TypeClassInfoVarType, !Info), - BaseConstArg = csa_constant(BaseConsId, build_typeclass_info_type), + BaseConstArg = csa_constant(BaseConsId, typeclass_info_type), StructArgs = [BaseConstArg | VarConstArgs], list.map(get_inst_of_const_struct_arg(ConstStructDb0), VarConstArgs, VarInsts), @@ -969,7 +969,7 @@ new_typeclass_info_var(Constraint, VarKind, Var, VarType, !Info) :- Name = "TypeClassInfo_for_" ++ ClassNameString ), varset.name_var(Var, Name, VarSet1, VarSet), - VarType = build_typeclass_info_type, + VarType = typeclass_info_type, add_var_type(Var, VarType, VarTypes0, VarTypes), rtti_det_insert_typeclass_info_var(Constraint, Var, RttiVarMaps0, RttiVarMaps), @@ -983,7 +983,7 @@ new_typeclass_info_var(Constraint, VarKind, Var, VarType, !Info) :- materialize_base_typeclass_info_var(Constraint, ConsId, Var, Goals, !Info) :- poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap0), - ConstArg = csa_constant(ConsId, build_typeclass_info_type), + ConstArg = csa_constant(ConsId, typeclass_info_type), ( if map.search(ConstStructVarMap0, ConstArg, OldVar) then poly_info_get_num_reuses(!.Info, NumReuses), poly_info_set_num_reuses(NumReuses + 1, !Info),