mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-15 17:33:38 +00:00
Code Issues Projects Releases Wiki Activity
Files
2fc28ebe813d302eee2b752fcbfc1472adc8c403
mercury/compiler/type_util.m
Zoltan Somogyi ee9c7d3a84 Speed up bound vs ground inst checks. 
The code that checks whether a bound inst wrapped around
a list of bound_functors matched the ground inst did several things
in a suboptimal fashion.

- It looked up the definition of the type constructor of the relevant type
  (the type of the variable the inst is for) more than once. (This was
  not easily visible because the lookups were in different predicates.)
  This diff factors these out, not for the immesurably small speedup,
  but to make possible the fixes for the next two issues.

- To simplify the "is there a bound_functor for each constructor in the type"
  check, it sorted the constructors of the type by name and arity. (Lists of
  bound_functors are always sorted by name and arity.) Given that most
  modules contain more than one bound inst for any given type constructor,
  any sorting after the first was unnecessarily repeated work. This diff
  therefore extends the representation of du types, which until now has
  include only a list of the data constructors in the type definition
  in definition order, with a list of those exact same data constructors
  in name/arity order.

- Even if a list of bound_functors lists all the constructors of a type,
  the bound inst containing them is not equivalent to ground if the inst
  of some argument of some bound_inst is not equivalent to ground.
  This means that we need to know the actual argument of each constructor.
  The du type definition lists argument types that refer to the type
  constructor's type parameters; we need the instances of these argument types
  that apply to type of the variable at hand, which usually binds concrete
  types to those type parameters.

  We used to apply the type-parameter-to-actual-type substitution to
  each argument of each data constructor in the type before we compared
  the resulting filled-in data constructor descriptions against the list of
  bound_functors. However, in cases where the comparison fails, the
  substitution applications to arguments beyond the point of failure
  are all wasted work. This diff therefore applies the substitution
  only when its result is about to be needed.

This diff leads to a speedup of about 3.5% on tools/speedtest,
and about 38% (yes, more than a third) when compiling options.m.

compiler/hlds_data.m:
    Add the new field to the representation of du types.

    Add a utility predicate that helps construct that field, since it is
    now needed by two modules (add_type.m and equiv_type_hlds.m).

    Delete two functions that were used only by det_check_switch.m,
    which this diff moves to that module (in modified form).

compiler/inst_match.m:
    Implement the first and third changes listed above, and take advantage
    of the second.

    The old call to all_du_ctor_arg_types, which this diff replaces,
    effectively lied about the list of constructors it returned,
    by simply not returning any constructors containing existentially
    quantified  types, on the grounds that they "were not handled yet".
    We now fail explicitly when we find any such constructors.

    Perform the check for one-to-one match between bound_functors and
    constructors with less argument passing.

compiler/det_check_switch.m:
    Move the code deleted from hlds_data.m here, and simplify it,
    taking advantage of the new field in du types.

compiler/Mercury.options:
    Specify --optimize-constructor-last-call for det_check_switch.m
    to optimize the updated moved code.

compiler/add_foreign_enum.m:
compiler/add_special_pred.m:
compiler/add_type.m:
compiler/check_typeclass.m:
compiler/code_info.m:
compiler/dead_proc_elim.m:
compiler/direct_arg_in_out.m:
compiler/du_type_layout.m:
compiler/equiv_type_hlds.m:
compiler/hlds_out_type_table.m:
compiler/inst_check.m:
compiler/intermod.m:
compiler/intermod_decide.m:
compiler/lookup_switch_util.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen_test.m:
compiler/ml_unify_gen_util.m:
compiler/mlds.m:
compiler/post_term_analysis.m:
compiler/recompilation.usage.m:
compiler/resolve_unify_functor.m:
compiler/simplify_goal_ite.m:
compiler/table_gen.m:
compiler/tag_switch_util.m:
compiler/term_norm.m:
compiler/type_ctor_info.m:
compiler/type_util.m:
compiler/typecheck_coerce.m:
compiler/unify_proc.m:
compiler/unused_imports.m:
compiler/xml_documentation.m:
    Conform to the changes above. This mostly means handling
    the new field in du types (usually by ignoring it).
2025-11-19 22:09:04 +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-2025 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,
% include 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 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