mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-18 23:35:25 +00:00
Code Issues Projects Releases Wiki Activity
Files
793ea4d449f9ee32b661dafd139855bfca593f9c
mercury/compiler/type_util.m
Zoltan Somogyi e9430b115a Prep for recording simple type representations in .int3 files. 
compiler/decide_type_repn.m:
    New module for computing the set of type representation items
    to put into the interface files of a module. For now, it generates
    this information only for .int3 files.

compiler/parse_tree.m:
compiler/notes/compiler_design.html:
    Add the new module to the parse_tree package.

compiler/comp_unit_interface.m:
    Invoke the new module to add type representation items to .int3 files
    if the experiment option has the right value. Give it the information
    it needs to do its job.

compiler/add_foreign_enum.m:
    Export a predicate for use by decide_type_repn.m. Maybe eventually
    it should be *moved* to decide_type_repn.m.

compiler/hlds_data.m:
compiler/prog_data.m:
    Change the representation of lists of constructors in a type
    from lists, which can be empty, with one_or_more, which cannot.
    This encodes the invariant that a type constructor cannot have
    zero data constructors in the structure of the type.

compiler/prog_item.m:
    Change the representation of lists of constructors in a type
    from lists, which can be empty, with one_or_more, which cannot.
    This encodes the invariant that a type constructor cannot have
    zero data constructors in the structure of the type.

    Include information about assertions in type representation items
    about foreign types.

    Do not record whether a type whose representation item says its values
    are guaranteed to be word aligned is a Mercury type or a foreign type.
    We generate such items only for Mercury types; for foreign types,
    their assertions will contain that information. We need this separation
    because when we generate .int3 files, we don't the backend that we will
    eventually generate code for, and thus do not know whether a given
    foreign type declaration is in effect on that backend or not.

compiler/parse_tree_out.m:
    Fix the printing of type representation items.

compiler/prog_type.m:
    Conform to the changes above, and delete an unused predicate.

compiler/parse_type_repn.m:
    Factor out some common code.

    Fix an old bug about yes/no vs du_repn/no_du_repn.

    Conform to the changes above.

compiler/parse_pragma.m:
    Export a predicate for parse_type_repn.m.

    Note a possible improvement.

    Conform to the changes above.

compiler/add_special_pred.m:
compiler/add_type.m:
compiler/check_typeclass.m:
compiler/det_report.m:
compiler/du_type_layout.m:
compiler/equiv_type.m:
compiler/hlds_out_module.m:
compiler/inst_check.m:
compiler/intermod.m:
compiler/mode_util.m:
compiler/module_qual.qualify_items.m:
compiler/parse_tree_out_pragma.m:
compiler/parse_type_defn.m:
compiler/recompilation.check.m:
compiler/recompilation.usage.m:
compiler/resolve_unify_functor.m:
compiler/special_pred.m:
compiler/switch_util.m:
compiler/table_gen.m:
compiler/term_norm.m:
compiler/type_util.m:
compiler/untupling.m:
compiler/unused_imports.m:
compiler/xml_documentation.m:
    Conform to the changes above.

compiler/simplify_goal_ite.m:
    Add a comment.

compiler/canonicalize_interface.m:
compiler/get_dependencies.m:
    Do not abort when seeing type representation items.

compiler/mmakefiles.m:
    Delete a predicate that this diff adds to list.m.

library/list.m:
    Add new predicates to convert from one_or_more to list
    and vice versa.

NEWS:
    Announce the new predicates.

library/bimap.m:
library/map.m:
library/tree234.m:
    Expand a comment.
2019-05-27 11:45:10 +02:00

1798 lines
68 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1994-2012 The University of Melbourne.
% Copyright (C) 2014-2018 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 latter
% to a new module in the hlds (as opposed to the check_hlds) package.
%
%-----------------------------------------------------------------------------%
:- module check_hlds.type_util.
:- interface.
:- import_module hlds.
:- import_module hlds.hlds_class.
:- import_module hlds.hlds_cons.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
:- import_module hlds.vartypes.
:- 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 list.
:- import_module maybe.
:- 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, vartypes::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.
:- 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 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.
% 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.
% 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. 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, 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.
:- pred get_cons_repn_defn(module_info::in, cons_id::in,
constructor_repn::out) is semidet.
:- pred get_cons_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, cons_id::in,
ctor_defn::out) is semidet.
:- pred cons_id_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.
% Succeed iff the given variable is of region_type.
%
:- pred is_region_var(vartypes::in, prog_var::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.
% 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(list(prog_var), vartypes) = list(prog_var).
% Given a list of variables, remove all the type_info-related
% variables.
%
:- func remove_typeinfo_vars(vartypes, list(prog_var)) = list(prog_var).
:- func remove_typeinfo_vars_from_set(vartypes, set(prog_var))
= set(prog_var).
:- func remove_typeinfo_vars_from_set_of_var(vartypes, set_of_progvar)
= set_of_progvar.
%-----------------------------------------------------------------------------%
%
% 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_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_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 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_subst.
:- import_module parse_tree.prog_util.
:- import_module bool.
:- import_module int.
:- import_module map.
:- import_module require.
:- import_module term.
%-----------------------------------------------------------------------------%
type_ctor_module(type_ctor(TypeSymName, _Arity)) = ModuleName :-
sym_name_get_module_name_default(TypeSymName, unqualified(""), 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) :-
sym_name_get_module_name_default_name(TypeSymName, unqualified(""),
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(_, _, _, 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
TypeBody ^ 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(_, _, _, _),
( if
TypeBody ^ 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
TypeBody ^ 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, VarTypes, Var) :-
lookup_var_type(VarTypes, Var, VarType),
type_is_or_may_contain_solver_type(ModuleInfo, VarType).
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(_)
),
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(_)
),
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.
IsBuiltinDummy = is_type_ctor_a_builtin_dummy(TypeCtor),
(
IsBuiltinDummy = is_builtin_dummy_type_ctor,
IsDummy = is_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(_, _, MaybeTypeRepn, _),
(
MaybeTypeRepn = no,
unexpected($pred, "MaybeTypeRepn = no")
;
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_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_)
; TypeBody = hlds_abstract_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(_, _, _, 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.
%-----------------------------------------------------------------------------%
classify_type(ModuleInfo, VarType) = TypeCategory :-
( if type_to_ctor(VarType, 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 = mercury_std_lib_module_name(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(_, _, 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_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, TypeArgs),
( if type_ctor_is_tuple(TypeCtor) then
% Tuples are never existentially typed.
MaybeExistConstraints = no_exist_constraints,
Context = term.context_init,
CtorArgs = list.map(
(func(ArgType) = ctor_arg(no, ArgType, Context)),
TypeArgs),
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),
substitute_type_args(TypeParams, TypeArgs,
one_or_more_to_list(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_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's 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(OoMConstructors, _, _, _),
OoMConstructors = one_or_more(_HeadCtor, TailCtors),
NumFunctors = 1 + list.length(TailCtors)
).
%-----------------------------------------------------------------------------%
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) :-
( if type_to_ctor_and_args(VarType, TypeCtor, TypeArgs) then
( if
% The argument types of a tuple cons_id are the arguments
% of the tuple type.
type_ctor_is_tuple(TypeCtor)
then
ArgTypes = TypeArgs
else if
get_cons_defn(ModuleInfo, TypeCtor, ConsId, 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_type_list(TSubst, ArgTypes0, ArgTypes)
else
ArgTypes = []
)
else
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),
TypeDefnBody = hlds_du_type(OoMCtors, _, _, _),
OoMCtors = one_or_more(HeadCtor, TailCtors),
( Ctor = HeadCtor
; list.member(Ctor, TailCtors)
),
Ctor = ctor(_Ordinal, _MaybeExistConstraints, Name, _Args, Arity, _Ctxt),
ConsId = cons(Name, Arity, TypeCtor),
% We should look it up in a type_ctor-specific table, not a global one.
module_info_get_cons_table(ModuleInfo, CtorTable),
search_cons_table_of_type_ctor(CtorTable, TypeCtor, ConsId, ConsDefn),
ConsDefn =
hlds_cons_defn(_, _, TypeParams, _, MaybeExistConstraints, Args, _),
% XXX handle ExistConstraints
MaybeExistConstraints = no_exist_constraints,
map.from_corresponding_lists(TypeParams, TypeArgs, TSubst),
ArgTypes0 = list.map(func(C) = C ^ arg_type, Args),
apply_subst_to_type_list(TSubst, ArgTypes0, ArgTypes).
get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn) :-
module_info_get_cons_table(ModuleInfo, Ctors),
% This search will fail for builtin cons_ids.
search_cons_table_of_type_ctor(Ctors, TypeCtor, ConsId, ConsDefn).
get_cons_defn_det(ModuleInfo, TypeCtor, ConsId, ConsDefn) :-
( if get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefnPrime) then
ConsDefn = ConsDefnPrime
else
unexpected($pred, "get_cons_defn failed")
).
get_cons_repn_defn(ModuleInfo, ConsId, ConsIdConsRepn) :-
ConsId = cons(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(_, _, 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, ConsIdConsRepn).
:- 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, ConsIdConsRepn) :-
( if ConsArity = HeadConsRepn ^ cr_num_args then
ConsIdConsRepn = HeadConsRepn
else
TailConsRepns = [HeadTailConsRepn | TailTailConsRepns],
find_cons_repn_with_given_arity(ConsArity,
HeadTailConsRepn, TailTailConsRepns, ConsIdConsRepn)
).
get_cons_repn_defn_det(ModuleInfo, ConsId, ConsRepnDefn) :-
( if get_cons_repn_defn(ModuleInfo, ConsId, ConsRepnDefnPrime) then
ConsRepnDefn = ConsRepnDefnPrime
else
unexpected($pred, "get_cons_repn_defn failed")
).
get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :-
cons_id_is_existq_cons_return_defn(ModuleInfo, VarType, 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(VarType, TypeCtor),
construct_type(TypeCtor, TypeCtorArgs, RetType),
CtorDefn = ctor_defn(TypeVarSet, KindMap, MaybeExistConstraints,
ArgTypes, RetType).
cons_id_is_existq_cons(ModuleInfo, VarType, ConsId) :-
cons_id_is_existq_cons_return_defn(ModuleInfo, VarType, ConsId, _).
:- pred cons_id_is_existq_cons_return_defn(module_info::in, mer_type::in,
cons_id::in, hlds_cons_defn::out) is semidet.
cons_id_is_existq_cons_return_defn(ModuleInfo, VarType, ConsId, ConsDefn) :-
type_to_ctor(VarType, 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, 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),
( if get_existq_cons_defn(ModuleInfo, Type, ConsId, 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(VarTypes, Var) :-
lookup_var_type(VarTypes, Var, Type),
Type = region_type.
%-----------------------------------------------------------------------------%
maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, ConsId, Arity,
MaybeTypes) :-
( if
( ConsId = cons(_SymName, _, _)
; ConsId = tuple_cons(_)
)
then
( if
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)
then
MaybeTypes = list.map(func(T) = yes(T), Types)
else
list.duplicate(Arity, no, MaybeTypes)
)
else
MaybeTypes = []
).
maybe_get_higher_order_arg_types(MaybeType, Arity, MaybeTypes) :-
( if
MaybeType = yes(Type),
type_is_higher_order_details(Type, _, _, _, ArgTypes)
then
MaybeTypes = list.map(func(T) = yes(T), ArgTypes)
else
list.duplicate(Arity, no, MaybeTypes)
).
%-----------------------------------------------------------------------------%
put_typeinfo_vars_first(VarsList, VarTypes) =
TypeInfoVarsList ++ NonTypeInfoVarsList :-
split_vars_typeinfo_no_typeinfo(VarsList, VarTypes,
TypeInfoVarsList, NonTypeInfoVarsList).
remove_typeinfo_vars(VarTypes, VarsList) = NonTypeInfoVarsList :-
list.negated_filter(var_is_introduced_type_info_type(VarTypes),
VarsList, NonTypeInfoVarsList).
remove_typeinfo_vars_from_set(VarTypes, VarsSet0) = VarsSet :-
VarsList0 = set.to_sorted_list(VarsSet0),
VarsList = remove_typeinfo_vars(VarTypes, VarsList0),
VarsSet = set.sorted_list_to_set(VarsList).
remove_typeinfo_vars_from_set_of_var(VarTypes, 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(VarTypes, VarsList0),
VarsSet = set_of_var.sorted_list_to_set(VarsList).
:- pred split_vars_typeinfo_no_typeinfo(list(prog_var)::in,
vartypes::in, list(prog_var)::out, list(prog_var)::out) is det.
split_vars_typeinfo_no_typeinfo(VarsList, VarTypes, TypeInfoVarsList,
NonTypeInfoVarsList) :-
list.filter(var_is_introduced_type_info_type(VarTypes),
VarsList, TypeInfoVarsList, NonTypeInfoVarsList).
:- pred var_is_introduced_type_info_type(vartypes::in, prog_var::in)
is semidet.
var_is_introduced_type_info_type(VarTypes, Var) :-
lookup_var_type(VarTypes, Var, Type),
is_introduced_type_info_type(Type).
%-----------------------------------------------------------------------------%
apply_variable_renaming_to_constraint(Renaming, !Constraint) :-
!.Constraint = hlds_constraint(Ids, ClassName, ArgTypes0),
apply_variable_renaming_to_type_list(Renaming, ArgTypes0, ArgTypes),
!:Constraint = hlds_constraint(Ids, ClassName, ArgTypes).
apply_subst_to_constraint(Subst, !Constraint) :-
!.Constraint = hlds_constraint(Ids, ClassName, ArgTypes0),
apply_subst_to_type_list(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_type_list(Subst, ArgTypes0, ArgTypes),
!:Constraint = hlds_constraint(Ids, ClassName, ArgTypes).
%-----------------------------------------------------------------------------%
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 = hlds_constraints(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_variable_renaming_to_constraint_list(Renaming,
Unproven0, Unproven),
apply_variable_renaming_to_constraint_list(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_variable_renaming_to_constraint_list(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_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 =
hlds_constraints(Unproven, Assumed, Redundant, Ancestors)
).
apply_subst_to_constraints(Subst, !Constraints) :-
!.Constraints = hlds_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 = hlds_constraints(Unproven, Assumed, Redundant, Ancestors).
apply_rec_subst_to_constraints(Subst, !Constraints) :-
!.Constraints = hlds_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 = hlds_constraints(Unproven, Assumed, Redundant, Ancestors).
%-----------------------------------------------------------------------------%
apply_variable_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_variable_renaming_to_prog_constraint_list(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_variable_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_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).
%-----------------------------------------------------------------------------%
:- end_module check_hlds.type_util.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink