mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-14 21:35:49 +00:00
Code Issues Projects Releases Wiki Activity
Files
1c3bc03415740d648e99d0a34389767d76f8808a
mercury/compiler/type_util.m
Zoltan Somogyi 8a28e40c9b Add the predicates sorry, unexpected and expect to library/error.m. 
Estimated hours taken: 2
Branches: main

Add the predicates sorry, unexpected and expect to library/error.m.

compiler/compiler_util.m:
library/error.m:
	Move the predicates sorry, unexpected and expect from compiler_util
	to error.

	Put the predicates in error.m into the same order as their
	declarations.

compiler/*.m:
	Change imports as needed.

compiler/lp.m:
compiler/lp_rational.m:
	Change imports as needed, and some minor cleanups.

deep_profiler/*.m:
	Switch to using the new library predicates, instead of calling error
	directly. Some other minor cleanups.

NEWS:
	Mention the new predicates in the standard library.
2010-12-15 06:30:36 +00:00

1359 lines
52 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1994-2010 The University of Melbourne.
% 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,
% include the mode checker and the code generator.
%
%-----------------------------------------------------------------------------%
:- module check_hlds.type_util.
:- interface.
:- import_module hlds.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module list.
:- import_module maybe.
%-----------------------------------------------------------------------------%
% Given a type_ctor, look up its module/name/arity.
%
:- func type_ctor_module(module_info, type_ctor) = module_name.
:- func type_ctor_name(module_info, type_ctor) = string.
:- func type_ctor_arity(module_info, type_ctor) = arity.
% 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_body(module_info::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,
unify_compare::out) is semidet.
:- pred type_body_has_user_defined_equality_pred(module_info::in,
hlds_type_body::in, unify_compare::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 is_solver_var(vartypes::in, module_info::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_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.
% Succeeds if this type is a solver type that has an initialisation
% predicate specified by the user in the solver type definition.
%
:- pred type_is_solver_type_with_auto_init(module_info::in, mer_type::in)
is semidet.
:- pred is_solver_type(module_info::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.
% Succeeds iff one or more of the type constructors for a given
% type is existentially quantified.
%
:- pred is_existq_type(module_info::in, mer_type::in) is semidet.
:- type is_dummy_type
---> is_dummy_type
; is_not_dummy_type.
% 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.
%
% NOTE: changes here may require changes to
% `constructor_list_represents_dummy_argument_type'.
%
:- func check_dummy_type(module_info, mer_type) = is_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.
% 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'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 and on the builtin type character. It is not
% feasible to have a complete switch on the builtin types integer,
% 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.
% The same as get_cons_id_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.
% The same as get_cons_id_arg_types except that the cons_id is output
% non-deterministically. The cons_id is not module-qualified.
%
:- pred cons_id_arg_types(module_info::in, mer_type::in,
cons_id::out, list(mer_type)::out) is nondet.
% Given a type constructor and one of its cons_ids, look up the definition
% of that cons_id. Aborts 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.
%
:- pred get_cons_defn(module_info::in, type_ctor::in, cons_id::in,
hlds_cons_defn::out) is semidet.
:- pred get_cons_defn_det(module_info::in, type_ctor::in, cons_id::in,
hlds_cons_defn::out) is det.
% 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, cons_id::in,
ctor_defn::out) is semidet.
:- pred is_existq_cons(module_info::in, mer_type::in, cons_id::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.
% cons_id_adjusted_arity(ModuleInfo, Type, ConsId):
%
% Returns the number of arguments of specified constructor id, adjusted
% to include the extra typeclassinfo and typeinfo arguments inserted
% by polymorphism.m for existentially typed constructors.
%
:- func cons_id_adjusted_arity(module_info, mer_type, cons_id) = 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.
%-----------------------------------------------------------------------------%
% If possible, get the argument types for the cons_id. We need to pass in
% the arity rather than using the arity from the cons_id because the arity
% in the cons_id will not include any extra type_info arguments for
% existentially quantified types.
%
:- pred maybe_get_cons_id_arg_types(module_info::in, maybe(mer_type)::in,
cons_id::in, arity::in, list(maybe(mer_type))::out) is det.
:- pred maybe_get_higher_order_arg_types(maybe(mer_type)::in, arity::in,
list(maybe(mer_type))::out) is det.
%-----------------------------------------------------------------------------%
%
% Predicates for doing renamings and substitutions on HLDS data structures.
%
:- pred apply_variable_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_variable_renaming_to_constraint_list(tvar_renaming::in,
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
:- pred apply_subst_to_constraint_list(tsubst::in, list(hlds_constraint)::in,
list(hlds_constraint)::out) is det.
:- pred apply_rec_subst_to_constraint_list(tsubst::in,
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
%-------------%
:- pred apply_variable_renaming_to_constraints(tvar_renaming::in,
hlds_constraints::in, hlds_constraints::out) is det.
:- pred apply_subst_to_constraints(tsubst::in, hlds_constraints::in,
hlds_constraints::out) is det.
:- pred apply_rec_subst_to_constraints(tsubst::in, hlds_constraints::in,
hlds_constraints::out) is det.
%-------------%
:- pred apply_variable_renaming_to_constraint_proofs(tvar_renaming::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
:- pred apply_subst_to_constraint_proofs(tsubst::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
:- pred apply_rec_subst_to_constraint_proofs(tsubst::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
%-------------%
:- pred apply_variable_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 libs.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_util.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
:- import_module bool.
:- import_module char.
:- import_module int.
:- import_module map.
:- import_module require.
:- import_module set.
:- import_module svset.
:- import_module term.
%-----------------------------------------------------------------------------%
type_ctor_module(_ModuleInfo, type_ctor(TypeSymName, _Arity)) = ModuleName :-
sym_name_get_module_name_default(TypeSymName, unqualified(""), ModuleName).
type_ctor_name(_ModuleInfo, type_ctor(TypeSymName, _Arity)) =
unqualify_name(TypeSymName).
type_ctor_arity(_ModuleInfo, type_ctor(_Name, Arity)) = Arity.
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_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_general)
),
IsAtomic = no
).
type_to_type_defn(ModuleInfo, Type, TypeDefn) :-
module_info_get_type_table(ModuleInfo, TypeTable),
type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
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_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, UserEqComp) :-
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
(
TypeBody = hlds_du_type(_, _, _, _, _, _, _, _),
(
TypeBody ^ du_type_is_foreign_type = yes(ForeignTypeBody),
have_foreign_type_for_backend(Target, ForeignTypeBody, yes)
->
foreign_type_body_has_user_defined_eq_comp_pred(
ModuleInfo, ForeignTypeBody, UserEqComp)
;
TypeBody ^ du_type_usereq = yes(UserEqComp)
)
;
TypeBody = hlds_foreign_type(ForeignTypeBody),
foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo,
ForeignTypeBody, UserEqComp)
;
TypeBody = hlds_solver_type(_SolverTypeDetails, yes(UserEqComp))
).
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
svset.insert(Type, !SeenTypes),
(
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)
)
).
:- 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(_, _, _, _, _, _, _, _),
(
TypeBody ^ du_type_is_foreign_type = yes(ForeignTypeBody),
have_foreign_type_for_backend(Target, ForeignTypeBody, yes)
->
not foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo,
ForeignTypeBody, _)
;
TypeBody ^ du_type_usereq = no,
% 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(_, no)
;
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([], _, _, 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).
is_solver_var(VarTypes, ModuleInfo, Var) :-
map.lookup(VarTypes, Var, VarType),
type_is_solver_type(ModuleInfo, VarType).
type_is_solver_type_with_auto_init(ModuleInfo, Type) :-
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
(
TypeBody = hlds_solver_type(_, _),
ActualType = Type
;
% XXX the current implementation doesn't provide enough information
% to determine whether abstract solver types support automatic
% initialisation or not. In the absence of such information we
% assume that they do not. Since we don't officially support
% automatic initialisation anyway this shouldn't be too much of a
% problem. (In the event that we do re-add some form of support for
% automatic solver initialisation then we will need to make sure
% that this information ends up in interface files somehow.)
TypeBody = hlds_abstract_type(solver_type),
fail
;
TypeBody = hlds_eqv_type(ActualType)
),
type_has_solver_type_details(ModuleInfo, ActualType, SolverTypeDetails),
SolverTypeDetails ^ std_init_pred = solver_init_automatic(_).
type_is_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(solver_type)
;
TypeBody = hlds_eqv_type(EqvType),
type_is_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) :-
(
Type = hlds_solver_type(SolverTypeDetails, _MaybeUserEqComp)
;
Type = hlds_eqv_type(EqvType),
type_has_solver_type_details(ModuleInfo, EqvType, SolverTypeDetails)
).
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_body_is_solver_type(ModuleInfo, TypeBody) :-
(
TypeBody = hlds_solver_type(_, _)
;
TypeBody = hlds_abstract_type(solver_type)
;
TypeBody = hlds_eqv_type(Type),
is_solver_type(ModuleInfo, Type)
).
is_existq_type(ModuleInfo, Type) :-
type_constructors(ModuleInfo, Type, Constructors),
some [Constructor] (
list.member(Constructor, Constructors),
Constructor ^ cons_exist = [_ | _]
).
check_dummy_type(ModuleInfo, Type) =
check_dummy_type_2(ModuleInfo, Type, []).
:- func check_dummy_type_2(module_info, mer_type, list(mer_type))
= is_dummy_type.
check_dummy_type_2(ModuleInfo, Type, CoveredTypes) = IsDummy :-
% Since the sizes of types in any given program is bounded, this test
% will ensure termination.
( list.member(Type, CoveredTypes) ->
% The type is circular.
IsDummy = is_not_dummy_type
; type_to_ctor_and_args(Type, TypeCtor, ArgTypes) ->
% Keep this in sync with is_dummy_argument_type_with_constructors
% above.
IsBuiltinDummy = check_builtin_dummy_type_ctor(TypeCtor),
(
IsBuiltinDummy = is_builtin_dummy_type_ctor,
IsDummy = is_dummy_type
;
IsBuiltinDummy = is_not_builtin_dummy_type_ctor,
module_info_get_type_table(ModuleInfo, TypeTable),
% This can fail for some builtin type constructors such as func,
% pred, and tuple, none of which are dummy types.
( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn)->
get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
(
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 = check_dummy_type_2(ModuleInfo, SingleArgType,
[Type | CoveredTypes])
)
;
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_, _)
; TypeBody = hlds_abstract_type(_)
),
IsDummy = is_not_dummy_type
)
;
IsDummy = is_not_dummy_type
)
)
;
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"
),
\+ ( Body = hlds_du_type(_, _, _, _, _, _, _, yes(_))
; Body = hlds_foreign_type(_)
; Body = hlds_solver_type(_, _)
).
%-----------------------------------------------------------------------------%
classify_type(ModuleInfo, VarType) = TypeCategory :-
( type_to_ctor(VarType, TypeCtor) ->
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
;
TypeCategory = ctor_cat_variable
).
classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
% Please keep the code of this predicate in sync with the code of
% classify_type_ctor_and_defn.
TypeCtor = type_ctor(TypeSymName, Arity),
(
TypeSymName = unqualified(TypeName),
Arity = 0,
(
TypeName = "character",
TypeCategoryPrime = ctor_cat_builtin(cat_builtin_char)
;
TypeName = "int",
TypeCategoryPrime = ctor_cat_builtin(cat_builtin_int)
;
TypeName = "float",
TypeCategoryPrime = ctor_cat_builtin(cat_builtin_float)
;
TypeName = "string",
TypeCategoryPrime = ctor_cat_builtin(cat_builtin_string)
;
TypeName = "void",
TypeCategoryPrime = ctor_cat_void
)
->
TypeCategory = TypeCategoryPrime
;
TypeSymName = qualified(ModuleSymName, TypeName),
ModuleSymName = mercury_public_builtin_module,
Arity = 0,
(
TypeName = "pred",
TypeCategoryPrime = ctor_cat_higher_order
;
TypeName = "func",
TypeCategoryPrime = ctor_cat_higher_order
;
TypeName = "tuple",
TypeCategoryPrime = ctor_cat_tuple
;
TypeName = "void",
TypeCategoryPrime = ctor_cat_void
)
->
TypeCategory = TypeCategoryPrime
;
TypeSymName = qualified(ModuleSymName, TypeName),
ModuleSymName = mercury_private_builtin_module,
Arity = 0,
(
TypeName = "type_info",
TypeCategoryPrime = ctor_cat_system(cat_system_type_info)
;
TypeName = "type_ctor_info",
TypeCategoryPrime = ctor_cat_system(cat_system_type_ctor_info)
;
TypeName = "typeclass_info",
TypeCategoryPrime = ctor_cat_system(cat_system_typeclass_info)
;
TypeName = "base_typeclass_info",
TypeCategoryPrime = ctor_cat_system(cat_system_base_typeclass_info)
)
->
TypeCategory = TypeCategoryPrime
;
check_builtin_dummy_type_ctor(TypeCtor) = is_builtin_dummy_type_ctor
->
TypeCategory = ctor_cat_builtin_dummy
;
type_ctor_is_higher_order(TypeCtor, _, _, _)
->
TypeCategory = ctor_cat_higher_order
;
type_ctor_is_tuple(TypeCtor)
->
TypeCategory = ctor_cat_tuple
;
module_info_get_type_table(ModuleInfo, TypeTable),
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
(
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)
)
;
% XXX We should be able to return more precise descriptions
% than this.
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_, _)
; TypeBody = hlds_abstract_type(_)
),
TypeCategory = ctor_cat_user(cat_user_general)
)
).
classify_type_defn_body(TypeBody) = TypeCategory :-
% Please keep the code of this predicate in sync with the code of
% classify_type_ctor.
%
% 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.
(
TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
(
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)
)
;
% XXX We should be able to return more precise descriptions
% than this.
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_, _)
; TypeBody = hlds_abstract_type(_)
),
TypeCategory = ctor_cat_user(cat_user_general)
).
%-----------------------------------------------------------------------------%
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_may_use_atomic_alloc(ModuleInfo, Type) = TypeMayUseAtomic :-
TypeCategory = classify_type(ModuleInfo, Type),
(
( TypeCategory = ctor_cat_builtin(cat_builtin_int)
; 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
).
%-----------------------------------------------------------------------------%
type_constructors(ModuleInfo, Type, Constructors) :-
type_to_ctor_and_args(Type, TypeCtor, TypeArgs),
( type_ctor_is_tuple(TypeCtor) ->
% Tuples are never existentially typed.
ExistQVars = [],
ClassConstraints = [],
Context = term.context_init,
CtorArgs = list.map(
(func(ArgType) = ctor_arg(no, ArgType, Context)), TypeArgs),
Constructors = [ctor(ExistQVars, ClassConstraints, unqualified("{}"),
CtorArgs, Context)]
;
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),
substitute_type_args(TypeParams, TypeArgs, TypeBody ^ du_type_ctors,
Constructors)
).
% Substitute the actual values of the type parameters in list of
% constructors, for a particular instance of a polymorphic type.
%
:- pred substitute_type_args(list(type_param)::in, list(mer_type)::in,
list(constructor)::in, list(constructor)::out) is det.
substitute_type_args(TypeParams, TypeArgs, Constructors0, Constructors) :-
(
TypeParams = [],
Constructors = Constructors0
;
TypeParams = [_ | _],
map.from_corresponding_lists(TypeParams, TypeArgs, Subst),
substitute_type_args_2(Subst, Constructors0, Constructors)
).
:- pred substitute_type_args_2(tsubst::in, list(constructor)::in,
list(constructor)::out) is det.
substitute_type_args_2(_, [], []).
substitute_type_args_2(Subst, [Ctor0 | Ctors0], [Ctor | Ctors]) :-
% Note: prog_io.m 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's no need to worry about applying the substitution to ExistQVars
% or Constraints.
Ctor0 = ctor(ExistQVars, Constraints, Name, Args0, Ctxt),
substitute_type_args_3(Subst, Args0, Args),
substitute_type_args_2(Subst, Ctors0, Ctors),
Ctor = ctor(ExistQVars, Constraints, Name, Args, Ctxt).
:- pred substitute_type_args_3(tsubst::in, list(constructor_arg)::in,
list(constructor_arg)::out) is det.
substitute_type_args_3(_, [], []).
substitute_type_args_3(Subst, [Arg0 | Args0], [Arg | Args]) :-
apply_subst_to_type(Subst, Arg0 ^ arg_type, ArgType),
Arg = Arg0 ^ arg_type := ArgType,
substitute_type_args_3(Subst, Args0, Args).
%-----------------------------------------------------------------------------%
switch_type_num_functors(ModuleInfo, Type, NumFunctors) :-
type_to_ctor_and_args(Type, TypeCtor, _),
( TypeCtor = type_ctor(unqualified("character"), 0) ->
% XXX The following code uses the source machine's character size,
% not the target's, so it won't work if cross-compiling to a machine
% with a different size character.
char.max_char_value(MaxChar),
char.min_char_value(MinChar),
NumFunctors = MaxChar - MinChar + 1
; type_ctor_is_tuple(TypeCtor) ->
NumFunctors = 1
;
module_info_get_type_table(ModuleInfo, TypeTable),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
map.count(TypeBody ^ du_type_cons_tag_values, NumFunctors)
).
%-----------------------------------------------------------------------------%
get_cons_id_arg_types(ModuleInfo, Type, ConsId, ArgTypes) :-
get_cons_id_arg_types_2(abort_on_exist_qvar, ModuleInfo, Type, ConsId,
ArgTypes).
get_cons_id_non_existential_arg_types(ModuleInfo, Type, ConsId, ArgTypes) :-
get_cons_id_arg_types_2(fail_on_exist_qvar, ModuleInfo, Type, ConsId,
ArgTypes).
:- type exist_qvar_action
---> fail_on_exist_qvar
; abort_on_exist_qvar.
:- pred get_cons_id_arg_types_2(exist_qvar_action, module_info, mer_type,
cons_id, list(mer_type)).
:- mode get_cons_id_arg_types_2(in(bound(fail_on_exist_qvar)), in, in,
in, out) is semidet.
:- mode get_cons_id_arg_types_2(in(bound(abort_on_exist_qvar)), in, in,
in, out) is det.
get_cons_id_arg_types_2(EQVarAction, ModuleInfo, VarType, ConsId, ArgTypes) :-
( type_to_ctor_and_args(VarType, TypeCtor, TypeArgs) ->
(
% The argument types of a tuple cons_id are the arguments
% of the tuple type.
type_ctor_is_tuple(TypeCtor)
->
ArgTypes = TypeArgs
;
get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn),
ConsDefn = hlds_cons_defn(_, _, TypeParams, _, ExistQVars0, _,
Args, _),
Args = [_ | _]
->
% XXX handle ExistQVars
(
ExistQVars0 = []
;
ExistQVars0 = [_ | _],
(
EQVarAction = abort_on_exist_qvar,
unexpected(this_file,
"get_cons_id_arg_types: 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_type_list(TSubst, ArgTypes0, ArgTypes)
;
ArgTypes = []
)
;
ArgTypes = []
).
cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :-
type_to_ctor_and_args(VarType, TypeCtor, TypeArgs),
module_info_get_type_table(ModuleInfo, TypeTable),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
map.member(TypeDefnBody ^ du_type_cons_tag_values, ConsId, _),
% XXX We should look it up in a type_ctor-specific table, not a global one.
module_info_get_cons_table(ModuleInfo, Ctors),
map.lookup(Ctors, ConsId, ConsDefns),
list.member(ConsDefn, ConsDefns),
ConsDefn = hlds_cons_defn(TypeCtor, _, TypeParams, _, ExistQVars0, _,
Args, _),
% XXX handle ExistQVars
ExistQVars0 = [],
map.from_corresponding_lists(TypeParams, TypeArgs, TSubst),
ArgTypes0 = list.map(func(C) = C ^ arg_type, Args),
apply_subst_to_type_list(TSubst, ArgTypes0, ArgTypes).
:- pred is_existq_cons(module_info::in, mer_type::in, cons_id::in,
hlds_cons_defn::out) is semidet.
is_existq_cons(ModuleInfo, VarType, ConsId) :-
is_existq_cons(ModuleInfo, VarType, ConsId, _).
get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn) :-
% XXX We should look it up in a type_ctor-specific table, not a global one.
module_info_get_cons_table(ModuleInfo, Ctors),
% will fail for builtin cons_ids.
map.search(Ctors, ConsId, ConsDefns),
MatchingCons =
(pred(ThisConsDefn::in) is semidet :-
ThisConsDefn ^ cons_type_ctor = TypeCtor
),
list.filter(MatchingCons, ConsDefns, [ConsDefn]).
get_cons_defn_det(ModuleInfo, TypeCtor, ConsId, ConsDefn) :-
( get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefnPrime) ->
ConsDefn = ConsDefnPrime
;
unexpected(this_file, "get_cons_defn_det: get_cons_defn failed")
).
get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :-
is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn),
ConsDefn = hlds_cons_defn(_TypeCtor, TypeVarSet, TypeParams, KindMap,
ExistQVars, Constraints, Args, _Context),
ArgTypes = list.map(func(C) = C ^ arg_type, Args),
prog_type.var_list_to_type_list(KindMap, TypeParams, TypeCtorArgs),
type_to_ctor_and_args(VarType, TypeCtor, _),
construct_type(TypeCtor, TypeCtorArgs, RetType),
CtorDefn = ctor_defn(TypeVarSet, ExistQVars, KindMap, Constraints,
ArgTypes, RetType).
is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn) :-
type_to_ctor_and_args(VarType, TypeCtor, _),
get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn),
ConsDefn ^ cons_exist_tvars = [_ | _].
%-----------------------------------------------------------------------------%
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, TypeArgs),
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, TypeArgs, Subn),
apply_subst_to_type(Subn, ArgType0, ArgType)
).
%-----------------------------------------------------------------------------%
cons_id_adjusted_arity(ModuleInfo, Type, ConsId) = AdjustedArity :-
% Figure out the arity of this constructor, _including_ any type-infos
% or typeclass-infos inserted for existential data types.
ConsArity = cons_id_arity(ConsId),
( get_existq_cons_defn(ModuleInfo, Type, ConsId, ConsDefn) ->
ConsDefn = ctor_defn(_TVarSet, ExistQTVars, _KindMap,
Constraints, _ArgTypes, _ResultType),
list.length(Constraints, NumTypeClassInfos),
constraint_list_get_tvars(Constraints, ConstrainedTVars),
list.delete_elems(ExistQTVars, ConstrainedTVars,
UnconstrainedExistQTVars),
list.length(UnconstrainedExistQTVars, NumTypeInfos),
AdjustedArity = ConsArity + NumTypeClassInfos + NumTypeInfos
;
AdjustedArity = ConsArity
).
%-----------------------------------------------------------------------------%
type_not_stored_in_region(Type, ModuleInfo) :-
( type_is_atomic(ModuleInfo, Type)
; check_dummy_type(ModuleInfo, Type) = is_dummy_type
; Type = type_info_type
; Type = type_ctor_info_type
; type_is_var(Type)
).
%-----------------------------------------------------------------------------%
maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, ConsId, Arity,
MaybeTypes) :-
(
( ConsId = cons(_SymName, _, _)
; ConsId = tuple_cons(_)
)
->
(
MaybeType = yes(Type),
% XXX get_cons_id_non_existential_arg_types will fail
% for ConsIds with existentially typed arguments.
get_cons_id_non_existential_arg_types(ModuleInfo, Type,
ConsId, Types),
list.length(Types, Arity)
->
MaybeTypes = list.map(func(T) = yes(T), Types)
;
list.duplicate(Arity, no, MaybeTypes)
)
;
MaybeTypes = []
).
maybe_get_higher_order_arg_types(MaybeType, Arity, MaybeTypes) :-
(
MaybeType = yes(Type),
type_is_higher_order_details(Type, _, _, _, ArgTypes)
->
MaybeTypes = list.map(func(T) = yes(T), ArgTypes)
;
list.duplicate(Arity, no, MaybeTypes)
).
%-----------------------------------------------------------------------------%
apply_variable_renaming_to_constraint(Renaming, !Constraint) :-
!.Constraint = constraint(Ids, ClassName, ClassArgTypes0),
apply_variable_renaming_to_type_list(Renaming, ClassArgTypes0,
ClassArgTypes),
!:Constraint = constraint(Ids, ClassName, ClassArgTypes).
apply_subst_to_constraint(Subst, !Constraint) :-
!.Constraint = constraint(Ids, ClassName, Types0),
apply_subst_to_type_list(Subst, Types0, Types),
!:Constraint = constraint(Ids, ClassName, Types).
apply_rec_subst_to_constraint(Subst, !Constraint) :-
!.Constraint = constraint(Ids, Name, Types0),
apply_rec_subst_to_type_list(Subst, Types0, Types),
!:Constraint = constraint(Ids, Name, Types).
%-----------------------------------------------------------------------------%
apply_variable_renaming_to_constraint_list(Renaming, !Constraints) :-
list.map(apply_variable_renaming_to_constraint(Renaming), !Constraints).
apply_subst_to_constraint_list(Subst, !Constraints) :-
list.map(apply_subst_to_constraint(Subst), !Constraints).
apply_rec_subst_to_constraint_list(Subst, !Constraints) :-
list.map(apply_rec_subst_to_constraint(Subst), !Constraints).
%-----------------------------------------------------------------------------%
apply_variable_renaming_to_constraints(Renaming, !Constraints) :-
!.Constraints = constraints(Unproven0, Assumed0, Redundant0, Ancestors0),
apply_variable_renaming_to_constraint_list(Renaming, Unproven0, Unproven),
apply_variable_renaming_to_constraint_list(Renaming, Assumed0, Assumed),
Pred = (pred(C0::in, C::out) is det :-
set.to_sorted_list(C0, L0),
apply_variable_renaming_to_constraint_list(Renaming, L0, L),
set.list_to_set(L, C)
),
map.map_values_only(Pred, Redundant0, Redundant),
map.keys(Ancestors0, AncestorsKeys0),
map.values(Ancestors0, AncestorsValues0),
apply_variable_renaming_to_prog_constraint_list(Renaming, AncestorsKeys0,
AncestorsKeys),
list.map(apply_variable_renaming_to_prog_constraint_list(Renaming),
AncestorsValues0, AncestorsValues),
map.from_corresponding_lists(AncestorsKeys, AncestorsValues, Ancestors),
!:Constraints = constraints(Unproven, Assumed, Redundant, Ancestors).
apply_subst_to_constraints(Subst, !Constraints) :-
!.Constraints = constraints(Unproven0, Assumed0, Redundant0, Ancestors0),
apply_subst_to_constraint_list(Subst, Unproven0, Unproven),
apply_subst_to_constraint_list(Subst, Assumed0, Assumed),
Pred = (pred(C0::in, C::out) is det :-
set.to_sorted_list(C0, L0),
apply_subst_to_constraint_list(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_constraint_list(Subst, AncestorsKeys0, AncestorsKeys),
list.map(apply_subst_to_prog_constraint_list(Subst),
AncestorsValues0, AncestorsValues),
map.from_corresponding_lists(AncestorsKeys, AncestorsValues, Ancestors),
!:Constraints = constraints(Unproven, Assumed, Redundant, Ancestors).
apply_rec_subst_to_constraints(Subst, !Constraints) :-
!.Constraints = constraints(Unproven0, Assumed0, Redundant0, Ancestors0),
apply_rec_subst_to_constraint_list(Subst, Unproven0, Unproven),
apply_rec_subst_to_constraint_list(Subst, Assumed0, Assumed),
Pred = (pred(C0::in, C::out) is det :-
set.to_sorted_list(C0, L0),
apply_rec_subst_to_constraint_list(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_constraint_list(Subst,
AncestorsKeys0, AncestorsKeys),
list.map(apply_rec_subst_to_prog_constraint_list(Subst),
AncestorsValues0, AncestorsValues),
map.from_corresponding_lists(AncestorsKeys, AncestorsValues, Ancestors),
!:Constraints = constraints(Unproven, Assumed, Redundant, Ancestors).
%-----------------------------------------------------------------------------%
apply_variable_renaming_to_constraint_proofs(Renaming, Proofs0, Proofs) :-
( map.is_empty(Proofs0) ->
% Optimize the simple case.
Proofs = Proofs0
;
map.keys(Proofs0, Keys0),
map.values(Proofs0, Values0),
apply_variable_renaming_to_prog_constraint_list(Renaming, Keys0, Keys),
list.map(rename_constraint_proof(Renaming), Values0, Values),
map.from_corresponding_lists(Keys, Values, Proofs)
).
% 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, apply_instance(Num), apply_instance(Num)).
rename_constraint_proof(TSubst, superclass(ClassConstraint0),
superclass(ClassConstraint)) :-
apply_variable_renaming_to_prog_constraint(TSubst, ClassConstraint0,
ClassConstraint).
apply_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :-
map.foldl(apply_subst_to_constraint_proofs_2(Subst), Proofs0,
map.init, Proofs).
:- pred apply_subst_to_constraint_proofs_2(tsubst::in,
prog_constraint::in, constraint_proof::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
apply_subst_to_constraint_proofs_2(Subst, Constraint0, Proof0, Map0, Map) :-
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(Map0, Constraint, Proof, Map).
apply_rec_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :-
map.foldl(apply_rec_subst_to_constraint_proofs_2(Subst), Proofs0,
map.init, Proofs).
:- pred apply_rec_subst_to_constraint_proofs_2(tsubst::in,
prog_constraint::in, constraint_proof::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
apply_rec_subst_to_constraint_proofs_2(Subst, Constraint0, Proof0, !Map) :-
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(!.Map, Constraint, Proof, !:Map).
%-----------------------------------------------------------------------------%
apply_variable_renaming_to_constraint_map(Renaming, !ConstraintMap) :-
map.map_values_only(apply_variable_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).
%-----------------------------------------------------------------------------%
:- func this_file = string.
this_file = "type_util.m".
%-----------------------------------------------------------------------------%
:- end_module type_util.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink