mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-15 01:13:30 +00:00
Code Issues Projects Releases Wiki Activity
Files
b28858717f3fd5cd040bc40f2d352431be9bb71d
mercury/compiler/type_util.m
Julien Fischer b9777da30f Fix some documentation errors in the compiler. 
Fix some mispelled variable names.

compiler/accumulator.m:
compiler/check_import_accessibility.m:
compiler/decide_type_repn.m:
compiler/du_type_layout.m:
compiler/error_spec.m:
compiler/hlds_data.m:
compiler/hlds_goal.m:
compiler/mlds.m:
compiler/parse_item.m:
compiler/prog_data.m:
compiler/type_util.m:
    As above.
2026-01-24 01:19:51 +11:00

1993 lines
77 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1994-2012 The University of Melbourne.
% Copyright (C) 2014-2026 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: type_util.m.
% Main author: fjh.
%
% This file provides some utility predicates which operate on types.
% It is used by various stages of the compilation after type-checking,
% including the mode checker and the code generator.
%
% XXX TYPE_REPN
% Put the contents of this type into meaningful groups.
% XXX TYPE_REPN
% Consider which of these predicates are used only during semantic checking,
% and which are used afterwards as well. Consider moving the former
% to a new module in the check_hlds (as opposed to the hlds) package.
%
%-----------------------------------------------------------------------------%
:- module hlds.type_util.
:- interface.
:- import_module hlds.hlds_class.
:- import_module hlds.hlds_cons.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.set_of_var.
:- import_module parse_tree.var_table.
:- import_module list.
:- import_module set.
%-----------------------------------------------------------------------------%
% Given a type_ctor, look up its module/name/arity.
%
:- func type_ctor_module(type_ctor) = module_name.
:- func type_ctor_name(type_ctor) = string.
:- func type_ctor_arity(type_ctor) = arity.
:- pred type_ctor_module_name_arity(type_ctor::in,
module_name::out, string::out, arity::out) is det.
% Succeed iff type is an "atomic" type - one which can be unified
% using a simple_test rather than a complicated_unify.
%
:- pred type_is_atomic(module_info::in, mer_type::in) is semidet.
:- pred type_ctor_is_atomic(module_info::in, type_ctor::in) is semidet.
% Obtain the type definition and type definition body respectively,
% if known, for the principal type constructor of the given type.
%
% Fail if the given type is a type variable or if the type is a builtin
% type.
%
:- pred type_to_type_defn(module_info::in, mer_type::in, hlds_type_defn::out)
is semidet.
:- pred type_to_type_defn_from_type_table(type_table::in, mer_type::in,
hlds_type_defn::out) is semidet.
:- pred type_to_type_defn_body(module_info::in, mer_type::in,
hlds_type_body::out) is semidet.
:- pred type_to_type_defn_body_from_type_table(type_table::in, mer_type::in,
hlds_type_body::out) is semidet.
% Succeed iff there was either a `where equality is <predname>' or a
% `where comparison is <predname>' declaration for the principal type
% constructor of the specified type, and return the ids of the declared
% unify and/or comparison predicates. Note that even if the type
% constructor has only a `where comparison is' clause, it effectively
% has user-defined equality, two values being equal only if the
% compare pred returns equal.
%
% If the type is a type variable and thus has no principal type
% constructor, fail.
%
:- pred type_has_user_defined_equality_pred(module_info::in, mer_type::in,
noncanonical::out) is semidet.
:- pred type_body_has_user_defined_equality_pred(module_info::in,
hlds_type_body::in, noncanonical::out) is semidet.
% Succeed iff the type (not just the principal type constructor) is known
% to not have user-defined equality or comparison predicates.
%
% If the type is a type variable, or is abstract, etc., make the
% conservative approximation and fail.
%
:- pred type_definitely_has_no_user_defined_equality_pred(module_info::in,
mer_type::in) is semidet.
:- pred var_is_or_may_contain_solver_type(module_info::in, var_table::in,
prog_var::in) is semidet.
% Succeed iff the principal type constructor for the given type is
% declared a solver type, or if the type is a pred or func type.
% Pred and func types are considered solver types because higher-order
% terms that contain non-local solver variables are not ground unless
% all of the non-locals are ground.
%
% If the type is a type variable and thus has no principal type
% constructor, fail.
%
:- pred type_is_or_may_contain_solver_type(module_info::in, mer_type::in)
is semidet.
:- pred type_has_solver_type_details(module_info::in, mer_type::in,
solver_type_details::out) is semidet.
:- pred type_body_has_solver_type_details(module_info::in,
hlds_type_body::in, solver_type_details::out) is semidet.
:- pred type_is_solver_type(module_info::in, mer_type::in) is semidet.
:- pred type_is_solver_type_from_type_table(type_table::in, mer_type::in)
is semidet.
% Succeed if the type body is for a solver type.
%
:- pred type_body_is_solver_type(module_info::in, hlds_type_body::in)
is semidet.
:- pred type_body_is_solver_type_from_type_table(type_table::in,
hlds_type_body::in) is semidet.
% Succeeds iff one or more of the type constructors for a given
% type is existentially quantified.
%
:- pred type_is_existq_type(module_info::in, mer_type::in) is semidet.
% Certain types are just dummy types used to ensure logical semantics
% or to act as a placeholder; they contain no information, and thus
% there is no need to actually pass them around, so we don't. Also,
% when importing or exporting procedures to/from C, we don't include
% arguments with these types.
%
% A type is a dummy type in one of three cases:
%
% - its principal type constructor is a builtin dummy type constructor
% such as io.state or store.store(S);
% - it has only a single function symbol with zero arguments;
% - it has only a single function symbol with one argument, which is itself
% a dummy type.
%
% A type cannot be a dummy type if it is the subject of a foreign_enum
% pragma, or if it has a reserved tag or user-defined equality.
%
% A subtype is only a dummy type if its base type is a dummy type.
%
% This function returns valid data only when invoked after the pass
% that fills in the type representation field in every entry in the
% type table. Until then, the return value will be correct only
% by accident.
%
% NOTE: changes here may require changes to
% `non_sub_du_constructor_list_represents_dummy_type'.
%
:- func is_type_a_dummy(module_info, mer_type) = is_dummy_type.
:- type is_either_dummy_type
---> at_least_one_is_dummy_type
; neither_is_dummy_type.
% Return at_least_one_is_dummy_type if *either* of the two types
% is a dummy type.
%
% Usually used to check the "dummyness" of both the type of an argument
% in both the caller and the callee of a call.
%
:- func is_either_type_a_dummy(module_info, mer_type, mer_type) =
is_either_dummy_type.
% A test for types that are defined in Mercury, but whose definitions
% are `lies', i.e. they are not sufficiently accurate for RTTI
% structures describing the types. Since the RTTI will be hand defined,
% the compiler shouldn't generate RTTI for these types.
%
:- pred type_ctor_has_hand_defined_rtti(type_ctor::in, hlds_type_body::in)
is semidet.
% Return the base type constructor for a given type constructor.
% This predicate must only be called with a type constructor that is known
% to be a subtype or supertype type constructor, not with arbitrary type
% constructors.
%
:- pred get_base_type_ctor(type_table::in, type_ctor::in, type_ctor::out)
is semidet.
% Return the supertype of a type, if any.
% This will substitute the type's arguments into its declared supertype.
%
:- pred get_supertype(type_table::in, tvarset::in, type_ctor::in,
list(mer_type)::in, mer_type::out) is semidet.
% Given a type, determine what category its principal constructor
% falls into.
%
:- func classify_type(module_info, mer_type) = type_ctor_category.
% Given a type_ctor, determine what sort it is.
%
:- func classify_type_ctor(module_info, type_ctor) = type_ctor_category.
% Given a type_ctor, determine what sort it is, *if* it is a special
% kind of type_ctor. Unlike classify_type_ctor itself, it does not need
% type representations to have been computed yet.
%
:- pred classify_type_ctor_if_special(type_ctor::in, type_ctor_category::out)
is semidet.
% Given a type_ctor's type_ctor_defn's body, determine what sort it is.
%
:- func classify_type_defn_body(hlds_type_body) = type_ctor_category.
% Report whether it is OK to include a value of the given time
% in a heap cell allocated with GC_malloc_atomic.
%
:- func type_may_use_atomic_alloc(module_info, mer_type) =
may_use_atomic_alloc.
% update_type_may_use_atomic_alloc(ModuleInfo, Type, !MaybeUseAtomic):
%
% Find out whether it is OK to include a value of the given time
% in a heap cell allocated with GC_malloc_atomic. If yes, leave
% !MaybeUseAtomic alone. If no, set !:MaybeUseAtomic to
% may_not_use_atomic_alloc.
%
:- pred update_type_may_use_atomic_alloc(module_info::in, mer_type::in,
may_use_atomic_alloc::in, may_use_atomic_alloc::out) is det.
% If the type is a du type or a tuple type, return the list of its
% constructors.
%
:- pred type_constructors(module_info::in, mer_type::in,
list(constructor)::out) is semidet.
% Given a type on which it is possible to have a complete switch, return
% the number of alternatives. (It is possible to have a complete switch on
% any du type, on the builtin type character and on the builtin fixed size
% integer types. It is not feasible to have a complete switch on the
% builtin types int, uint, float, and string. One cannot have a switch on
% an abstract type, and equivalence types will have been expanded out by
% the time we consider switches.)
%
:- pred switch_type_num_functors(module_info::in, mer_type::in, int::out)
is semidet.
% Work out the types of the arguments of a functor, given the cons_id
% and type of the functor. Aborts if the functor is existentially typed.
% Note that this will substitute appropriate values for any type variables
% in the functor's argument types, to match their bindings in the
% functor's type.
%
:- pred get_cons_id_arg_types(module_info::in, mer_type::in,
cons_id::in, list(mer_type)::out) is det.
:- pred get_du_ctor_arg_types(module_info::in, mer_type::in,
du_ctor::in, list(mer_type)::out) is det.
% The same as get_user_data_arg_types except that it fails rather than
% aborting if the functor is existentially typed.
%
:- pred get_cons_id_non_existential_arg_types(module_info::in,
mer_type::in, cons_id::in, list(mer_type)::out) is semidet.
:- pred get_du_ctor_non_existential_arg_types(module_info::in,
mer_type::in, du_ctor::in, list(mer_type)::out) is semidet.
% The same as get_cons_id_arg_types except that it returns
% the argument not just for a single data constructor in the type,
% but all of them.
%
:- pred all_du_ctor_arg_types(module_info::in, mer_type::in,
list({string, arity, list(mer_type)})::out) is det.
% Is this type a du type?
%
% ZZZ
:- pred type_is_du_type(module_info::in, mer_type::in,
hlds_type_defn::out, type_body_du::out) is semidet.
% Given a type constructor and one of its cons_ids, look up the definition
% of that cons_id. Fails if the cons_id is not user-defined.
%
% Note that this will NOT bind type variables in the functor's argument
% types; they will be left unbound, so the caller can find out the
% original types from the constructor definition. The caller must do
% that substitution itself if required.
%
% The versions with "repn" in the name return a definition of the
% constructor that includes type representation information.
% These versions may be called only after the pass in which
% type representations are decided.
%
:- pred get_cons_defn(module_info::in, type_ctor::in, du_ctor::in,
hlds_cons_defn::out) is semidet.
:- pred get_cons_defn_det(module_info::in, type_ctor::in, du_ctor::in,
hlds_cons_defn::out) is det.
:- pred get_cons_repn_defn(module_info::in, du_ctor::in,
constructor_repn::out) is semidet.
:- pred get_cons_repn_defn_det(module_info::in, du_ctor::in,
constructor_repn::out) is det.
:- pred get_cons_id_repn_defn_det(module_info::in, cons_id::in,
constructor_repn::out) is det.
% This type is used to return information about a constructor definition,
% extracted from the hlds_type_defn and hlds_cons_defn data types.
%
:- type ctor_defn
---> ctor_defn(
ctor_tvars :: tvarset,
% The kinds of the type variables.
ctor_tvar_kinds :: tvar_kind_map,
% Existential constraints, if any.
ctor_maybe_exist :: maybe_cons_exist_constraints,
% The type of the functor's arguments.
ctor_arg_types :: list(mer_type),
% The functor's result type.
ctor_result_type :: mer_type
).
% Given a type and a cons_id, look up the definition of that constructor;
% if it is existentially typed, return its definition, otherwise fail.
% Note that this will NOT bind type variables in the functor's argument
% types; they will be left unbound, so the caller can find out the
% original types from the constructor definition. The caller must do
% that substitution itself if required.
%
:- pred get_existq_cons_defn(module_info::in, mer_type::in, du_ctor::in,
ctor_defn::out) is semidet.
:- pred cons_id_is_existq_cons(module_info::in, mer_type::in,
du_ctor::in) is semidet.
% Check whether a type is a no_tag type (i.e. one with only one
% constructor, and whose one constructor has only one argument).
%
:- pred type_is_no_tag_type(module_info::in, mer_type::in) is semidet.
% As above, but return the constructor symbol and argument type on
% success.
%
:- pred type_is_no_tag_type(module_info::in, mer_type::in, sym_name::out,
mer_type::out) is semidet.
% du_ctor_adjusted_arity(ModuleInfo, Type, DuCtor):
%
% Returns the number of arguments of the specified constructor id,
% adjusted to include the extra typeclassinfo and typeinfo arguments
% inserted by polymorphism.m for existentially typed constructors.
%
:- func du_ctor_adjusted_arity(module_info, mer_type, du_ctor) = int.
% Check if (values/program terms of) the type is NOT allocated in a
% region in region-based memory management.
%
:- pred type_not_stored_in_region(mer_type::in, module_info::in) is semidet.
% Succeed iff the given variable is of region_type.
%
:- pred is_region_var(var_table::in, prog_var::in) is semidet.
%-----------------------------------------------------------------------------%
% Given a list of variables, return the permutation
% of that list which has all the type_info-related variables
% preceding the non-type_info-related variables (with the relative
% order of variables within each group being the same as in the
% original list).
%
:- func put_typeinfo_vars_first(var_table, list(prog_var)) = list(prog_var).
% Given a list of variables, remove all the type_info-related
% variables.
%
:- func remove_typeinfo_vars(var_table, list(prog_var)) = list(prog_var).
:- func remove_typeinfo_vars_from_set(var_table, set(prog_var))
= set(prog_var).
:- func remove_typeinfo_vars_from_set_of_var(var_table, set_of_progvar)
= set_of_progvar.
%-----------------------------------------------------------------------------%
%
% Predicates for doing renamings and substitutions on HLDS data structures.
%
:- pred apply_renaming_to_constraint(tvar_renaming::in,
hlds_constraint::in, hlds_constraint::out) is det.
:- pred apply_subst_to_constraint(tsubst::in, hlds_constraint::in,
hlds_constraint::out) is det.
:- pred apply_rec_subst_to_constraint(tsubst::in, hlds_constraint::in,
hlds_constraint::out) is det.
%-------------%
:- pred apply_renaming_to_constraints(tvar_renaming::in,
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
:- pred apply_subst_to_constraints(tsubst::in, list(hlds_constraint)::in,
list(hlds_constraint)::out) is det.
:- pred apply_rec_subst_to_constraints(tsubst::in,
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
%-------------%
:- pred apply_renaming_to_constraint_db(tvar_renaming::in,
hlds_constraint_db::in, hlds_constraint_db::out) is det.
:- pred apply_subst_to_constraint_db(tsubst::in,
hlds_constraint_db::in, hlds_constraint_db::out) is det.
:- pred apply_rec_subst_to_constraint_db(tsubst::in,
hlds_constraint_db::in, hlds_constraint_db::out) is det.
%-------------%
:- pred apply_renaming_to_constraint_proof_map(tvar_renaming::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
:- pred apply_subst_to_constraint_proof_map(tsubst::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
:- pred apply_rec_subst_to_constraint_proof_map(tsubst::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
%-------------%
:- pred apply_renaming_to_constraint_map(tvar_renaming::in,
constraint_map::in, constraint_map::out) is det.
:- pred apply_subst_to_constraint_map(tsubst::in,
constraint_map::in, constraint_map::out) is det.
:- pred apply_rec_subst_to_constraint_map(tsubst::in,
constraint_map::in, constraint_map::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module backend_libs.
:- import_module backend_libs.foreign.
:- import_module backend_libs.string_encoding.
:- import_module libs.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.builtin_modules.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_type_construct.
:- import_module parse_tree.prog_type_scan.
:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_type_test.
:- import_module bool.
:- import_module int.
:- import_module map.
:- import_module maybe.
:- import_module one_or_more.
:- import_module require.
:- import_module term_context.
%-----------------------------------------------------------------------------%
type_ctor_module(type_ctor(TypeSymName, _Arity)) = ModuleName :-
% If a type_ctor has an unqualified sym_name, return "builtin" as its
% module name, since
%
% - after typechecking, all type_ctors will be module qualified, with
% the only exceptions being the type_ctors of builtin types; and
%
% - before typechecking, no type_ctors will be module qualified beyond
% whatever qualification may have been written down explicitly
% by the programmer, which makes calling this function futile.
sym_name_get_module_name_default(TypeSymName,
unqualified("builtin"), ModuleName).
type_ctor_name(type_ctor(TypeSymName, _Arity)) =
unqualify_name(TypeSymName).
type_ctor_arity(type_ctor(_TypeSymName, Arity)) = Arity.
type_ctor_module_name_arity(type_ctor(TypeSymName, Arity), ModuleName, Name,
Arity) :-
% See the comment in type_ctor_module.
sym_name_get_module_name_default_name(TypeSymName,
unqualified("builtin"), ModuleName, Name).
%-----------------------------------------------------------------------------%
type_is_atomic(ModuleInfo, Type) :-
type_to_ctor(Type, TypeCtor),
type_ctor_is_atomic(ModuleInfo, TypeCtor).
type_ctor_is_atomic(ModuleInfo, TypeCtor) :-
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
type_ctor_category_is_atomic(TypeCategory) = yes.
:- func type_ctor_category_is_atomic(type_ctor_category) = bool.
type_ctor_category_is_atomic(CtorCat) = IsAtomic :-
(
( CtorCat = ctor_cat_builtin(_)
; CtorCat = ctor_cat_enum(_)
; CtorCat = ctor_cat_void
; CtorCat = ctor_cat_builtin_dummy
; CtorCat = ctor_cat_user(cat_user_abstract_dummy)
; CtorCat = ctor_cat_user(cat_user_direct_dummy)
),
IsAtomic = yes
;
( CtorCat = ctor_cat_higher_order
; CtorCat = ctor_cat_tuple
; CtorCat = ctor_cat_variable
; CtorCat = ctor_cat_system(_)
; CtorCat = ctor_cat_user(cat_user_notag)
; CtorCat = ctor_cat_user(cat_user_abstract_notag)
; CtorCat = ctor_cat_user(cat_user_general)
),
IsAtomic = no
).
type_to_type_defn(ModuleInfo, Type, TypeDefn) :-
module_info_get_type_table(ModuleInfo, TypeTable),
type_to_ctor(Type, TypeCtor),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn).
type_to_type_defn_from_type_table(TypeTable, Type, TypeDefn) :-
type_to_ctor(Type, TypeCtor),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn).
type_to_type_defn_body(ModuleInfo, Type, TypeBody) :-
type_to_type_defn(ModuleInfo, Type, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody).
type_to_type_defn_body_from_type_table(TypeTable, Type, TypeBody) :-
type_to_type_defn_from_type_table(TypeTable, Type, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody).
type_has_user_defined_equality_pred(ModuleInfo, Type, UserEqComp) :-
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, UserEqComp).
type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, NonCanonical) :-
require_complete_switch [TypeBody]
(
TypeBody = hlds_du_type(TypeBodyDu),
TypeBodyDu = type_body_du(_, _, _, _, _, MaybeForeignType),
( if
MaybeForeignType = yes(ForeignTypeBody),
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
have_foreign_type_for_backend(Target, ForeignTypeBody, yes)
then
foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo,
ForeignTypeBody, NonCanonical)
else
TypeBodyDu ^ du_type_canonical = noncanon(NonCanonical)
)
;
TypeBody = hlds_foreign_type(ForeignTypeBody),
foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo,
ForeignTypeBody, NonCanonical)
;
TypeBody = hlds_solver_type(DetailsSolver),
DetailsSolver =
type_details_solver(_SolverTypeDetails, noncanon(NonCanonical))
;
( TypeBody = hlds_abstract_type(_)
; TypeBody = hlds_eqv_type(_)
),
fail
).
type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type) :-
type_definitely_has_no_user_defined_eq_pred_2(ModuleInfo, Type,
set.init, _).
:- pred type_definitely_has_no_user_defined_eq_pred_2(module_info::in,
mer_type::in, set(mer_type)::in, set(mer_type)::out) is semidet.
type_definitely_has_no_user_defined_eq_pred_2(ModuleInfo, Type, !SeenTypes) :-
( if set.contains(!.SeenTypes, Type) then
% Don't loop on recursive types.
true
else
set.insert(Type, !SeenTypes),
require_complete_switch [Type]
(
Type = builtin_type(_)
;
Type = tuple_type(Args, _Kind),
types_definitely_have_no_user_defined_eq_pred(ModuleInfo,
Args, !SeenTypes)
;
( Type = defined_type(_, _, _)
; Type = higher_order_type(_, _, _, _)
; Type = apply_n_type(_, _, _)
; Type = kinded_type(_, _)
),
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo,
Type, TypeBody, !SeenTypes),
type_to_ctor_and_args_det(Type, _, Args),
types_definitely_have_no_user_defined_eq_pred(ModuleInfo,
Args, !SeenTypes)
;
Type = type_variable(_, _),
fail
)
).
:- pred types_definitely_have_no_user_defined_eq_pred(module_info::in,
list(mer_type)::in, set(mer_type)::in, set(mer_type)::out) is semidet.
types_definitely_have_no_user_defined_eq_pred(ModuleInfo, Types, !SeenTypes) :-
list.foldl(type_definitely_has_no_user_defined_eq_pred_2(ModuleInfo),
Types, !SeenTypes).
:- pred type_body_definitely_has_no_user_defined_equality_pred(module_info::in,
mer_type::in, hlds_type_body::in, set(mer_type)::in, set(mer_type)::out)
is semidet.
type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type,
TypeBody, !SeenTypes) :-
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
(
TypeBody = hlds_du_type(TypeBodyDu),
( if
TypeBodyDu ^ du_type_is_foreign_type = yes(ForeignTypeBody),
have_foreign_type_for_backend(Target, ForeignTypeBody, yes)
then
not foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo,
ForeignTypeBody, _)
else
TypeBodyDu ^ du_type_canonical = canon,
% type_constructors does substitution of types variables.
type_constructors(ModuleInfo, Type, Ctors),
list.foldl(ctor_definitely_has_no_user_defined_eq_pred(ModuleInfo),
Ctors, !SeenTypes)
)
;
TypeBody = hlds_eqv_type(EqvType),
type_definitely_has_no_user_defined_equality_pred(ModuleInfo, EqvType)
;
TypeBody = hlds_foreign_type(ForeignTypeBody),
not foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo,
ForeignTypeBody, _)
;
TypeBody = hlds_solver_type(DetailsSolver),
DetailsSolver = type_details_solver(_, canon)
;
TypeBody = hlds_abstract_type(_),
fail
).
:- pred ctor_definitely_has_no_user_defined_eq_pred(module_info::in,
constructor::in, set(mer_type)::in, set(mer_type)::out) is semidet.
ctor_definitely_has_no_user_defined_eq_pred(ModuleInfo, Ctor, !SeenTypes) :-
% There must not be any existentially quantified type variables.
Ctor = ctor(_, no_exist_constraints, _, Args, _, _),
% The data constructor argument types must not have user-defined equality
% or comparison predicates.
ArgTypes = list.map((func(A) = A ^ arg_type), Args),
list.foldl(type_definitely_has_no_user_defined_eq_pred_2(ModuleInfo),
ArgTypes, !SeenTypes).
var_is_or_may_contain_solver_type(ModuleInfo, VarTable, Var) :-
lookup_var_type(VarTable, Var, Type),
type_is_or_may_contain_solver_type(ModuleInfo, Type).
type_is_or_may_contain_solver_type(ModuleInfo, Type) :-
(
type_is_higher_order(Type)
;
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
(
TypeBody = hlds_solver_type(_)
;
TypeBody = hlds_abstract_type(abstract_solver_type)
;
TypeBody = hlds_eqv_type(EqvType),
type_is_or_may_contain_solver_type(ModuleInfo, EqvType)
)
).
type_has_solver_type_details(ModuleInfo, Type, SolverTypeDetails) :-
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
type_body_has_solver_type_details(ModuleInfo, TypeBody,
SolverTypeDetails).
type_body_has_solver_type_details(ModuleInfo, Type, SolverTypeDetails) :-
require_complete_switch [Type]
(
Type = hlds_solver_type(DetailsSolver),
DetailsSolver =
type_details_solver(SolverTypeDetails, _MaybeUserEqComp)
;
Type = hlds_eqv_type(EqvType),
type_has_solver_type_details(ModuleInfo, EqvType, SolverTypeDetails)
;
( Type = hlds_du_type(_)
; Type = hlds_foreign_type(_)
; Type = hlds_abstract_type(_)
),
fail
).
type_is_solver_type(ModuleInfo, Type) :-
% XXX We can't assume that type variables refer to solver types
% because otherwise the compiler will try to construct initialisation
% forwarding predicates for exported abstract types defined to be
% equivalent to a type variable parameter. This, of course, will
% lead to the compiler throwing an exception. The correct solution
% is to introduce a solver typeclass, but that's something for another day.
%
% Type_to_type_defn_body will fail for builtin types such as `int/0'.
% Such types are not solver types so is_solver_type fails too.
% Type_to_type_defn_body also fails for type variables.
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
type_body_is_solver_type(ModuleInfo, TypeBody).
type_is_solver_type_from_type_table(TypeTable, Type) :-
% XXX The comment in type_is_solver_type applies here as well.
type_to_type_defn_body_from_type_table(TypeTable, Type, TypeBody),
type_body_is_solver_type_from_type_table(TypeTable, TypeBody).
type_body_is_solver_type(ModuleInfo, TypeBody) :-
% Please keep in sync with get_body_is_solver_type in add_type.m.
require_complete_switch [TypeBody]
(
TypeBody = hlds_solver_type(_),
IsSolverType = solver_type
;
TypeBody = hlds_abstract_type(AbstractType),
require_complete_switch [AbstractType]
(
AbstractType = abstract_solver_type,
IsSolverType = solver_type
;
( AbstractType = abstract_type_general
; AbstractType = abstract_dummy_type
; AbstractType = abstract_notag_type
; AbstractType = abstract_type_fits_in_n_bits(_)
; AbstractType = abstract_subtype(_)
),
IsSolverType = non_solver_type
)
;
TypeBody = hlds_eqv_type(Type),
% type_body_is_solver_type and get_body_is_solver_type differ
% in their treatment of equivalence types.
( if type_is_solver_type(ModuleInfo, Type) then
IsSolverType = solver_type
else
IsSolverType = non_solver_type
)
;
( TypeBody = hlds_du_type(_)
; TypeBody = hlds_foreign_type(_)
),
IsSolverType = non_solver_type
),
IsSolverType = solver_type.
type_body_is_solver_type_from_type_table(TypeTable, TypeBody) :-
require_complete_switch [TypeBody]
(
TypeBody = hlds_solver_type(_),
IsSolverType = yes
;
TypeBody = hlds_abstract_type(AbstractType),
require_complete_switch [AbstractType]
(
AbstractType = abstract_solver_type,
IsSolverType = yes
;
( AbstractType = abstract_type_general
; AbstractType = abstract_dummy_type
; AbstractType = abstract_notag_type
; AbstractType = abstract_type_fits_in_n_bits(_)
; AbstractType = abstract_subtype(_)
),
IsSolverType = no
)
;
TypeBody = hlds_eqv_type(Type),
( if type_is_solver_type_from_type_table(TypeTable, Type) then
IsSolverType = yes
else
IsSolverType = no
)
;
( TypeBody = hlds_du_type(_)
; TypeBody = hlds_foreign_type(_)
),
IsSolverType = no
),
IsSolverType = yes.
type_is_existq_type(ModuleInfo, Type) :-
type_constructors(ModuleInfo, Type, Constructors),
some [Constructor] (
list.member(Constructor, Constructors),
Constructor ^ cons_maybe_exist = exist_constraints(_)
).
is_type_a_dummy(ModuleInfo, Type) = IsDummy :-
module_info_get_type_table(ModuleInfo, TypeTable),
IsDummy = is_type_a_dummy_loop(TypeTable, Type, []).
is_either_type_a_dummy(ModuleInfo, TypeA, TypeB) = IsDummy :-
module_info_get_type_table(ModuleInfo, TypeTable),
IsDummyA = is_type_a_dummy_loop(TypeTable, TypeA, []),
(
IsDummyA = is_dummy_type,
IsDummy = at_least_one_is_dummy_type
;
IsDummyA = is_not_dummy_type,
IsDummyB = is_type_a_dummy_loop(TypeTable, TypeB, []),
(
IsDummyB = is_dummy_type,
IsDummy = at_least_one_is_dummy_type
;
IsDummyB = is_not_dummy_type,
IsDummy = neither_is_dummy_type
)
).
:- func is_type_a_dummy_loop(type_table, mer_type, list(mer_type))
= is_dummy_type.
is_type_a_dummy_loop(TypeTable, Type, CoveredTypes) = IsDummy :-
% Since the sizes of types in any given program is bounded, this test
% will ensure termination.
( if list.member(Type, CoveredTypes) then
% The type is circular.
IsDummy = is_not_dummy_type
else if type_to_ctor_and_args(Type, TypeCtor, ArgTypes) then
% Keep this in sync with is_dummy_argument_type_with_constructors
% above.
% XXX gone since 097b45acec46527f1485419e66ce28d5ba224846
IsBuiltinDummy = is_type_ctor_a_builtin_dummy(TypeCtor),
(
IsBuiltinDummy = is_builtin_dummy_type_ctor,
IsDummy = is_dummy_type
;
IsBuiltinDummy = is_builtin_non_dummy_type_ctor,
IsDummy = is_not_dummy_type
;
IsBuiltinDummy = is_not_builtin_dummy_type_ctor,
% This can fail for some builtin type constructors such as func,
% pred, and tuple, none of which are dummy types.
( if search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) then
get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(TypeBodyDu),
TypeBodyDu = type_body_du(_, _, _, _, MaybeTypeRepn, _),
(
MaybeTypeRepn = no,
% Code setting up var_table entries invokes
% our caller, is_type_a_dummy, to decide whether
% the type is a dummy. Some of that code is invoked
% *before* the pass that decides each type's
% representation has been run. This is why,
% when invoked at such times, we cannot just
% throw an exception here.
%
% There are two cases: either (a) our caller calls us
% to fill in the vte_is_dummy field, or (b) it calls us
% for some other purpose.
%
% Case (a) is ok, because
%
% - no part of the compiler pays attention to
% the vte_is_dummy field until *after* the
% post-typecheck pass, and
%
% - the post-typecheck pass, which is run after
% type representations have been decided, replaces
% all the old, possibly-inaccurate values in all
% those fields in all predicates' var_tables
% with accurate values.
%
% Case (b) is ok because until (a) became a concern,
% this arm of the switch contained code to throw
% an exception, but that code has (to the best of
% my knowledge) never been executed.
%
% The value we return here won't be looked at,
% so in one sense, what we return does not matter.
% We return is_dummy_type because if, due to a bug,
% some compiler pass *does* pay attention to the
% returned value, returning is_dummy_type is
% much less likely to lead to *silent* error.
%
% XXX We could get extra insurance by looking up
% a flag (stored either in a flag in the module_info,
% or in a mutable) that says whether type
% representations *should* have been filled in
% by now, and throw an exception if we get here
% even though the representation *should* have been
% filled in.
IsDummy = is_dummy_type
;
MaybeTypeRepn = yes(TypeRepn),
DuTypeKind = TypeRepn ^ dur_kind,
(
DuTypeKind = du_type_kind_direct_dummy,
IsDummy = is_dummy_type
;
( DuTypeKind = du_type_kind_mercury_enum
; DuTypeKind = du_type_kind_foreign_enum(_)
; DuTypeKind = du_type_kind_general
),
IsDummy = is_not_dummy_type
;
DuTypeKind = du_type_kind_notag(_,
SingleArgTypeInDefn, _),
get_type_defn_tparams(TypeDefn, TypeParams),
map.from_corresponding_lists(TypeParams, ArgTypes,
Subst),
apply_subst_to_type(Subst, SingleArgTypeInDefn,
SingleArgType),
IsDummy = is_type_a_dummy_loop(TypeTable,
SingleArgType, [Type | CoveredTypes])
)
)
;
TypeBody = hlds_abstract_type(AbstractDetails),
(
( AbstractDetails = abstract_type_general
; AbstractDetails = abstract_type_fits_in_n_bits(_)
; AbstractDetails = abstract_notag_type
; AbstractDetails = abstract_solver_type
),
IsDummy = is_not_dummy_type
;
AbstractDetails = abstract_dummy_type,
IsDummy = is_dummy_type
;
AbstractDetails = abstract_subtype(SuperTypeCtor),
% It does not matter what the supertype type parameters
% are bound to, only that they are not dummy types.
SuperTypeCtor = type_ctor(_, Arity),
list.duplicate(Arity, int_type, FakeArgTypes),
construct_type(SuperTypeCtor, FakeArgTypes, SuperType),
IsDummy = is_type_a_dummy_loop(TypeTable, SuperType,
[Type | CoveredTypes])
)
;
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_)
),
IsDummy = is_not_dummy_type
)
else
IsDummy = is_not_dummy_type
)
)
else
IsDummy = is_not_dummy_type
).
type_ctor_has_hand_defined_rtti(Type, Body) :-
Type = type_ctor(qualified(mercury_private_builtin_module, Name), 0),
( Name = "type_info"
; Name = "type_ctor_info"
; Name = "typeclass_info"
; Name = "base_typeclass_info"
),
require_complete_switch [Body]
(
Body = hlds_du_type(TypeBodyDu),
TypeBodyDu = type_body_du(_, _, _, _, _, IsForeignType),
(
IsForeignType = yes(_),
HasHandDefinedRtti = no
;
IsForeignType = no,
HasHandDefinedRtti = yes
)
;
( Body = hlds_foreign_type(_)
; Body = hlds_solver_type(_)
),
HasHandDefinedRtti = no
;
( Body = hlds_abstract_type(_)
; Body = hlds_eqv_type(_)
),
HasHandDefinedRtti = yes
),
HasHandDefinedRtti = yes.
%-----------------------------------------------------------------------------%
get_base_type_ctor(TypeTable, TypeCtor, BaseTypeCtor) :-
% Circular subtype definitions are assumed to have been detected by now.
hlds_data.search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
require_complete_switch [TypeBody]
(
TypeBody = hlds_du_type(TypeBodyDu),
TypeBodyDu = type_body_du(_, _, MaybeSuperType, _, _, _),
(
MaybeSuperType = not_a_subtype,
BaseTypeCtor = TypeCtor
;
MaybeSuperType = subtype_of(SuperType),
type_to_ctor(SuperType, SuperTypeCtor),
get_base_type_ctor(TypeTable, SuperTypeCtor, BaseTypeCtor)
)
;
TypeBody = hlds_abstract_type(AbstractDetails),
require_complete_switch [AbstractDetails]
(
( AbstractDetails = abstract_type_general
; AbstractDetails = abstract_type_fits_in_n_bits(_)
; AbstractDetails = abstract_dummy_type
; AbstractDetails = abstract_notag_type
),
BaseTypeCtor = TypeCtor
;
AbstractDetails = abstract_subtype(SuperTypeCtor),
get_base_type_ctor(TypeTable, SuperTypeCtor, BaseTypeCtor)
;
AbstractDetails = abstract_solver_type,
unexpected($pred, "abstract solver type")
)
;
TypeBody = hlds_eqv_type(EqvType),
type_to_ctor(EqvType, EqvTypeCtor),
get_base_type_ctor(TypeTable, EqvTypeCtor, BaseTypeCtor)
;
TypeBody = hlds_foreign_type(_),
unexpected($pred, "foreign type")
;
TypeBody = hlds_solver_type(_),
unexpected($pred, "solver type")
).
%-----------------------------------------------------------------------------%
get_supertype(TypeTable, TVarSet, TypeCtor, ArgTypes, SuperType) :-
hlds_data.search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
TypeBody = hlds_du_type(TypeBodyDu),
TypeBodyDu = type_body_du(_, _, subtype_of(SuperType0), _, _, _),
require_det (
% Create substitution from type parameters to ArgTypes.
hlds_data.get_type_defn_tvarset(TypeDefn, TVarSet0),
hlds_data.get_type_defn_tparams(TypeDefn, TypeParams0),
tvarset_merge_renaming(TVarSet, TVarSet0, _NewTVarSet, Renaming),
apply_renaming_to_tvars(Renaming, TypeParams0, TypeParams),
map.from_corresponding_lists(TypeParams, ArgTypes, TSubst),
% Apply substitution to the declared supertype.
apply_renaming_to_type(Renaming, SuperType0, SuperType1),
apply_rec_subst_to_type(TSubst, SuperType1, SuperType)
).
%-----------------------------------------------------------------------------%
classify_type(ModuleInfo, Type) = TypeCategory :-
( if type_to_ctor(Type, TypeCtor) then
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
else
TypeCategory = ctor_cat_variable
).
classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
( if classify_type_ctor_if_special(TypeCtor, TypeCategoryPrime) then
TypeCategory = TypeCategoryPrime
else
module_info_get_type_table(ModuleInfo, TypeTable),
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
TypeCategory = classify_type_defn_body(TypeBody)
).
classify_type_ctor_if_special(TypeCtor, TypeCategory) :-
% Please keep the code of this predicate in sync with the code of
% classify_type_defn_body.
%
% Please also keep the relevant parts of this code in sync with
%
% - builtin_type_to_string
% - int_type_to_string
% - type_ctor_is_higher_order
% - type_ctor_is_tuple
% - check_builtin_dummy_type_ctor
%
TypeCtor = type_ctor(TypeSymName, Arity),
( TypeSymName = unqualified(TypeName)
; TypeSymName = qualified(_ModuleSymName, TypeName)
),
(
(
TypeName = "int",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_int))
;
TypeName = "uint",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_uint))
;
TypeName = "int8",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_int8))
;
TypeName = "uint8",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_uint8))
;
TypeName = "int16",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_int16))
;
TypeName = "uint16",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_uint16))
;
TypeName = "int32",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_int32))
;
TypeName = "uint32",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_uint32))
;
TypeName = "int64",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_int64))
;
TypeName = "uint64",
TypeCategory = ctor_cat_builtin(cat_builtin_int(int_type_uint64))
;
TypeName = "character",
TypeCategory = ctor_cat_builtin(cat_builtin_char)
;
TypeName = "float",
TypeCategory = ctor_cat_builtin(cat_builtin_float)
;
TypeName = "string",
TypeCategory = ctor_cat_builtin(cat_builtin_string)
;
TypeName = "void",
TypeCategory = ctor_cat_void
),
(
TypeSymName = unqualified(_TypeName)
;
TypeSymName = qualified(ModuleSymName, _TypeName),
ModuleSymName = mercury_public_builtin_module
),
Arity = 0
;
(
TypeName = "type_info",
TypeCategory = ctor_cat_system(cat_system_type_info)
;
TypeName = "type_ctor_info",
TypeCategory = ctor_cat_system(cat_system_type_ctor_info)
;
TypeName = "typeclass_info",
TypeCategory = ctor_cat_system(cat_system_typeclass_info)
;
TypeName = "base_typeclass_info",
TypeCategory = ctor_cat_system(cat_system_base_typeclass_info)
),
TypeSymName = qualified(ModuleSymName, _TypeName),
ModuleSymName = mercury_private_builtin_module,
Arity = 0
;
(
TypeName = "state",
TypeSymName = qualified(ModuleSymName, _TypeName),
ModuleSymName = mercury_io_module,
Arity = 0
;
TypeName = "store",
TypeSymName = qualified(ModuleSymName, _TypeName),
ModuleSymName = maybe_add_stdlib_wrapper(unqualified("store")),
Arity = 1
),
TypeCategory = ctor_cat_builtin_dummy
;
(
TypeName = "pred"
;
TypeName = "func"
),
% The previous version of classify_type_ctor was implemented
% as a series of nested if-then-elses, with two conditions
% that could recognize higher order type constructors.
(
% This was the first condition.
TypeSymName = qualified(ModuleSymName, _TypeName),
ModuleSymName = mercury_public_builtin_module,
Arity = 0
;
% This was the second condition.
(
TypeSymName = unqualified(_TypeName)
;
TypeSymName = qualified(ModuleSymName, _TypeName),
ModuleSymName = unqualified(Qualifier),
( Qualifier = "impure"
; Qualifier = "semipure"
)
)
% The arity may be anything.
),
% XXX zs: Having two conditions that look so different seems wrong.
TypeCategory = ctor_cat_higher_order
;
% XXX The compiler does not recognize any type named tuple/0 in
% user code, but it nevertheless needs to know about this type,
% because the compiler itself generates references to it. The
% type_infos for tuples types (whose type name is "{}", not "tuple")
% reference the hand-written type_ctor_info for the type named "tuple".
% Since the name of the type is part of the name of the target language
% variable holding the type_ctor_info, it helps if it does not contain
% nonalphanumeric characters.
TypeName = "tuple",
TypeSymName = qualified(ModuleSymName, _TypeName),
ModuleSymName = mercury_public_builtin_module,
Arity = 0,
TypeCategory = ctor_cat_tuple
;
TypeName = "{}",
TypeSymName = unqualified(_TypeName),
% The arity may be anything.
TypeCategory = ctor_cat_tuple
).
classify_type_defn_body(TypeBody) = TypeCategory :-
% Unlike classify_type_ctor, we don't have to (a) test for types that do
% not have definitions, or (b) look up the definition, since our caller has
% already done that.
% XXX Why don't we have a category for solver types?
% XXX Why do we classify abstract_enum_types as general?
(
TypeBody = hlds_du_type(TypeBodyDu),
TypeBodyDu = type_body_du(_, _, _, _, MaybeTypeRepn, _),
(
MaybeTypeRepn = no,
unexpected($pred, "MaybeTypeRepn = no")
;
MaybeTypeRepn = yes(Repn)
),
DuTypeKind = Repn ^ dur_kind,
(
DuTypeKind = du_type_kind_mercury_enum,
TypeCategory = ctor_cat_enum(cat_enum_mercury)
;
DuTypeKind = du_type_kind_foreign_enum(_),
TypeCategory = ctor_cat_enum(cat_enum_foreign)
;
DuTypeKind = du_type_kind_direct_dummy,
TypeCategory = ctor_cat_user(cat_user_direct_dummy)
;
DuTypeKind = du_type_kind_notag(_, _, _),
TypeCategory = ctor_cat_user(cat_user_notag)
;
DuTypeKind = du_type_kind_general,
TypeCategory = ctor_cat_user(cat_user_general)
)
;
TypeBody = hlds_abstract_type(AbstractDetails),
(
( AbstractDetails = abstract_type_general
; AbstractDetails = abstract_type_fits_in_n_bits(_)
; AbstractDetails = abstract_subtype(_)
; AbstractDetails = abstract_solver_type
),
TypeCategory = ctor_cat_user(cat_user_general)
;
AbstractDetails = abstract_dummy_type,
TypeCategory = ctor_cat_user(cat_user_abstract_dummy)
;
AbstractDetails = abstract_notag_type,
TypeCategory = ctor_cat_user(cat_user_abstract_notag)
)
;
% XXX We should be able to return more precise descriptions
% than this.
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_)
),
TypeCategory = ctor_cat_user(cat_user_general)
).
%-----------------------------------------------------------------------------%
type_may_use_atomic_alloc(ModuleInfo, Type) = TypeMayUseAtomic :-
TypeCategory = classify_type(ModuleInfo, Type),
(
TypeCategory = ctor_cat_builtin(cat_builtin_int(IntType)),
(
( IntType = int_type_int
; IntType = int_type_uint
; IntType = int_type_int8
; IntType = int_type_uint8
; IntType = int_type_int16
; IntType = int_type_uint16
; IntType = int_type_int32
; IntType = int_type_uint32
),
TypeMayUseAtomic = may_use_atomic_alloc
;
( IntType = int_type_int64
; IntType = int_type_uint64
),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, unboxed_int64s, UBI64),
(
UBI64 = yes,
TypeMayUseAtomic = may_use_atomic_alloc
;
UBI64 = no,
TypeMayUseAtomic = may_not_use_atomic_alloc
)
)
;
( TypeCategory = ctor_cat_builtin(cat_builtin_char)
; TypeCategory = ctor_cat_enum(_)
; TypeCategory = ctor_cat_builtin_dummy
; TypeCategory = ctor_cat_system(cat_system_type_ctor_info)
),
TypeMayUseAtomic = may_use_atomic_alloc
;
TypeCategory = ctor_cat_builtin(cat_builtin_float),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, unboxed_float, UBF),
(
UBF = yes,
TypeMayUseAtomic = may_use_atomic_alloc
;
UBF = no,
TypeMayUseAtomic = may_not_use_atomic_alloc
)
;
( TypeCategory = ctor_cat_builtin(cat_builtin_string)
; TypeCategory = ctor_cat_higher_order
; TypeCategory = ctor_cat_tuple
; TypeCategory = ctor_cat_variable
; TypeCategory = ctor_cat_system(cat_system_type_info)
; TypeCategory = ctor_cat_system(cat_system_typeclass_info)
; TypeCategory = ctor_cat_system(cat_system_base_typeclass_info)
; TypeCategory = ctor_cat_void
; TypeCategory = ctor_cat_user(_) % for direct_dummy, alloc is moot
),
TypeMayUseAtomic = may_not_use_atomic_alloc
).
update_type_may_use_atomic_alloc(ModuleInfo, Type, !MayUseAtomic) :-
(
!.MayUseAtomic = may_not_use_atomic_alloc
% There is no point in testing Type.
;
!.MayUseAtomic = may_use_atomic_alloc,
!:MayUseAtomic = type_may_use_atomic_alloc(ModuleInfo, Type)
).
%-----------------------------------------------------------------------------%
type_constructors(ModuleInfo, Type, Constructors) :-
type_to_ctor_and_args(Type, TypeCtor, ArgTypes),
( if type_ctor_is_tuple(TypeCtor) then
% Tuples are never existentially typed.
MaybeExistConstraints = no_exist_constraints,
Context = dummy_context,
CtorArgs = list.map(
(func(ArgType) = ctor_arg(no, ArgType, Context)),
ArgTypes),
Constructors = [ctor(0u32, MaybeExistConstraints, unqualified("{}"),
CtorArgs, list.length(CtorArgs), Context)]
else
module_info_get_type_table(ModuleInfo, TypeTable),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
TypeBody = hlds_du_type(TypeBodyDu),
substitute_type_args(TypeParams, ArgTypes,
one_or_more_to_list(TypeBodyDu ^ du_type_ctors),
Constructors)
).
% Substitute the actual values of the type parameters (for a
% particular instance of a polymorphic type) in the given list
% of constructors.
%
:- pred substitute_type_args(list(type_param)::in, list(mer_type)::in,
list(constructor)::in, list(constructor)::out) is det.
substitute_type_args(TypeParams, ArgTypes, Constructors0, Constructors) :-
(
TypeParams = [],
Constructors = Constructors0
;
TypeParams = [_ | _],
map.from_corresponding_lists(TypeParams, ArgTypes, Subst),
substitute_type_args_ctors(Subst, Constructors0, Constructors)
).
:- pred substitute_type_args_ctors(tsubst::in, list(constructor)::in,
list(constructor)::out) is det.
substitute_type_args_ctors(_, [], []).
substitute_type_args_ctors(Subst, [Ctor0 | Ctors0], [Ctor | Ctors]) :-
% Note: the parser ensures that the existentially quantified variables,
% if any, are distinct from the parameters, and that the (existential)
% constraints can only contain existentially quantified variables,
% so there is no need to worry about applying the substitution
% to ExistQVars or Constraints.
Ctor0 = ctor(Ordinal, MaybeExistConstraints, Name, Args0, Arity, Ctxt),
substitute_type_args_ctor_args(Subst, Args0, Args),
Ctor = ctor(Ordinal, MaybeExistConstraints, Name, Args, Arity, Ctxt),
substitute_type_args_ctors(Subst, Ctors0, Ctors).
:- pred substitute_type_args_ctor_args(tsubst::in, list(constructor_arg)::in,
list(constructor_arg)::out) is det.
substitute_type_args_ctor_args(_, [], []).
substitute_type_args_ctor_args(Subst, [Arg0 | Args0], [Arg | Args]) :-
apply_subst_to_type(Subst, Arg0 ^ arg_type, ArgType),
Arg = Arg0 ^ arg_type := ArgType,
substitute_type_args_ctor_args(Subst, Args0, Args).
%-----------------------------------------------------------------------------%
switch_type_num_functors(ModuleInfo, Type, NumFunctors) :-
type_to_ctor(Type, TypeCtor),
( if
TypeCtor = type_ctor(unqualified("character"), 0)
then
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
target_char_range(Target, MinChar, MaxChar),
NumFunctors = MaxChar - MinChar + 1
else if
% It's not worth bothering with the 32- and 64-bit integer types here
% -- a complete switch on any of those types would be so large that it
% would overwhelm the compiler anyway.
TypeCtor = type_ctor(unqualified(IntType), 0),
( IntType = "int8", NumFunctors0 = 256
; IntType = "uint8", NumFunctors0 = 256
; IntType = "int16", NumFunctors0 = 65536
; IntType = "uint16", NumFunctors0 = 65536
)
then
NumFunctors = NumFunctors0
else if
type_ctor_is_tuple(TypeCtor)
then
NumFunctors = 1
else
module_info_get_type_table(ModuleInfo, TypeTable),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
TypeBody = hlds_du_type(type_body_du(OoMConstructors, _, _, _, _, _)),
OoMConstructors = one_or_more(_HeadCtor, TailCtors),
NumFunctors = 1 + list.length(TailCtors)
).
%-----------------------------------------------------------------------------%
get_cons_id_arg_types(ModuleInfo, Type, ConsId, ArgTypes) :-
( if ConsId = du_data_ctor(DuCtor) then
get_du_ctor_arg_types(ModuleInfo, Type, DuCtor, ArgTypes)
else
( if
type_to_ctor_and_args(Type, TypeCtor, ArgTypesPrime),
type_ctor_is_tuple(TypeCtor)
then
% The argument types of a tuple cons_id are the arguments
% of the tuple type constructor.
ArgTypes = ArgTypesPrime
else
ArgTypes = []
)
).
get_du_ctor_arg_types(ModuleInfo, Type, DuCtor, ArgTypes) :-
get_user_data_arg_types_2(abort_on_exist_qvar, ModuleInfo, Type,
DuCtor, ArgTypes).
get_cons_id_non_existential_arg_types(ModuleInfo, Type, ConsId,
ArgTypes) :-
( if ConsId = du_data_ctor(DuCtor) then
get_du_ctor_non_existential_arg_types(ModuleInfo, Type,
DuCtor, ArgTypes)
else
( if
type_to_ctor_and_args(Type, TypeCtor, ArgTypesPrime),
type_ctor_is_tuple(TypeCtor)
then
% The argument types of a tuple cons_id are the arguments
% of the tuple type constructor. None of them can be
% existentially quantified.
ArgTypes = ArgTypesPrime
else
ArgTypes = []
)
).
get_du_ctor_non_existential_arg_types(ModuleInfo, Type, DuCtor,
ArgTypes) :-
get_user_data_arg_types_2(fail_on_exist_qvar, ModuleInfo, Type,
DuCtor, ArgTypes).
:- type exist_qvar_action
---> fail_on_exist_qvar
; abort_on_exist_qvar.
:- pred get_user_data_arg_types_2(exist_qvar_action, module_info, mer_type,
du_ctor, list(mer_type)).
:- mode get_user_data_arg_types_2(in(bound(fail_on_exist_qvar)), in, in,
in, out) is semidet.
:- mode get_user_data_arg_types_2(in(bound(abort_on_exist_qvar)), in, in,
in, out) is det.
get_user_data_arg_types_2(EQVarAction, ModuleInfo, Type, DuCtor,
ArgTypes) :-
( if type_to_ctor_and_args(Type, TypeCtor, TypeArgs) then
( if
get_cons_defn(ModuleInfo, TypeCtor, DuCtor, ConsDefn),
ConsDefn = hlds_cons_defn(_, _, TypeParams, _,
MaybeExistConstraints0, Args, _),
Args = [_ | _]
then
(
MaybeExistConstraints0 = no_exist_constraints
;
MaybeExistConstraints0 = exist_constraints(_ExistConstraints),
% XXX handle _ExistConstraints
(
EQVarAction = abort_on_exist_qvar,
unexpected($pred, "existentially typed cons_id")
;
EQVarAction = fail_on_exist_qvar,
fail
)
),
map.from_corresponding_lists(TypeParams, TypeArgs, TSubst),
ArgTypes0 = list.map(func(C) = C ^ arg_type, Args),
apply_subst_to_types(TSubst, ArgTypes0, ArgTypes)
else
ArgTypes = []
)
else
ArgTypes = []
).
all_du_ctor_arg_types(ModuleInfo, Type, NamesAritiesArgTypes) :-
( if
type_to_ctor_and_args(Type, TypeCtor, TypeCtorArgTypes),
module_info_get_type_table(ModuleInfo, TypeTable),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
TypeDefnBody = hlds_du_type(TypeBodyDu)
then
get_type_defn_tparams(TypeDefn, TypeParams),
TypeBodyDu = type_body_du(OoMCtors, _, _, _, _, _),
Ctors = one_or_more_to_list(OoMCtors),
list.filter_map(get_user_ctor_arg_types(TypeParams, TypeCtorArgTypes),
Ctors, NamesAritiesArgTypes)
else
NamesAritiesArgTypes = []
).
:- pred get_user_ctor_arg_types(list(type_param)::in,
list(mer_type)::in, constructor::in,
{string, arity, list(mer_type)}::out) is semidet.
get_user_ctor_arg_types(TypeParams, TypeCtorArgTypes, Ctor,
{Name, Arity, CtorArgTypes}) :-
Ctor = ctor(_Ordinal, MaybeExistConstraints, SymName, CtorArgs,
Arity, _Ctxt),
% XXX handle ExistConstraints
MaybeExistConstraints = no_exist_constraints,
map.from_corresponding_lists(TypeParams, TypeCtorArgTypes, TSubst),
CtorArgTypes0 = list.map(func(C) = C ^ arg_type, CtorArgs),
apply_subst_to_types(TSubst, CtorArgTypes0, CtorArgTypes),
Name = unqualify_name(SymName).
type_is_du_type(ModuleInfo, Type, TypeDefn, TypeBodyDu) :-
module_info_get_type_table(ModuleInfo, TypeTable),
type_to_ctor(Type, TypeCtor),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
TypeDefnBody = hlds_du_type(TypeBodyDu).
get_cons_defn(ModuleInfo, TypeCtor, DuCtor, ConsDefn) :-
module_info_get_cons_table(ModuleInfo, Ctors),
% This search will fail for builtin cons_ids.
search_cons_table_of_type_ctor(Ctors, TypeCtor, DuCtor, ConsDefn).
get_cons_defn_det(ModuleInfo, TypeCtor, DuCtor, ConsDefn) :-
( if get_cons_defn(ModuleInfo, TypeCtor, DuCtor, ConsDefnPrime) then
ConsDefn = ConsDefnPrime
else
unexpected($pred, "get_cons_defn failed")
).
get_cons_repn_defn(ModuleInfo, DuCtor, UserDataCTorConsRepn) :-
DuCtor = du_ctor(ConsSymName, ConsArity, TypeCtor),
module_info_get_type_table(ModuleInfo, TypeTable),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
get_type_defn_body(TypeDefn, TypeBody),
TypeBody = hlds_du_type(type_body_du(_, _, _, _, MaybeRepn, _)),
MaybeRepn = yes(Repn),
Repn = du_type_repn(_, ConsRepnMap, _, _, _),
ConsName = unqualify_name(ConsSymName),
map.search(ConsRepnMap, ConsName, MatchingConsRepns),
MatchingConsRepns = one_or_more(HeadConsRepn, TailConsRepns),
find_cons_repn_with_given_arity(ConsArity, HeadConsRepn, TailConsRepns,
UserDataCTorConsRepn).
:- pred find_cons_repn_with_given_arity(arity::in,
constructor_repn::in, list(constructor_repn)::in,
constructor_repn::out) is semidet.
find_cons_repn_with_given_arity(ConsArity,
HeadConsRepn, TailConsRepns, DuCtorConsRepn) :-
( if ConsArity = HeadConsRepn ^ cr_num_args then
DuCtorConsRepn = HeadConsRepn
else
TailConsRepns = [HeadTailConsRepn | TailTailConsRepns],
find_cons_repn_with_given_arity(ConsArity,
HeadTailConsRepn, TailTailConsRepns, DuCtorConsRepn)
).
get_cons_repn_defn_det(ModuleInfo, DuCtor, ConsRepnDefn) :-
( if get_cons_repn_defn(ModuleInfo, DuCtor, ConsRepnDefnPrime) then
ConsRepnDefn = ConsRepnDefnPrime
else
unexpected($pred, "get_cons_repn_defn failed")
).
get_cons_id_repn_defn_det(ModuleInfo, ConsId, ConsRepnDefn) :-
( if
ConsId = du_data_ctor(DuCtor),
get_cons_repn_defn(ModuleInfo, DuCtor, ConsRepnDefnPrime)
then
ConsRepnDefn = ConsRepnDefnPrime
else
unexpected($pred, "get_cons_repn_defn failed")
).
get_existq_cons_defn(ModuleInfo, Type, ConsId, CtorDefn) :-
cons_id_is_existq_cons_return_defn(ModuleInfo, Type, ConsId, ConsDefn),
ConsDefn = hlds_cons_defn(_TypeCtor, TypeVarSet, TypeParams, KindMap,
MaybeExistConstraints, Args, _Context),
ArgTypes = list.map(func(C) = C ^ arg_type, Args),
prog_type.var_list_to_type_list(KindMap, TypeParams, TypeCtorArgs),
type_to_ctor(Type, TypeCtor),
construct_type(TypeCtor, TypeCtorArgs, RetType),
CtorDefn = ctor_defn(TypeVarSet, KindMap, MaybeExistConstraints,
ArgTypes, RetType).
cons_id_is_existq_cons(ModuleInfo, Type, ConsId) :-
cons_id_is_existq_cons_return_defn(ModuleInfo, Type, ConsId, _).
:- pred cons_id_is_existq_cons_return_defn(module_info::in, mer_type::in,
du_ctor::in, hlds_cons_defn::out) is semidet.
cons_id_is_existq_cons_return_defn(ModuleInfo, Type, ConsId, ConsDefn) :-
type_to_ctor(Type, TypeCtor),
get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn),
ConsDefn ^ cons_maybe_exist = exist_constraints(_).
%-----------------------------------------------------------------------------%
type_is_no_tag_type(ModuleInfo, Type) :-
type_is_no_tag_type(ModuleInfo, Type, _Ctor, _ArgType).
type_is_no_tag_type(ModuleInfo, Type, Ctor, ArgType) :-
type_to_ctor_and_args(Type, TypeCtor, ArgTypes),
module_info_get_no_tag_types(ModuleInfo, NoTagTypes),
map.search(NoTagTypes, TypeCtor, NoTagType),
NoTagType = no_tag_type(TypeParams, Ctor, ArgType0),
(
TypeParams = [],
ArgType = ArgType0
;
TypeParams = [_ | _],
map.from_corresponding_lists(TypeParams, ArgTypes, Subn),
apply_subst_to_type(Subn, ArgType0, ArgType)
).
%-----------------------------------------------------------------------------%
du_ctor_adjusted_arity(ModuleInfo, Type, DuCtor) = AdjustedArity :-
% Figure out the arity of this constructor, _including_ any type-infos
% or typeclass-infos inserted for existential data types.
DuCtor = du_ctor(_, ConsArity, _),
( if get_existq_cons_defn(ModuleInfo, Type, DuCtor, ConsDefn) then
ConsDefn = ctor_defn(_TVarSet, _KindMap, MaybeExistConstraints,
_ArgTypes, _ResultType),
(
MaybeExistConstraints = exist_constraints(ExistConstraints),
ExistConstraints = cons_exist_constraints(ExistQTVars, Constraints,
UnconstrainedExistQTVarsEC, _ConstrainedExistQTVars),
list.length(Constraints, NumTypeClassInfos),
list.length(UnconstrainedExistQTVarsEC,
NumUnconstrainedExistQTVarsEC),
constraint_list_get_tvars(Constraints, ConstrainedTVars),
list.delete_elems(ExistQTVars, ConstrainedTVars,
UnconstrainedExistQTVars),
list.length(UnconstrainedExistQTVars, NumTypeInfos),
AdjustedArity = NumTypeInfos + NumTypeClassInfos + ConsArity,
% XXX ARG_PACK Sanity check.
expect(unify(NumTypeInfos, NumUnconstrainedExistQTVarsEC), $pred,
"NumTypeInfos != NumUnconstrainedExistQTVars")
;
MaybeExistConstraints = no_exist_constraints,
AdjustedArity = ConsArity
)
else
AdjustedArity = ConsArity
).
%-----------------------------------------------------------------------------%
type_not_stored_in_region(Type, ModuleInfo) :-
( type_is_atomic(ModuleInfo, Type)
; is_type_a_dummy(ModuleInfo, Type) = is_dummy_type
; Type = type_info_type
; Type = type_ctor_info_type
; type_is_var(Type)
).
is_region_var(VarTable, Var) :-
lookup_var_entry(VarTable, Var, Entry),
Entry ^ vte_type = region_type.
%-----------------------------------------------------------------------------%
put_typeinfo_vars_first(VarTable, Vars0) = Vars :-
split_vars_typeinfo_no_typeinfo(VarTable, Vars0,
TypeInfoVars, NonTypeInfoVars),
Vars = TypeInfoVars ++ NonTypeInfoVars.
remove_typeinfo_vars(VarTable, Vars) = NonTypeInfoVars :-
list.negated_filter(var_is_introduced_type_info_type(VarTable),
Vars, NonTypeInfoVars).
remove_typeinfo_vars_from_set(VarTable, VarsSet0) = VarsSet :-
VarsList0 = set.to_sorted_list(VarsSet0),
VarsList = remove_typeinfo_vars(VarTable, VarsList0),
VarsSet = set.sorted_list_to_set(VarsList).
remove_typeinfo_vars_from_set_of_var(VarTable, VarsSet0) = VarsSet :-
% XXX could be done more efficiently, operating directly on the set_of_var
VarsList0 = set_of_var.to_sorted_list(VarsSet0),
VarsList = remove_typeinfo_vars(VarTable, VarsList0),
VarsSet = set_of_var.sorted_list_to_set(VarsList).
:- pred split_vars_typeinfo_no_typeinfo(var_table::in,
list(prog_var)::in, list(prog_var)::out, list(prog_var)::out) is det.
split_vars_typeinfo_no_typeinfo(VarTable, Vars,
TypeInfoVars, NonTypeInfoVars) :-
list.filter(var_is_introduced_type_info_type(VarTable),
Vars, TypeInfoVars, NonTypeInfoVars).
:- pred var_is_introduced_type_info_type(var_table::in, prog_var::in)
is semidet.
var_is_introduced_type_info_type(VarTable, Var) :-
lookup_var_entry(VarTable, Var, Entry),
Type = Entry ^ vte_type,
is_introduced_type_info_type(Type).
%-----------------------------------------------------------------------------%
apply_renaming_to_constraint(Renaming, !Constraint) :-
!.Constraint = hlds_constraint(Ids, ClassName, ArgTypes0),
apply_renaming_to_types(Renaming, ArgTypes0, ArgTypes),
!:Constraint = hlds_constraint(Ids, ClassName, ArgTypes).
apply_subst_to_constraint(Subst, !Constraint) :-
!.Constraint = hlds_constraint(Ids, ClassName, ArgTypes0),
apply_subst_to_types(Subst, ArgTypes0, ArgTypes),
!:Constraint = hlds_constraint(Ids, ClassName, ArgTypes).
apply_rec_subst_to_constraint(Subst, !Constraint) :-
!.Constraint = hlds_constraint(Ids, ClassName, ArgTypes0),
apply_rec_subst_to_types(Subst, ArgTypes0, ArgTypes),
!:Constraint = hlds_constraint(Ids, ClassName, ArgTypes).
%-----------------------------------------------------------------------------%
apply_renaming_to_constraints(Renaming, !Constraints) :-
list.map(apply_renaming_to_constraint(Renaming), !Constraints).
apply_subst_to_constraints(Subst, !Constraints) :-
list.map(apply_subst_to_constraint(Subst), !Constraints).
apply_rec_subst_to_constraints(Subst, !Constraints) :-
list.map(apply_rec_subst_to_constraint(Subst), !Constraints).
%-----------------------------------------------------------------------------%
apply_renaming_to_constraint_db(Renaming, !ConstraintDb) :-
!.ConstraintDb = hlds_constraint_db(Unproven0, Assumed0,
Redundant0, Ancestors0),
% Most of the time, !.Constraints contains nothing. Even when some
% of its fields are not empty, some others may be.
( if
Unproven0 = [],
Assumed0 = [],
map.is_empty(Redundant0),
map.is_empty(Ancestors0)
then
true
else
apply_renaming_to_constraints(Renaming, Unproven0, Unproven),
apply_renaming_to_constraints(Renaming, Assumed0, Assumed),
( if map.is_empty(Redundant0) then
Redundant = Redundant0
else
Pred =
( pred(C0::in, C::out) is det :-
set.to_sorted_list(C0, L0),
apply_renaming_to_constraints(Renaming, L0, L),
set.list_to_set(L, C)
),
map.map_values_only(Pred, Redundant0, Redundant)
),
( if map.is_empty(Ancestors0) then
Ancestors = Ancestors0
else
map.keys(Ancestors0, AncestorsKeys0),
map.values(Ancestors0, AncestorsValues0),
apply_renaming_to_prog_constraints(Renaming,
AncestorsKeys0, AncestorsKeys),
list.map(apply_renaming_to_prog_constraints(Renaming),
AncestorsValues0, AncestorsValues),
map.from_corresponding_lists(AncestorsKeys, AncestorsValues,
Ancestors)
),
!:ConstraintDb =
hlds_constraint_db(Unproven, Assumed, Redundant, Ancestors)
).
apply_subst_to_constraint_db(Subst, !ConstraintDb) :-
!.ConstraintDb = hlds_constraint_db(Unproven0, Assumed0,
Redundant0, Ancestors0),
apply_subst_to_constraints(Subst, Unproven0, Unproven),
apply_subst_to_constraints(Subst, Assumed0, Assumed),
Pred =
( pred(C0::in, C::out) is det :-
set.to_sorted_list(C0, L0),
apply_subst_to_constraints(Subst, L0, L),
set.list_to_set(L, C)
),
map.map_values_only(Pred, Redundant0, Redundant),
map.keys(Ancestors0, AncestorsKeys0),
map.values(Ancestors0, AncestorsValues0),
apply_subst_to_prog_constraints(Subst, AncestorsKeys0, AncestorsKeys),
list.map(apply_subst_to_prog_constraints(Subst),
AncestorsValues0, AncestorsValues),
map.from_corresponding_lists(AncestorsKeys, AncestorsValues, Ancestors),
!:ConstraintDb = hlds_constraint_db(Unproven, Assumed,
Redundant, Ancestors).
apply_rec_subst_to_constraint_db(Subst, !ConstraintDb) :-
!.ConstraintDb = hlds_constraint_db(Unproven0, Assumed0,
Redundant0, Ancestors0),
apply_rec_subst_to_constraints(Subst, Unproven0, Unproven),
apply_rec_subst_to_constraints(Subst, Assumed0, Assumed),
Pred =
( pred(C0::in, C::out) is det :-
set.to_sorted_list(C0, L0),
apply_rec_subst_to_constraints(Subst, L0, L),
set.list_to_set(L, C)
),
map.map_values_only(Pred, Redundant0, Redundant),
map.keys(Ancestors0, AncestorsKeys0),
map.values(Ancestors0, AncestorsValues0),
apply_rec_subst_to_prog_constraints(Subst, AncestorsKeys0, AncestorsKeys),
list.map(apply_rec_subst_to_prog_constraints(Subst),
AncestorsValues0, AncestorsValues),
map.from_corresponding_lists(AncestorsKeys, AncestorsValues, Ancestors),
!:ConstraintDb = hlds_constraint_db(Unproven, Assumed,
Redundant, Ancestors).
%-----------------------------------------------------------------------------%
apply_renaming_to_constraint_proof_map(Renaming,
ProofMap0, ProofMap) :-
( if map.is_empty(ProofMap0) then
% Optimize the simple case.
ProofMap = ProofMap0
else
map.keys(ProofMap0, Keys0),
map.values(ProofMap0, Values0),
apply_renaming_to_prog_constraints(Renaming, Keys0, Keys),
list.map(rename_constraint_proof(Renaming), Values0, Values),
map.from_corresponding_lists(Keys, Values, ProofMap)
).
% Apply a type variable renaming to a class constraint proof.
%
:- pred rename_constraint_proof(tvar_renaming::in,
constraint_proof::in, constraint_proof::out) is det.
rename_constraint_proof(TSubst, Proof0, Proof) :-
(
Proof0 = apply_instance(_Num),
Proof = Proof0
;
Proof0 = superclass(ClassConstraint0),
apply_renaming_to_prog_constraint(TSubst,
ClassConstraint0, ClassConstraint),
Proof = superclass(ClassConstraint)
).
apply_subst_to_constraint_proof_map(Subst, ProofMap0, ProofMap) :-
map.foldl(apply_subst_to_constraint_proof_map_2(Subst), ProofMap0,
map.init, ProofMap).
:- pred apply_subst_to_constraint_proof_map_2(tsubst::in,
prog_constraint::in, constraint_proof::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
apply_subst_to_constraint_proof_map_2(Subst, Constraint0, Proof0, !ProofMap) :-
apply_subst_to_prog_constraint(Subst, Constraint0, Constraint),
(
Proof0 = apply_instance(_),
Proof = Proof0
;
Proof0 = superclass(Super0),
apply_subst_to_prog_constraint(Subst, Super0, Super),
Proof = superclass(Super)
),
map.set(Constraint, Proof, !ProofMap).
apply_rec_subst_to_constraint_proof_map(Subst, ProofMap0, ProofMap) :-
map.foldl(apply_rec_subst_to_constraint_proof_map_2(Subst), ProofMap0,
map.init, ProofMap).
:- pred apply_rec_subst_to_constraint_proof_map_2(tsubst::in,
prog_constraint::in, constraint_proof::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
apply_rec_subst_to_constraint_proof_map_2(Subst, Constraint0, Proof0,
!ProofMap) :-
apply_rec_subst_to_prog_constraint(Subst, Constraint0, Constraint),
(
Proof0 = apply_instance(_),
Proof = Proof0
;
Proof0 = superclass(Super0),
apply_rec_subst_to_prog_constraint(Subst, Super0, Super),
Proof = superclass(Super)
),
map.set(Constraint, Proof, !ProofMap).
%-----------------------------------------------------------------------------%
apply_renaming_to_constraint_map(Renaming, !ConstraintMap) :-
map.map_values_only(apply_renaming_to_prog_constraint(Renaming),
!ConstraintMap).
apply_subst_to_constraint_map(Subst, !ConstraintMap) :-
map.map_values_only(apply_subst_to_prog_constraint(Subst), !ConstraintMap).
apply_rec_subst_to_constraint_map(Subst, !ConstraintMap) :-
map.map_values_only(apply_rec_subst_to_prog_constraint(Subst),
!ConstraintMap).
%-----------------------------------------------------------------------------%
:- end_module hlds.type_util.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink