mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-19 03:13:40 +00:00
Code Issues Projects Releases Wiki Activity
Files
083d376e6598628362ee91c2da170febd83590f4
mercury/compiler/prog_type.m
Zoltan Somogyi a2cdba85bd Reduce duplication of code about int type names. 
compiler/prog_data.m:
    Give two predicates dealing with the names of builtin types
    more meaningful names. Document the semantics of both predicates,
    and document the reason why the definition of one is effectively
    inlined into the definition of the other.

compiler/builtin_ops.m:
    Make a copy of one of the predicates easier to read, even though
    the copy cannot be replaced by a call.

compiler/module_qual.qualify_items.m:
    Do replace such copy by a call.

compiler/error_type_util.m:
compiler/parse_tree_out_type.m:
compiler/parse_tree_to_term.m:
compiler/pred_name.m:
compiler/prog_event.m:
compiler/prog_type.m:
compiler/table_gen.m:
compiler/typecheck_errors.m:
compiler/xml_documentation.m:
    Refer to the predicates by their new names.
2023-05-21 11:33:20 +10:00

1534 lines
56 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2005-2012 The University of Melbourne.
% Copyright (C) 2014-2021 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: prog_type.m.
% Main author: fjh.
%
% Utility predicates dealing with types in the parse tree. The predicates for
% doing type substitutions are in prog_type_subst.m, while utility predicates
% for dealing with types in the HLDS are in type_util.m.
%
%---------------------------------------------------------------------------%
:- module parse_tree.prog_type.
:- interface.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_util.
:- import_module bool.
:- import_module list.
:- import_module map.
:- import_module one_or_more.
:- import_module set.
:- import_module term.
%---------------------------------------------------------------------------%
%
% Simple tests for certain properties of types. These tests work modulo any
% kind annotations, so in the early stages of the compiler (i.e., before type
% checking) these should be used rather than direct tests. Once we reach
% type checking, all kind annotations should have been removed, so it would
% be preferable to switch on the top functor rather than use these predicates
% in an if-then-else expression, since switches will give better error
% detection.
%
% Succeeds iff the given type is a variable.
%
:- pred type_is_var(mer_type::in) is semidet.
% Succeeds iff the given type is not a variable.
%
:- pred type_is_nonvar(mer_type::in) is semidet.
% Succeeds iff the given type is a higher-order predicate or function type.
%
:- pred type_is_higher_order(mer_type::in) is semidet.
% type_is_higher_order_details(Type, Purity, PredOrFunc, ArgTypes,
% EvalMethod):
%
% Succeeds iff Type is a higher-order predicate or function type with
% the specified argument types (for functions, the return type is appended
% to the end of the argument types), purity, and evaluation method.
%
:- pred type_is_higher_order_details(mer_type::in, purity::out,
pred_or_func::out, lambda_eval_method::out, list(mer_type)::out)
is semidet.
:- pred type_is_higher_order_details_det(mer_type::in, purity::out,
pred_or_func::out, lambda_eval_method::out, list(mer_type)::out)
is det.
% Succeed if the given type is a tuple type, returning
% the argument types.
%
:- pred type_is_tuple(mer_type::in, list(mer_type)::out) is semidet.
:- type non_kinded_type =< mer_type
---> type_variable(tvar, kind)
; defined_type(sym_name, list(mer_type), kind)
; builtin_type(builtin_type)
; tuple_type(list(mer_type), kind)
; higher_order_type(pred_or_func, list(mer_type), ho_inst_info,
purity, lambda_eval_method)
; apply_n_type(tvar, list(mer_type), kind).
% Remove the kind annotation at the top-level if there is one,
% otherwise return the type unchanged.
%
:- func strip_kind_annotation(mer_type) = non_kinded_type.
%---------------------------------------------------------------------------%
% Succeeds iff the given type is ground (that is, contains no type
% variables).
%
:- pred type_is_ground(mer_type::in) is semidet.
% Succeeds iff the given type contains no type variables except
% for those in the given list.
%
:- pred type_is_ground_except_vars(mer_type::in, list(tvar)::in) is semidet.
% Succeeds iff the given type is not ground.
%
:- pred type_is_nonground(mer_type::in) is semidet.
% Succeeds iff the given type with the substitution applied is ground.
%
:- pred subst_type_is_ground(mer_type::in, tsubst::in) is semidet.
% Succeeds iff the given type with the substitution applied is not
% ground.
%
:- pred subst_type_is_nonground(mer_type::in, tsubst::in) is semidet.
% type_has_variable_arity_ctor(Type, TypeCtor, ArgTypes):
%
% Check if the principal type constructor of Type is of variable arity.
% If yes, return the type constructor as TypeCtor and its args as
% ArgTypes. If not, fail.
%
:- pred type_has_variable_arity_ctor(mer_type::in, type_ctor::out,
list(mer_type)::out) is semidet.
% Given a non-variable type, return its type_ctor and argument types.
% Fail if the type is a variable.
%
:- pred type_to_ctor_and_args(mer_type::in, type_ctor::out,
list(mer_type)::out) is semidet.
% Given a non-variable type, return its type_ctor and argument types.
% Abort if the type is a variable.
%
:- pred type_to_ctor_and_args_det(mer_type::in, type_ctor::out,
list(mer_type)::out) is det.
% Given a non-variable type, return its type_ctor.
% Fail if the type is a variable.
%
:- pred type_to_ctor(mer_type::in, type_ctor::out) is semidet.
% Given a non-variable type, return its type_ctor.
% Abort if the type is a variable.
%
:- pred type_to_ctor_det(mer_type::in, type_ctor::out) is det.
% type_ctor_is_higher_order(TypeCtor, PredOrFunc) succeeds iff
% TypeCtor is a higher-order predicate or function type.
%
:- pred type_ctor_is_higher_order(type_ctor::in, purity::out,
pred_or_func::out, lambda_eval_method::out) is semidet.
% type_ctor_is_tuple(TypeCtor) succeeds iff TypeCtor is a tuple type.
%
:- pred type_ctor_is_tuple(type_ctor::in) is semidet.
% Convert a list of types to a list of vars. Fail if any of the type are
% not variables.
%
:- pred type_list_to_var_list(list(mer_type)::in, list(tvar)::out) is semidet.
% Convert a var into a variable type.
%
:- pred var_to_type(tvar_kind_map::in, tvar::in, mer_type::out) is det.
% Convert a list of vars into a list of variable types.
%
:- pred var_list_to_type_list(tvar_kind_map::in, list(tvar)::in,
list(mer_type)::out) is det.
% Return a list of the type variables of a type, or a list of types,
% in order of their first occurrence in a depth-first, left-right
% traversal.
%
:- pred type_vars_in_type(mer_type::in, list(tvar)::out) is det.
:- pred type_vars_in_types(list(mer_type)::in, list(tvar)::out) is det.
% Return the set of the type variables of a type, or a list of types.
%
:- pred set_of_type_vars_in_type(mer_type::in, set(tvar)::out) is det.
:- pred set_of_type_vars_in_types(list(mer_type)::in, set(tvar)::out) is det.
% Nondeterministically return the variables in a type.
%
:- pred type_contains_var(mer_type::in, tvar::out) is nondet.
% Nondeterministically return the variables in a list of types.
%
:- pred type_list_contains_var(list(mer_type)::in, tvar::out) is nondet.
% Given a type_ctor and a list of argument types,
% construct a type.
%
:- pred construct_type(type_ctor::in, list(mer_type)::in, mer_type::out)
is det.
:- pred construct_higher_order_type(purity::in, pred_or_func::in,
lambda_eval_method::in, list(mer_type)::in, mer_type::out) is det.
:- pred construct_higher_order_pred_type(purity::in, lambda_eval_method::in,
list(mer_type)::in, mer_type::out) is det.
:- pred construct_higher_order_pred_type(purity::in, lambda_eval_method::in,
list(mer_type)::in, list(mer_mode)::in, determinism::in, mer_type::out)
is det.
:- pred construct_higher_order_func_type(purity::in, lambda_eval_method::in,
list(mer_type)::in, mer_type::in, mer_type::out) is det.
:- pred construct_higher_order_func_type(purity::in, lambda_eval_method::in,
list(mer_type)::in, mer_type::in, list(mer_mode)::in, mer_mode::in,
determinism::in, mer_type::out) is det.
% Make error messages more readable by removing some or all
% module qualifiers from type and mode names contained in the given type
% or types, regardless of how deeply they are nested.
%
:- pred strip_module_names_from_type(strip_what_module_names::in,
mer_type::in, mer_type::out) is det.
:- pred strip_module_names_from_type_list(strip_what_module_names::in,
list(mer_type)::in, list(mer_type)::out) is det.
% Return the list of type variables contained in a list of constraints.
%
:- pred prog_constraints_get_tvars(prog_constraints::in, list(tvar)::out)
is det.
% Return the list of type variables contained in a list of constraints.
%
:- pred constraint_list_get_tvars(list(prog_constraint)::in, list(tvar)::out)
is det.
% Return the list of type variables contained in a constraint.
%
:- pred constraint_get_tvars(prog_constraint::in, list(tvar)::out) is det.
:- pred get_unconstrained_tvars(list(tvar)::in, list(prog_constraint)::in,
list(tvar)::out) is det.
%---------------------------------------------------------------------------%
:- type is_dummy_type
---> is_dummy_type
; is_not_dummy_type.
% The list of type_ctors which are builtins which do not have a
% hlds_type_defn.
%
:- func builtin_type_ctors_with_no_hlds_type_defn = list(type_ctor).
:- type is_builtin_dummy_type_ctor
---> is_builtin_dummy_type_ctor
; is_builtin_non_dummy_type_ctor
; is_not_builtin_dummy_type_ctor.
% is_builtin_dummy_type_ctor(type_ctor):
%
% Is the given type constructor a dummy type irrespective
% of its definition?
%
:- func is_type_ctor_a_builtin_dummy(type_ctor) = is_builtin_dummy_type_ctor.
:- pred type_is_io_state(mer_type::in) is semidet.
:- pred type_ctor_is_array(type_ctor::in) is semidet.
:- pred type_ctor_is_bitmap(type_ctor::in) is semidet.
% A test for type_info-related types that are introduced by
% polymorphism.m. These need to be handled specially in certain
% places. For example, mode inference never infers unique modes
% for these types, since it would not be useful, and since we
% want to minimize the number of different modes that we infer.
%
:- pred is_introduced_type_info_type(mer_type::in) is semidet.
:- pred is_introduced_type_info_type_ctor(type_ctor::in) is semidet.
:- func is_introduced_type_info_type_category(type_ctor_category) = bool.
% Check for a "new " prefix at the start of the functor name,
% and remove it if present; if there is no such prefix, fail.
% (These prefixes are used for construction unifications
% with existentially typed functors.)
%
:- pred remove_new_prefix(sym_name::in, sym_name::out) is semidet.
% Prepend a "new " prefix at the start of the given functor name.
% (These prefixes are used for construction unifications
% with existentially typed functors.)
%
:- pred add_new_prefix(sym_name::in, sym_name::out) is det.
:- type type_ctor_category
---> ctor_cat_builtin(type_ctor_cat_builtin)
; ctor_cat_builtin_dummy
; ctor_cat_void
; ctor_cat_variable
; ctor_cat_higher_order
; ctor_cat_tuple
; ctor_cat_enum(type_ctor_cat_enum)
; ctor_cat_system(type_ctor_cat_system)
; ctor_cat_user(type_ctor_cat_user).
:- type type_ctor_cat_builtin
---> cat_builtin_int(int_type)
; cat_builtin_float
; cat_builtin_char
; cat_builtin_string.
:- type type_ctor_cat_system
---> cat_system_type_info
; cat_system_type_ctor_info
; cat_system_typeclass_info
; cat_system_base_typeclass_info.
:- type type_ctor_cat_enum
---> cat_enum_mercury
% XXX TYPE_REPN Should we add an arg specifying
% the number of bits needed to store the enum?
; cat_enum_foreign.
:- type type_ctor_cat_user
---> cat_user_direct_dummy
; cat_user_abstract_dummy
; cat_user_notag
; cat_user_abstract_notag
; cat_user_general.
% Given a constant and an arity, return a type_ctor.
% Fails if the constant is not an atom.
%
% This really ought to take a name and an arity -
% use of integers/floats/strings as type names should be rejected
% by the parser, not by module_qual.m.
%
:- pred make_type_ctor(const::in, int::in, type_ctor::out) is semidet.
:- type polymorphism_cell
---> type_info_cell(type_ctor)
; typeclass_info_cell.
:- func cell_cons_id(polymorphism_cell) = cons_id.
:- func cell_inst_cons_id(polymorphism_cell, int) = cons_id.
% Module-qualify the cons_id using module information from the type.
% The second output value is the cons_id required for use in insts which
% can be different from that used in types for typeclass_info and
% type_info. The list(prog_var) is the list of arguments to the cons_id
% and is just used for obtaining the arity for typeclass_info and type_info
% cons_ids.
%
:- pred qualify_cons_id(list(prog_var)::in, cons_id::in,
cons_id::out, cons_id::out) is det.
% Given a list of constructors for a type, check whether that type
% is a private_builtin.type_info/0 or similar type.
%
:- pred type_constructors_are_type_info(list(constructor)::in) is semidet.
% Is the discriminated union type (not a subtype) with the given list of
% constructors a notag type?
%
:- pred non_sub_du_type_is_notag(one_or_more(constructor)::in,
maybe_canonical::in) is semidet.
% Is the discriminated union type (not a subtype) with the given list of
% constructors an enum? If yes, return the number of enum values.
%
:- pred non_sub_du_type_is_enum(type_details_du::in, int::out) is semidet.
% Return the number of bits required to represent
% the given number of values, 0 to n-1.
%
:- pred num_bits_needed_for_n_dense_values(int::in, int::out) is det.
% Is the discriminated union type (not a subtype) with the given list of
% constructors a dummy type?
%
:- pred non_sub_du_type_is_dummy(type_details_du::in) is semidet.
% Unify (with occurs check) two types with respect to a type substitution
% and update the type bindings. The third argument is a list of type
% variables which cannot be bound (i.e. head type variables).
%
% No kind checking is done, since it is assumed that kind errors
% will be picked up elsewhere.
%
:- pred type_unify(mer_type::in, mer_type::in, list(tvar)::in, tsubst::in,
tsubst::out) is semidet.
:- pred type_unify_list(list(mer_type)::in, list(mer_type)::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
% type_subsumes(TypeA, TypeB, Subst) succeeds iff TypeA subsumes
% (is more general than) TypeB, producing a type substitution
% which when applied to TypeA will give TypeB.
%
:- pred type_subsumes(mer_type::in, mer_type::in, tsubst::out) is semidet.
% Same as type_subsumes, but aborts instead of failing.
%
:- pred type_subsumes_det(mer_type::in, mer_type::in, tsubst::out) is det.
% type_list_subsumes(TypesA, TypesB, Subst) succeeds iff the list
% TypesA subsumes (is more general than) TypesB, producing a
% type substitution which when applied to TypesA will give TypesB.
%
:- pred type_list_subsumes(list(mer_type)::in, list(mer_type)::in, tsubst::out)
is semidet.
% Same as type_list_subsumes, but aborts instead of failing.
%
:- pred type_list_subsumes_det(list(mer_type)::in, list(mer_type)::in,
tsubst::out) is det.
% arg_type_list_subsumes(TVarSet, ExistQVars, ArgTypes, HeadTypeParams,
% CalleeTVarSet, CalleeExistQVars, CalleeArgTypes):
%
% Check that the argument types of the called predicate, function or
% constructor subsume the types of the arguments of the call. This checks
% that none of the existentially quantified type variables of the callee
% are bound.
%
:- pred arg_type_list_subsumes(tvarset::in, existq_tvars::in,
list(mer_type)::in, list(tvar)::in,
tvarset::in, tvar_kind_map::in, existq_tvars::in, list(mer_type)::in)
is semidet.
% compute_caller_callee_type_substitution(CalleeArgTypes, CallerArgTypes,
% ExternalTypeParams, CalleeExistQTVars, TypeSubn):
%
% Work out a type substitution to map the callee's argument types
% into the caller's.
%
:- pred compute_caller_callee_type_substitution(list(mer_type)::in,
list(mer_type)::in, list(tvar)::in, list(tvar)::in, tsubst::out) is det.
% Apply a renaming (partial map) to a list.
% Useful for applying a variable renaming to a list of variables.
%
:- pred apply_partial_map_to_list(map(T, T)::in, list(T)::in, list(T)::out)
is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module mdbcomp.builtin_modules.
:- import_module parse_tree.parse_tree_out_misc.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type_subst.
:- import_module int.
:- import_module maybe.
:- import_module require.
:- import_module string.
%---------------------------------------------------------------------------%
type_is_var(Type) :-
strip_kind_annotation(Type) = type_variable(_, _).
type_is_nonvar(Type) :-
not type_is_var(Type).
type_is_higher_order(Type) :-
strip_kind_annotation(Type) = higher_order_type(_, _, _, _, _).
type_is_higher_order_details(Type, Purity, PredOrFunc, EvalMethod, ArgTypes) :-
strip_kind_annotation(Type) =
higher_order_type(PredOrFunc, ArgTypes, _HOInstInfo, Purity,
EvalMethod).
type_is_higher_order_details_det(Type, !:Purity, !:PredOrFunc, !:EvalMethod,
!:PredArgTypes) :-
( if
type_is_higher_order_details(Type, !:Purity, !:PredOrFunc,
!:EvalMethod, !:PredArgTypes)
then
true
else
unexpected($pred, "type is not higher-order")
).
type_is_tuple(Type, ArgTypes) :-
strip_kind_annotation(Type) = tuple_type(ArgTypes, _).
strip_kind_annotation(Type0) = Type :-
(
Type0 = kinded_type(Type1, _),
Type = strip_kind_annotation(Type1)
;
( Type0 = type_variable(_, _)
; Type0 = defined_type(_, _, _)
; Type0 = builtin_type(_)
; Type0 = tuple_type(_, _)
; Type0 = higher_order_type(_, _, _, _, _)
; Type0 = apply_n_type(_, _, _)
),
Type = coerce(Type0)
).
%---------------------------------------------------------------------------%
type_is_ground(Type) :-
not type_contains_var(Type, _).
type_is_ground_except_vars(Type, Except) :-
all [TVar] (
type_contains_var(Type, TVar)
=>
list.contains(Except, TVar)
).
type_is_nonground(Type) :-
type_contains_var(Type, _).
subst_type_is_ground(Type, TSubst) :-
not subst_type_is_nonground(Type, TSubst).
subst_type_is_nonground(Type, TSubst) :-
type_contains_var(Type, TVar),
( if map.search(TSubst, TVar, Binding) then
subst_type_is_nonground(Binding, TSubst)
else
true
).
type_has_variable_arity_ctor(Type, TypeCtor, ArgTypes) :-
( if
type_is_higher_order_details(Type, _Purity, PredOrFunc, _, ArgTypes0)
then
ArgTypes = ArgTypes0,
PredOrFuncStr = parse_tree_out_misc.pred_or_func_to_str(PredOrFunc),
TypeCtor = type_ctor(unqualified(PredOrFuncStr), 0)
else if
type_is_tuple(Type, ArgTypes1)
then
ArgTypes = ArgTypes1,
% XXX why tuple/0 and not {}/N ?
TypeCtor = type_ctor(unqualified("tuple"), 0)
else
fail
).
type_to_ctor_and_args(Type, TypeCtor, ArgTypes) :-
require_complete_switch [Type]
(
Type = type_variable(_, _),
fail
;
Type = defined_type(SymName, ArgTypes, _),
Arity = list.length(ArgTypes),
TypeCtor = type_ctor(SymName, Arity)
;
Type = builtin_type(BuiltinType),
builtin_type_name(BuiltinType, Name),
SymName = unqualified(Name),
Arity = 0,
ArgTypes = [],
TypeCtor = type_ctor(SymName, Arity)
;
Type = higher_order_type(PorF, ArgTypes, _HO, Purity, _EvalMethod),
list.length(ArgTypes, NumArgTypes),
(
PorF = pf_predicate,
PorFStr = "pred",
UserArity = NumArgTypes
;
PorF = pf_function,
PorFStr = "func",
UserArity = NumArgTypes - 1
),
SymName0 = unqualified(PorFStr),
(
Purity = purity_pure,
SymName = SymName0
;
Purity = purity_semipure,
SymName = add_outermost_qualifier("semipure", SymName0)
;
Purity = purity_impure,
SymName = add_outermost_qualifier("impure", SymName0)
),
TypeCtor = type_ctor(SymName, UserArity)
;
Type = tuple_type(ArgTypes, _),
SymName = unqualified("{}"),
Arity = list.length(ArgTypes),
TypeCtor = type_ctor(SymName, Arity)
;
Type = apply_n_type(_, _, _),
sorry($pred, "apply/N types")
;
Type = kinded_type(SubType, _),
type_to_ctor_and_args(SubType, TypeCtor, ArgTypes)
).
type_to_ctor_and_args_det(Type, TypeCtor, ArgTypes) :-
( if type_to_ctor_and_args(Type, TypeCtorPrime, ArgTypesPrime) then
TypeCtor = TypeCtorPrime,
ArgTypes = ArgTypesPrime
else
unexpected($pred, "type_to_ctor_and_args failed: " ++ string(Type))
).
type_to_ctor(Type, TypeCtor) :-
% This should be subject to unused argument elimination.
type_to_ctor_and_args(Type, TypeCtor, _ArgTypes).
type_to_ctor_det(Type, TypeCtor) :-
% This should be subject to unused argument elimination.
type_to_ctor_and_args_det(Type, TypeCtor, _ArgTypes).
type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc, EvalMethod) :-
% Please keep this code in sync with classify_type_ctor_if_special.
% XXX Unlike classify_type_ctor_if_special, this code here does NOT test
% for mercury_public_builtin_module as ModuleSymName. This preserves
% old behavior, but I (zs) think that it may nevertheless be a bug,
% either here, or in classify_type_ctor_if_special.
TypeCtor = type_ctor(SymName, _Arity),
(
SymName = qualified(ModuleSymName, PorFStr),
ModuleSymName = unqualified(Qualifier),
(
Qualifier = "impure",
Purity = purity_impure,
EvalMethod = lambda_normal
;
Qualifier = "semipure",
Purity = purity_semipure,
EvalMethod = lambda_normal
)
;
SymName = unqualified(PorFStr),
EvalMethod = lambda_normal,
Purity = purity_pure
),
(
PorFStr = "pred",
PredOrFunc = pf_predicate
;
PorFStr = "func",
PredOrFunc = pf_function
).
% Please keep this code in sync with classify_type_ctor_if_special.
type_ctor_is_tuple(type_ctor(unqualified("{}"), _)).
type_list_to_var_list([], []).
type_list_to_var_list([Type | Types], [Var | Vars]) :-
Type = type_variable(Var, _),
type_list_to_var_list(Types, Vars).
var_to_type(KindMap, Var, Type) :-
get_tvar_kind(KindMap, Var, Kind),
Type = type_variable(Var, Kind).
var_list_to_type_list(_, [], []).
var_list_to_type_list(KindMap, [Var | Vars], [Type | Types]) :-
var_to_type(KindMap, Var, Type),
var_list_to_type_list(KindMap, Vars, Types).
%---------------------%
type_vars_in_type(Type, TVars) :-
type_vars_in_type_acc(Type, [], RevTVars),
list.reverse(RevTVars, TVarsDups),
list.remove_dups(TVarsDups, TVars).
type_vars_in_types(Types, TVars) :-
type_vars_in_types_acc(Types, [], RevTVars),
list.reverse(RevTVars, TVarsDups),
list.remove_dups(TVarsDups, TVars).
:- pred type_vars_in_type_acc(mer_type::in,
list(tvar)::in, list(tvar)::out) is det.
type_vars_in_type_acc(type_variable(Var, _), !RevTVars) :-
!:RevTVars = [Var | !.RevTVars].
type_vars_in_type_acc(defined_type(_, ArgTypes, _), !RevTVars) :-
type_vars_in_types_acc(ArgTypes, !RevTVars).
type_vars_in_type_acc(builtin_type(_), !RevTVars).
type_vars_in_type_acc(higher_order_type(_, ArgTypes, _, _, _), !RevTVars) :-
type_vars_in_types_acc(ArgTypes, !RevTVars).
type_vars_in_type_acc(tuple_type(ArgTypes, _), !RevTVars) :-
type_vars_in_types_acc(ArgTypes, !RevTVars).
type_vars_in_type_acc(apply_n_type(Var, ArgTypes, _), !RevTVars) :-
!:RevTVars= [Var | !.RevTVars],
type_vars_in_types_acc(ArgTypes, !RevTVars).
type_vars_in_type_acc(kinded_type(Type, _), !RevTVars) :-
type_vars_in_type_acc(Type, !RevTVars).
:- pred type_vars_in_types_acc(list(mer_type)::in,
list(tvar)::in, list(tvar)::out) is det.
type_vars_in_types_acc([], !RevTVars).
type_vars_in_types_acc([Type | Types], !RevTVars) :-
type_vars_in_type_acc(Type, !RevTVars),
type_vars_in_types_acc(Types, !RevTVars).
%---------------------%
set_of_type_vars_in_type(Type, SetOfTVars) :-
type_vars_in_type(Type, TVars),
set.list_to_set(TVars, SetOfTVars).
set_of_type_vars_in_types(Types, SetOfTVars) :-
type_vars_in_types(Types, TVars),
set.list_to_set(TVars, SetOfTVars).
%---------------------%
type_contains_var(type_variable(Var, _), Var).
type_contains_var(defined_type(_, ArgTypes, _), Var) :-
type_list_contains_var(ArgTypes, Var).
type_contains_var(higher_order_type(_, ArgTypes, _, _, _), Var) :-
type_list_contains_var(ArgTypes, Var).
type_contains_var(tuple_type(ArgTypes, _), Var) :-
type_list_contains_var(ArgTypes, Var).
type_contains_var(apply_n_type(Var, _, _), Var).
type_contains_var(apply_n_type(_, ArgTypes, _), Var) :-
type_list_contains_var(ArgTypes, Var).
type_contains_var(kinded_type(Type, _), Var) :-
type_contains_var(Type, Var).
type_list_contains_var([Type | _], Var) :-
type_contains_var(Type, Var).
type_list_contains_var([_ | Types], Var) :-
type_list_contains_var(Types, Var).
construct_type(TypeCtor, ArgTypes, Type) :-
( if
TypeCtor = type_ctor(unqualified(Name), 0),
builtin_type_name(BuiltinType, Name)
then
Type = builtin_type(BuiltinType)
else if
type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc, EvalMethod)
then
construct_higher_order_type(Purity, PredOrFunc, EvalMethod, ArgTypes,
Type)
else if
type_ctor_is_tuple(TypeCtor)
then
% XXX kind inference: we assume the kind is star.
Type = tuple_type(ArgTypes, kind_star)
else
TypeCtor = type_ctor(SymName, _),
% XXX kind inference: we assume the kind is star.
Type = defined_type(SymName, ArgTypes, kind_star)
).
construct_higher_order_type(Purity, PredOrFunc, EvalMethod, ArgTypes, Type) :-
(
PredOrFunc = pf_predicate,
construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, Type)
;
PredOrFunc = pf_function,
pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType),
construct_higher_order_func_type(Purity, EvalMethod, FuncArgTypes,
FuncRetType, Type)
).
construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, Type) :-
Type = higher_order_type(pf_predicate, ArgTypes, none_or_default_func,
Purity, EvalMethod).
construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, ArgModes,
Detism, Type) :-
PredInstInfo = pred_inst_info(pf_predicate, ArgModes, arg_reg_types_unset,
Detism),
Type = higher_order_type(pf_predicate, ArgTypes,
higher_order(PredInstInfo), Purity, EvalMethod).
construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType,
Type) :-
Type = higher_order_type(pf_function, ArgTypes ++ [RetType],
none_or_default_func, Purity, EvalMethod).
construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType,
ArgModes, RetMode, Detism, Type) :-
PredInstInfo = pred_inst_info(pf_function, ArgModes ++ [RetMode],
arg_reg_types_unset, Detism),
Type = higher_order_type(pf_function, ArgTypes ++ [RetType],
higher_order(PredInstInfo), Purity, EvalMethod).
%---------------------%
strip_module_names_from_type(StripWhat, Type0, Type) :-
(
( Type0 = type_variable(_, _)
; Type0 = builtin_type(_)
),
Type = Type0
;
Type0 = defined_type(SymName0, ArgTypes0, Kind),
strip_module_names_from_sym_name(StripWhat, SymName0, SymName),
strip_module_names_from_type_list(StripWhat, ArgTypes0, ArgTypes),
Type = defined_type(SymName, ArgTypes, Kind)
;
Type0 = higher_order_type(PorF, ArgTypes0, HOInstInfo0, Purity, EM),
strip_module_names_from_type_list(StripWhat, ArgTypes0, ArgTypes),
strip_module_names_from_ho_inst_info(StripWhat,
HOInstInfo0, HOInstInfo),
Type = higher_order_type(PorF, ArgTypes, HOInstInfo, Purity, EM)
;
Type0 = tuple_type(ArgTypes0, Kind),
strip_module_names_from_type_list(StripWhat, ArgTypes0, ArgTypes),
Type = tuple_type(ArgTypes, Kind)
;
Type0 = apply_n_type(Var, ArgTypes0, Kind),
strip_module_names_from_type_list(StripWhat, ArgTypes0, ArgTypes),
Type = apply_n_type(Var, ArgTypes, Kind)
;
Type0 = kinded_type(SubType0, Kind),
strip_module_names_from_type(StripWhat, SubType0, SubType),
Type = kinded_type(SubType, Kind)
).
strip_module_names_from_type_list(StripWhat, Types0, Types) :-
list.map(strip_module_names_from_type(StripWhat), Types0, Types).
:- pred strip_module_names_from_ho_inst_info(strip_what_module_names::in,
ho_inst_info::in, ho_inst_info::out) is det.
strip_module_names_from_ho_inst_info(StripWhat, HOInstInfo0, HOInstInfo) :-
(
HOInstInfo0 = none_or_default_func,
HOInstInfo = none_or_default_func
;
HOInstInfo0 = higher_order(PredInstInfo0),
PredInstInfo0 = pred_inst_info(PorF, Modes0, RegTypes, Detism),
strip_module_names_from_mode_list(StripWhat, Modes0, Modes),
PredInstInfo = pred_inst_info(PorF, Modes, RegTypes, Detism),
HOInstInfo = higher_order(PredInstInfo)
).
%---------------------------------------------------------------------------%
prog_constraints_get_tvars(constraints(Univ, Exist), TVars) :-
constraint_list_get_tvars(Univ, UnivTVars),
constraint_list_get_tvars(Exist, ExistTVars),
list.append(UnivTVars, ExistTVars, TVars).
constraint_list_get_tvars(Constraints, TVars) :-
list.map(constraint_get_tvars, Constraints, TVarsList),
list.condense(TVarsList, TVars).
constraint_get_tvars(constraint(_ClassName, ArgTypes), TVars) :-
type_vars_in_types(ArgTypes, TVars).
get_unconstrained_tvars(Tvars, Constraints, Unconstrained) :-
constraint_list_get_tvars(Constraints, ConstrainedTvars),
list.delete_elems(Tvars, ConstrainedTvars, Unconstrained0),
list.remove_dups(Unconstrained0, Unconstrained).
%---------------------------------------------------------------------------%
% Every element of this list must be reflected in the code of
% builtin_type_ctor in type_ctor_info.m.
builtin_type_ctors_with_no_hlds_type_defn =
[ type_ctor(qualified(mercury_public_builtin_module, "int"), 0),
type_ctor(qualified(mercury_public_builtin_module, "uint"), 0),
type_ctor(qualified(mercury_public_builtin_module, "int8"), 0),
type_ctor(qualified(mercury_public_builtin_module, "uint8"), 0),
type_ctor(qualified(mercury_public_builtin_module, "int16"), 0),
type_ctor(qualified(mercury_public_builtin_module, "uint16"), 0),
type_ctor(qualified(mercury_public_builtin_module, "int32"), 0),
type_ctor(qualified(mercury_public_builtin_module, "uint32"), 0),
type_ctor(qualified(mercury_public_builtin_module, "int64"), 0),
type_ctor(qualified(mercury_public_builtin_module, "uint64"), 0),
type_ctor(qualified(mercury_public_builtin_module, "string"), 0),
type_ctor(qualified(mercury_public_builtin_module, "character"), 0),
type_ctor(qualified(mercury_public_builtin_module, "float"), 0),
type_ctor(qualified(mercury_public_builtin_module, "pred"), 0),
type_ctor(qualified(mercury_public_builtin_module, "func"), 0),
type_ctor(qualified(mercury_public_builtin_module, "void"), 0),
type_ctor(qualified(mercury_public_builtin_module, "tuple"), 0)
].
is_type_ctor_a_builtin_dummy(TypeCtor) = IsBuiltinDummy :-
% Please keep the set of type_ctors for which we return
% is_builtin_dummy_type_ctor in sync with classify_type_ctor_if_special.
TypeCtor = type_ctor(CtorSymName, TypeArity),
(
CtorSymName = qualified(ModuleName, TypeName),
( if
(
TypeName = "state",
TypeArity = 0,
ModuleName = mercury_io_module
;
TypeName = "store",
TypeArity = 1,
ModuleName = mercury_std_lib_module_name(unqualified("store"))
)
then
IsBuiltinDummy = is_builtin_dummy_type_ctor
else if
(
TypeName = "store_at_ref_type",
TypeArity = 1,
ModuleName = mercury_private_builtin_module
;
TypeName = "comparison_result",
TypeArity = 0,
ModuleName = mercury_public_builtin_module
)
then
IsBuiltinDummy = is_builtin_non_dummy_type_ctor
else
IsBuiltinDummy = is_not_builtin_dummy_type_ctor
)
;
CtorSymName = unqualified(_TypeName),
IsBuiltinDummy = is_not_builtin_dummy_type_ctor
).
type_is_io_state(Type) :-
type_to_ctor_and_args(Type, TypeCtor, []),
ModuleName = mercury_io_module,
TypeCtor = type_ctor(qualified(ModuleName, "state"), 0).
type_ctor_is_array(type_ctor(qualified(unqualified("array"), "array"), 1)).
type_ctor_is_bitmap(
type_ctor(qualified(unqualified("bitmap"), "bitmap"), 0)).
is_introduced_type_info_type(Type) :-
type_to_ctor(Type, TypeCtor),
is_introduced_type_info_type_ctor(TypeCtor).
is_introduced_type_info_type_ctor(TypeCtor) :-
TypeCtor = type_ctor(qualified(PrivateBuiltin, Name), 0),
PrivateBuiltin = mercury_private_builtin_module,
( Name = "type_info"
; Name = "type_ctor_info"
; Name = "typeclass_info"
; Name = "base_typeclass_info"
).
is_introduced_type_info_type_category(TypeCtorCat) = IsIntroduced :-
(
( TypeCtorCat = ctor_cat_builtin(_)
; TypeCtorCat = ctor_cat_higher_order
; TypeCtorCat = ctor_cat_tuple
; TypeCtorCat = ctor_cat_enum(_)
; TypeCtorCat = ctor_cat_builtin_dummy
; TypeCtorCat = ctor_cat_variable
; TypeCtorCat = ctor_cat_void
; TypeCtorCat = ctor_cat_user(_)
),
IsIntroduced = no
;
TypeCtorCat = ctor_cat_system(_),
IsIntroduced = yes
).
%---------------------------------------------------------------------------%
remove_new_prefix(unqualified(Name0), unqualified(Name)) :-
string.append("new ", Name, Name0).
remove_new_prefix(qualified(Module, Name0), qualified(Module, Name)) :-
string.append("new ", Name, Name0).
add_new_prefix(unqualified(Name0), unqualified(Name)) :-
string.append("new ", Name0, Name).
add_new_prefix(qualified(Module, Name0), qualified(Module, Name)) :-
string.append("new ", Name0, Name).
%---------------------------------------------------------------------------%
make_type_ctor(term.atom(Name), Arity, type_ctor(unqualified(Name), Arity)).
%---------------------------------------------------------------------------%
cell_cons_id(type_info_cell(Ctor)) = type_info_cell_constructor(Ctor).
cell_cons_id(typeclass_info_cell) = typeclass_info_cell_constructor.
cell_inst_cons_id(Which, Arity) = InstConsId :-
% Neither of these function symbols exist, even with fake arity,
% but they do not need to.
(
Which = type_info_cell(_),
Symbol = "type_info"
;
Which = typeclass_info_cell,
Symbol = "typeclass_info"
),
PrivateBuiltin = mercury_private_builtin_module,
TypeCtor = cons_id_dummy_type_ctor,
InstConsId = cons(qualified(PrivateBuiltin, Symbol), Arity, TypeCtor).
%---------------------------------------------------------------------------%
qualify_cons_id(Args, ConsId0, ConsId, InstConsId) :-
(
ConsId0 = cons(Name0, OrigArity, TypeCtor),
( if TypeCtor = type_ctor(qualified(TypeModule, _), _) then
UnqualName = unqualify_name(Name0),
Name = qualified(TypeModule, UnqualName),
ConsId = cons(Name, OrigArity, TypeCtor)
else
ConsId = ConsId0
),
InstConsId = ConsId
;
ConsId0 = type_info_cell_constructor(CellCtor),
ConsId = ConsId0,
InstConsId = cell_inst_cons_id(type_info_cell(CellCtor),
list.length(Args))
;
ConsId0 = typeclass_info_cell_constructor,
ConsId = ConsId0,
InstConsId = cell_inst_cons_id(typeclass_info_cell, list.length(Args))
;
( ConsId0 = tuple_cons(_)
; ConsId0 = closure_cons(_, _)
; ConsId0 = some_int_const(_)
; ConsId0 = float_const(_)
; ConsId0 = char_const(_)
; ConsId0 = string_const(_)
; ConsId0 = impl_defined_const(_)
; ConsId0 = type_ctor_info_const(_, _, _)
; ConsId0 = base_typeclass_info_const(_, _, _, _)
; ConsId0 = type_info_const(_)
; ConsId0 = typeclass_info_const(_)
; ConsId0 = ground_term_const(_, _)
; ConsId0 = table_io_entry_desc(_)
; ConsId0 = tabling_info_const(_)
; ConsId0 = deep_profiling_proc_layout(_)
),
ConsId = ConsId0,
InstConsId = ConsId
).
%---------------------------------------------------------------------------%
type_constructors_are_type_info(Ctors) :-
Ctors = [Ctor],
Ctor = ctor(_Ordinal, MaybeExistConstraints, FunctorName,
[_CtorArg], 1, _Context),
unqualify_private_builtin(FunctorName, Name),
name_is_type_info(Name),
MaybeExistConstraints = no_exist_constraints.
% If the sym_name is in the private_builtin module, unqualify it,
% otherwise fail. All, user-defined types should be module-qualified
% by the time this predicate is called, so we assume that any unqualified
% names are in private_builtin.
%
:- pred unqualify_private_builtin(sym_name::in, string::out) is semidet.
unqualify_private_builtin(unqualified(Name), Name).
unqualify_private_builtin(qualified(ModuleName, Name), Name) :-
ModuleName = mercury_private_builtin_module.
:- pred name_is_type_info(string::in) is semidet.
name_is_type_info("type_info").
name_is_type_info("type_ctor_info").
name_is_type_info("typeclass_info").
name_is_type_info("base_typeclass_info").
%---------------------------------------------------------------------------%
non_sub_du_type_is_notag(OoMCtors, MaybeCanonical) :-
OoMCtors = one_or_more(Ctor, []),
Ctor = ctor(_Ordinal, MaybeExistConstraints, _FunctorName, [_CtorArg], 1,
_Context),
MaybeExistConstraints = no_exist_constraints,
MaybeCanonical = canon.
non_sub_du_type_is_enum(DuDetails, NumFunctors) :-
DuDetails = type_details_du(OoMCtors, _MaybeCanon, _MaybeDirectArgCtors),
Ctors = one_or_more_to_list(OoMCtors),
Ctors = [_, _ | _],
all_functors_are_constants(Ctors, 0, NumFunctors).
num_bits_needed_for_n_dense_values(NumValues, NumBits) :-
int.log2(NumValues, NumBits).
:- pred all_functors_are_constants(list(constructor)::in,
int::in, int::out) is semidet.
all_functors_are_constants([], !NumFunctors).
all_functors_are_constants([Ctor | Ctors], !NumFunctors) :-
Ctor = ctor(_Ordinal, MaybeExistConstraints, _Name, ArgTypes, _Arity,
_Context),
ArgTypes = [],
MaybeExistConstraints = no_exist_constraints,
!:NumFunctors = !.NumFunctors + 1,
all_functors_are_constants(Ctors, !NumFunctors).
non_sub_du_type_is_dummy(DuDetails) :-
DuDetails = type_details_du(Ctors, MaybeCanonical, MaybeDirectArgCtors),
Ctors = one_or_more(Ctor, []),
Ctor = ctor(_Ordinal, MaybeExistConstraints, _FunctorName, [], 0,
_Context),
MaybeExistConstraints = no_exist_constraints,
MaybeCanonical = canon,
MaybeDirectArgCtors = no.
%---------------------------------------------------------------------------%
%
% Type unification.
%
type_unify(X, Y, HeadTypeParams, !Bindings) :-
( if X = type_variable(VarX, _) then
type_unify_var(VarX, Y, HeadTypeParams, !Bindings)
else if Y = type_variable(VarY, _) then
type_unify_var(VarY, X, HeadTypeParams, !Bindings)
else if type_unify_nonvar(X, Y, HeadTypeParams, !Bindings) then
true
else
% Some special cases are not handled above. We handle them separately
% here.
type_unify_special(X, Y, HeadTypeParams, !Bindings)
).
:- pred type_unify_var(tvar::in, mer_type::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings) :-
( if TypeY = type_variable(VarY, KindY) then
type_unify_var_var(VarX, VarY, KindY, HeadTypeParams, !Bindings)
else if map.search(!.Bindings, VarX, BindingOfX) then
% VarX has a binding. Y is not a variable.
type_unify(BindingOfX, TypeY, HeadTypeParams, !Bindings)
else
% VarX has no binding, so bind it to TypeY.
not type_occurs(TypeY, VarX, !.Bindings),
not list.member(VarX, HeadTypeParams),
map.det_insert(VarX, TypeY, !Bindings)
).
:- pred type_unify_var_var(tvar::in, tvar::in, kind::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
type_unify_var_var(X, Y, Kind, HeadTypeParams, !Bindings) :-
( if list.member(Y, HeadTypeParams) then
type_unify_head_type_param(X, Y, Kind, HeadTypeParams, !Bindings)
else if list.member(X, HeadTypeParams) then
type_unify_head_type_param(Y, X, Kind, HeadTypeParams, !Bindings)
else if map.search(!.Bindings, X, BindingOfX) then
( if map.search(!.Bindings, Y, BindingOfY) then
% Both X and Y already have bindings - just unify the
% types they are bound to.
type_unify(BindingOfX, BindingOfY, HeadTypeParams, !Bindings)
else
% Y hasn't been bound yet.
apply_rec_subst_to_type(!.Bindings, BindingOfX, SubstBindingOfX),
( if SubstBindingOfX = type_variable(Y, _) then
true
else
not type_occurs(SubstBindingOfX, Y, !.Bindings),
map.det_insert(Y, SubstBindingOfX, !Bindings)
)
)
else
% Neither X nor Y is a head type param. X had not been bound yet.
( if map.search(!.Bindings, Y, BindingOfY) then
apply_rec_subst_to_type(!.Bindings, BindingOfY, SubstBindingOfY),
( if SubstBindingOfY = type_variable(X, _) then
true
else
not type_occurs(SubstBindingOfY, X, !.Bindings),
map.det_insert(X, SubstBindingOfY, !Bindings)
)
else
% Both X and Y are unbound type variables - bind one to the other.
( if X = Y then
true
else
map.det_insert(X, type_variable(Y, Kind), !Bindings)
)
)
).
:- pred type_unify_head_type_param(tvar::in, tvar::in, kind::in,
list(tvar)::in, tsubst::in, tsubst::out) is semidet.
type_unify_head_type_param(Var, HeadVar, Kind, HeadTypeParams, !Bindings) :-
( if map.search(!.Bindings, Var, BindingOfVar) then
BindingOfVar = type_variable(Var2, _),
type_unify_head_type_param(Var2, HeadVar, Kind, HeadTypeParams,
!Bindings)
else
( if Var = HeadVar then
true
else
not list.member(Var, HeadTypeParams),
map.det_insert(Var, type_variable(HeadVar, Kind), !Bindings)
)
).
% Unify two types, neither of which are variables. Two special cases
% which are not handled here are apply_n types and kinded types.
% Those are handled below.
%
:- pred type_unify_nonvar(mer_type::in, mer_type::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
type_unify_nonvar(TypeX, TypeY, HeadTypeParams, !Bindings) :-
(
TypeX = defined_type(SymName, ArgTypesX, _),
TypeY = defined_type(SymName, ArgTypesY, _),
% Instead of insisting that the names are equal and the arg lists
% unify, we should consider attempting to expand equivalence types
% first. That would require the type table to be passed in to the
% unification algorithm, though.
type_unify_list(ArgTypesX, ArgTypesY, HeadTypeParams, !Bindings)
;
TypeX = builtin_type(BuiltinType),
TypeY = builtin_type(BuiltinType)
;
TypeX = higher_order_type(PorF, ArgTypesX, _, Purity, EvalMethod),
TypeY = higher_order_type(PorF, ArgTypesY, _, Purity, EvalMethod),
type_unify_list(ArgTypesX, ArgTypesY, HeadTypeParams, !Bindings)
;
TypeX = tuple_type(ArgTypesX, _),
TypeY = tuple_type(ArgTypesY, _),
type_unify_list(ArgTypesX, ArgTypesY, HeadTypeParams, !Bindings)
).
% Handle apply_n types and kinded types.
%
:- pred type_unify_special(mer_type::in, mer_type::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
type_unify_special(TypeX, TypeY, HeadTypeParams, !Bindings) :-
( if TypeX = apply_n_type(VarX, ArgTypesX, _) then
type_unify_apply(TypeY, VarX, ArgTypesX, HeadTypeParams, !Bindings)
else if TypeY = apply_n_type(VarY, ArgTypesY, _) then
type_unify_apply(TypeX, VarY, ArgTypesY, HeadTypeParams, !Bindings)
else if TypeX = kinded_type(RawX, _) then
( if TypeY = kinded_type(RawY, _) then
type_unify(RawX, RawY, HeadTypeParams, !Bindings)
else
type_unify(RawX, TypeY, HeadTypeParams, !Bindings)
)
else if TypeY = kinded_type(RawY, _) then
type_unify(TypeX, RawY, HeadTypeParams, !Bindings)
else
fail
).
% The idea here is that we try to strip off arguments from Y starting
% from the end and unify each with the corresponding argument of X.
% If we reach an atomic type before the arguments run out, we fail.
% If we reach a variable before the arguments run out, we unify it
% with what remains of the apply_n expression. If we manage to unify
% all of the arguments, we unify the apply_n variable with what remains
% of the other expression.
%
% Note that Y is not a variable, since that case would have been caught
% by type_unify.
%
:- pred type_unify_apply(mer_type::in, tvar::in, list(mer_type)::in,
list(tvar)::in, tsubst::in, tsubst::out) is semidet.
type_unify_apply(TypeY, VarX, ArgTypesX0, HeadTypeParams, !Bindings) :-
(
TypeY = defined_type(NameY, ArgTypesY0, KindY0),
type_unify_args(ArgTypesX0, ArgTypesY0, ArgTypesY, KindY0, KindY,
HeadTypeParams, !Bindings),
type_unify_var(VarX, defined_type(NameY, ArgTypesY, KindY),
HeadTypeParams, !Bindings)
;
TypeY = builtin_type(_),
ArgTypesX0 = [],
type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings)
;
TypeY = higher_order_type(_, _, _, _, _),
ArgTypesX0 = [],
type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings)
;
TypeY = tuple_type(ArgTypesY0, KindY0),
type_unify_args(ArgTypesX0, ArgTypesY0, ArgTypesY, KindY0, KindY,
HeadTypeParams, !Bindings),
type_unify_var(VarX, tuple_type(ArgTypesY, KindY), HeadTypeParams,
!Bindings)
;
TypeY = apply_n_type(VarY, ArgTypesY0, Kind0),
list.length(ArgTypesX0, NArgTypesX0),
list.length(ArgTypesY0, NArgTypesY0),
compare(Result, NArgTypesX0, NArgTypesY0),
(
Result = (<),
type_unify_args(ArgTypesX0, ArgTypesY0, ArgTypesY, Kind0, Kind,
HeadTypeParams, !Bindings),
type_unify_var(VarX, apply_n_type(VarY, ArgTypesY, Kind),
HeadTypeParams, !Bindings)
;
Result = (=),
% We know here that the list of remaining args will be empty.
type_unify_args(ArgTypesX0, ArgTypesY0, _, Kind0, Kind,
HeadTypeParams, !Bindings),
type_unify_var_var(VarX, VarY, Kind, HeadTypeParams, !Bindings)
;
Result = (>),
type_unify_args(ArgTypesY0, ArgTypesX0, ArgTypesX, Kind0, Kind,
HeadTypeParams, !Bindings),
type_unify_var(VarY, apply_n_type(VarX, ArgTypesX, Kind),
HeadTypeParams, !Bindings)
)
;
TypeY = kinded_type(RawY, _),
type_unify_apply(RawY, VarX, ArgTypesX0, HeadTypeParams, !Bindings)
;
TypeY = builtin_type(_),
% XXX I (zs) am not sure *why* it is ok to fail here.
fail
).
:- pred type_unify_args(list(mer_type)::in, list(mer_type)::in,
list(mer_type)::out, kind::in, kind::out, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
type_unify_args(ArgTypesX, ArgTypesY0, ArgTypesY,
KindY0, KindY, HeadTypeParams, !Bindings) :-
list.reverse(ArgTypesX, RevArgTypesX),
list.reverse(ArgTypesY0, RevArgTypesY0),
type_unify_rev_args(RevArgTypesX, RevArgTypesY0, RevArgTypesY,
KindY0, KindY, HeadTypeParams, !Bindings),
list.reverse(RevArgTypesY, ArgTypesY).
:- pred type_unify_rev_args(list(mer_type)::in, list(mer_type)::in,
list(mer_type)::out, kind::in, kind::out, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
type_unify_rev_args([], ArgTypesY, ArgTypesY, KindY, KindY, _, !Bindings).
type_unify_rev_args([ArgTypeX | ArgTypesX], [ArgTypeY0 | ArgTypesY0],
ArgTypesY, KindY0, KindY, HeadTypeParams, !Bindings) :-
type_unify(ArgTypeX, ArgTypeY0, HeadTypeParams, !Bindings),
KindY1 = kind_arrow(get_type_kind(ArgTypeY0), KindY0),
type_unify_rev_args(ArgTypesX, ArgTypesY0, ArgTypesY,
KindY1, KindY, HeadTypeParams, !Bindings).
type_unify_list([], [], _HeadTypeParams, !Bindings).
type_unify_list([X | Xs], [Y | Ys], HeadTypeParams, !Bindings) :-
type_unify(X, Y, HeadTypeParams, !Bindings),
type_unify_list(Xs, Ys, HeadTypeParams, !Bindings).
% type_occurs(Type, Var, Subst) succeeds iff Type contains Var,
% perhaps indirectly via the substitution. (The variable must not
% be mapped by the substitution.)
%
:- pred type_occurs(mer_type::in, tvar::in, tsubst::in) is semidet.
type_occurs(TypeX, Y, Bindings) :-
require_complete_switch [TypeX]
(
TypeX = type_variable(X, _),
( if X = Y then
true
else
map.search(Bindings, X, BindingOfX),
type_occurs(BindingOfX, Y, Bindings)
)
;
TypeX = defined_type(_, ArgTypes, _),
type_occurs_list(ArgTypes, Y, Bindings)
;
TypeX = higher_order_type(_, ArgTypes, _, _, _),
type_occurs_list(ArgTypes, Y, Bindings)
;
TypeX = tuple_type(ArgTypes, _),
type_occurs_list(ArgTypes, Y, Bindings)
;
TypeX = apply_n_type(X, ArgTypes, _),
(
X = Y
;
type_occurs_list(ArgTypes, Y, Bindings)
;
map.search(Bindings, X, BindingOfX),
type_occurs(BindingOfX, Y, Bindings)
)
;
TypeX = kinded_type(TypeX1, _),
type_occurs(TypeX1, Y, Bindings)
;
TypeX = builtin_type(_),
fail
).
:- pred type_occurs_list(list(mer_type)::in, tvar::in, tsubst::in) is semidet.
type_occurs_list([X | Xs], Y, Bindings) :-
(
type_occurs(X, Y, Bindings)
;
type_occurs_list(Xs, Y, Bindings)
).
%---------------------------------------------------------------------------%
type_subsumes(TypeA, TypeB, TypeSubst) :-
% TypeA subsumes TypeB iff TypeA can be unified with TypeB
% without binding any of the type variables in TypeB.
type_vars_in_type(TypeB, TypeBVars),
map.init(TypeSubst0),
type_unify(TypeA, TypeB, TypeBVars, TypeSubst0, TypeSubst).
type_subsumes_det(TypeA, TypeB, TypeSubst) :-
( if type_subsumes(TypeA, TypeB, TypeSubstPrime) then
TypeSubst = TypeSubstPrime
else
unexpected($pred, "type_subsumes failed")
).
type_list_subsumes(TypesA, TypesB, TypeSubst) :-
% TypesA subsumes TypesB iff TypesA can be unified with TypesB
% without binding any of the type variables in TypesB.
type_vars_in_types(TypesB, TypesBVars),
map.init(TypeSubst0),
type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
type_list_subsumes_det(TypesA, TypesB, TypeSubst) :-
( if type_list_subsumes(TypesA, TypesB, TypeSubstPrime) then
TypeSubst = TypeSubstPrime
else
unexpected($pred, "type_list_subsumes failed")
).
arg_type_list_subsumes(TVarSet, ExistQVars, ActualArgTypes, HeadTypeParams,
CalleeTVarSet, PredKindMap, PredExistQVars, PredArgTypes) :-
% Rename the type variables in the callee's argument types.
tvarset_merge_renaming(TVarSet, CalleeTVarSet, _TVarSet1, Renaming),
apply_variable_renaming_to_tvar_kind_map(Renaming, PredKindMap,
ParentKindMap),
apply_variable_renaming_to_type_list(Renaming, PredArgTypes,
ParentArgTypes),
apply_variable_renaming_to_tvar_list(Renaming, PredExistQVars,
ParentExistQVars),
% Check that the types of the candidate predicate/function
% subsume the actual argument types.
% [This is the right thing to do even for calls to
% existentially typed preds, because we're using the
% type variables from the callee's pred decl (obtained
% from the pred_info via pred_info_get_arg_types) not the types
% inferred from the callee's clauses (and stored in the
% clauses_info and proc_info) -- the latter
% might not subsume the actual argument types.]
(
ExistQVars = [],
type_list_subsumes(ParentArgTypes, ActualArgTypes, ParentToActualSubst)
;
ExistQVars = [_ | _],
% For calls to existentially type preds, we may need to bind
% type variables in the caller, not just those in the callee.
type_unify_list(ParentArgTypes, ActualArgTypes, HeadTypeParams,
map.init, ParentToActualSubst)
),
% Check that the type substitution did not bind any existentially
% typed variables to non-ground types.
(
ParentExistQVars = []
% Optimize common case.
;
ParentExistQVars = [_ | _],
apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualSubst,
ParentExistQVars, ActualExistQTypes),
all [T] (
list.member(T, ActualExistQTypes)
=>
T = type_variable(_, _)
)
% It might make sense to also check that the type substitution
% did not bind any existentially typed variables to universally
% quantified type variables in the caller's argument types.
).
%---------------------------------------------------------------------------%
compute_caller_callee_type_substitution(CalleeArgTypes, CallerArgTypes,
ExternalTypeParams, CalleeExistQVars, TypeSubn) :-
(
CalleeExistQVars = [],
( if type_list_subsumes(CalleeArgTypes, CallerArgTypes, TypeSubn0) then
TypeSubn = TypeSubn0
else
% The callee's arg types should always be unifiable with the
% caller's, otherwise there is a type error that should have
% been detected by typechecking. But polymorphism.m introduces
% type-incorrect code -- e.g. compare(Res, EnumA, EnumB) gets
% converted into builtin_compare_int(Res, EnumA, EnumB), which
% is a type error, since it assumes that an enumeration is an int.
% In those cases, we don't need to worry about the type
% substitution. (Perhaps it would be better if polymorphism
% introduced calls to unsafe_type_cast/2 for such cases.)
map.init(TypeSubn)
)
;
CalleeExistQVars = [_ | _],
% For calls to existentially type preds, we may need to bind
% type variables in the caller, as well as in the callee.
( if
map.init(TypeSubn0),
type_unify_list(CalleeArgTypes, CallerArgTypes, ExternalTypeParams,
TypeSubn0, TypeSubn1)
then
TypeSubn = TypeSubn1
else
unexpected($pred, "type unification failed")
)
).
%---------------------------------------------------------------------------%
apply_partial_map_to_list(_PartialMap, [], []).
apply_partial_map_to_list(PartialMap, [X | Xs], [Y | Ys]) :-
( if map.search(PartialMap, X, Y0) then
Y = Y0
else
Y = X
),
apply_partial_map_to_list(PartialMap, Xs, Ys).
%---------------------------------------------------------------------------%
:- end_module parse_tree.prog_type.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink