mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-14 05:12:33 +00:00
92966551f1
Estimated hours taken: 16
Branches: main
Replace the workaround for the bootstrapping problem with deep profiling grades
with a proper fix. The fix requires changing the builtin generic unify and
compare routines by removing the pretest comparing the two argument words
for equality. Since this can alter the algorithmic complexity of the program
(for the worse) which a profiler should definitely avoid, we compensate for
this by adding the pretest to the compiler-generated unify and compare
predicates. Since these pretests are executed even when the deleted pretest
wouldn't be, this can also alter algorithmic complexity (for the better)
at the cost of higher constant factors. However, the likelyhood of such
alteration is much smaller: if the top level of a term doesn't match, chances
are most of the function symbols at the lower levels won't match either.
In any case, the user has the option of getting this better algorithmic
complexity anyway by specifying the new option --should-pretest-equality.
However, until we have more experience with it, the documentation of the
new option is commented out.
runtime/mercury_conf_param.h:
Remove the workaround.
runtime/mercury_unify_compare_body.h:
Remove the problematic pretest, and document the problem that would
occur in its presence. Document the user_by_rtti dummy type
constructor. Fix some misleading abort messages.
compiler/options.m:
Add the --should-pretest-equality option.
Add (commented out) documentation for another option for which it was
missing.
doc/user_guide.texi:
Add (commented out) documentation for the new option, and for some
others which it was missing.
compiler/handle_options.m:
Make deep profiling imply the need for pretests in compiler generated
unify and compare predicates.
compiler/unify_proc.m:
If the new option is set, add pretests to unify and compare predicates.
We have to be careful to make sure that we don't add pretests if they
would try to unify two non-ground terms, or if the unification is
guaranteed to fail (since the casts in the pretest would obscure this
fact).
Implementing this required changing the approach of this module.
Instead of most predicates generating single clauses, they now generate
disjuncts for a disjunction that itself can be put inside the
if-then-else whose condition is the pretest. Since these predicates
not longer generate clauses, their names have been changed accordingly.
compiler/hlds_goal.m:
Add a goal feature for marking an if-then-else as representing
a pretest.
compiler/saved_vars.m:
Handle the new goal feature.
compiler/goal_util.m:
Add a function for stripping pretests away.
compiler/post_term_analysis.m:
compiler/term_constr_build.m:
compiler/term_pass1.m:
compiler/term_pass2.m:
Strip pretests away before termination analysis, since the analysis
can't yet prove termination in the presence of the pretest.
compiler/prog_type.m:
Add some auxilary predicates, and change the signature of an existing
predicate to make it more convenient to use.
compiler/type_util.m:
Conform to the change in prog_type.m, and in the process fix code to
avoid the assumption that the names of standard library modules are
unqualified (since the plan is to put them in package "std").
tests/hard_coded/profdeep_seg_fault.{m,exp}:
Fix the test case to be more readable and to generate properly
line-terminated output, now that we pass it.
BUGS:
Remove the entry for the bug fixed by this diff.
1404 lines
52 KiB
Mathematica
1404 lines
52 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 2005-2007 The University of Melbourne.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: prog_type.m.
|
|
% Main author: fjh.
|
|
%
|
|
% Utility predicates dealing with type 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 libs.globals.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module bool.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- 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,
|
|
% EvalMeth):
|
|
%
|
|
% 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.
|
|
|
|
% 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.
|
|
|
|
% Remove the kind annotation at the top-level if there is one,
|
|
% otherwise return the type unchanged.
|
|
%
|
|
:- func strip_kind_annotation(mer_type) = mer_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 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, TypeArgs):
|
|
%
|
|
% Check if the principal type constructor of Type is of variable arity.
|
|
% If yes, return the type constructor as TypeCtor and its args as
|
|
% TypeArgs. 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.
|
|
% Fail 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 and argument types.
|
|
% Fail 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 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, in order of their
|
|
% first occurrence in a depth-first, left-right traversal.
|
|
%
|
|
:- pred type_vars(mer_type::in, list(tvar)::out) is det.
|
|
|
|
% Return a list of the type variables of a list of types, in order
|
|
% of their first occurrence in a depth-first, left-right traversal.
|
|
%
|
|
:- pred type_vars_list(list(mer_type)::in, list(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_func_type(purity::in, lambda_eval_method::in,
|
|
list(mer_type)::in, mer_type::in, mer_type::out) is det.
|
|
|
|
% Make error messages more readable by removing "builtin."
|
|
% qualifiers.
|
|
%
|
|
:- pred strip_builtin_qualifiers_from_type(mer_type::in, mer_type::out) is det.
|
|
|
|
:- pred strip_builtin_qualifiers_from_type_list(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.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% 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).
|
|
|
|
% is_builtin_dummy_argument_type(type_ctor):
|
|
%
|
|
% Is the given type constructor a dummy type irrespective
|
|
% of its definition?
|
|
%
|
|
:- pred is_builtin_dummy_argument_type(type_ctor::in) is semidet.
|
|
|
|
% Certain types, e.g. io.state and store.store(S), are just dummy types
|
|
% used to ensure logical semantics; there is no need to actually pass them,
|
|
% and so 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 two cases: either it is a builtin
|
|
% dummy type, or it has only a single function symbol of arity zero.
|
|
%
|
|
:- pred constructor_list_represents_dummy_argument_type(list(constructor)::in,
|
|
maybe(unify_compare)::in) is semidet.
|
|
|
|
:- 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_category) = bool.
|
|
|
|
% 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).
|
|
|
|
% In the forwards mode, this predicate checks for a "new " prefix
|
|
% at the start of the functor name, and removes it if present;
|
|
% it fails if there is no such prefix.
|
|
% In the reverse mode, this predicate prepends such a prefix.
|
|
% (These prefixes are used for construction unifications
|
|
% with existentially typed functors.)
|
|
%
|
|
:- pred remove_new_prefix(sym_name, sym_name).
|
|
:- mode remove_new_prefix(in, out) is semidet.
|
|
:- mode remove_new_prefix(out, in) is det.
|
|
|
|
:- type type_category
|
|
---> type_cat_int
|
|
; type_cat_char
|
|
; type_cat_string
|
|
; type_cat_float
|
|
; type_cat_higher_order
|
|
; type_cat_tuple
|
|
; type_cat_enum
|
|
; type_cat_dummy
|
|
; type_cat_variable
|
|
; type_cat_type_info
|
|
; type_cat_type_ctor_info
|
|
; type_cat_typeclass_info
|
|
; type_cat_base_typeclass_info
|
|
; type_cat_void
|
|
; type_cat_user_ctor.
|
|
|
|
% Construct builtin types.
|
|
%
|
|
:- func int_type = mer_type.
|
|
:- func string_type = mer_type.
|
|
:- func float_type = mer_type.
|
|
:- func char_type = mer_type.
|
|
:- func void_type = mer_type.
|
|
:- func c_pointer_type = mer_type.
|
|
:- func heap_pointer_type = mer_type.
|
|
:- func sample_type_info_type = mer_type.
|
|
:- func sample_typeclass_info_type = mer_type.
|
|
:- func comparison_result_type = mer_type.
|
|
:- func io_state_type = mer_type.
|
|
|
|
% Construct the types of type_infos and type_ctor_infos.
|
|
%
|
|
:- func type_info_type = mer_type.
|
|
:- func type_ctor_info_type = mer_type.
|
|
|
|
% Given a constant and an arity, return a type_ctor.
|
|
% Fails if the constant is not an atom.
|
|
%
|
|
:- 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(mer_type::in, list(prog_var)::in, cons_id::in,
|
|
cons_id::out, cons_id::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,
|
|
ctor_existq_tvars :: existq_tvars,
|
|
ctor_tvar_kinds :: tvar_kind_map,
|
|
% kinds of existq_tvars
|
|
ctor_constraints :: list(prog_constraint),
|
|
% existential constraints
|
|
ctor_arg_types :: list(mer_type),
|
|
% functor argument types
|
|
ctor_result_type :: mer_type
|
|
% functor result type
|
|
).
|
|
|
|
% Check whether the type with the given list of constructors would be
|
|
% a no_tag type (which requires the list to include exactly one constructor
|
|
% with exactly one argument), and if so, return its constructor symbol,
|
|
% argument type, and the argument's name (if it has one).
|
|
%
|
|
% This doesn't do any checks for options that might be set (such as
|
|
% turning off no_tag_types). If you want those checks you should use
|
|
% type_is_no_tag_type/4, or if you really know what you are doing,
|
|
% perform the checks yourself.
|
|
%
|
|
:- pred type_constructors_are_no_tag_type(list(constructor)::in, sym_name::out,
|
|
mer_type::out, maybe(string)::out) is semidet.
|
|
|
|
% 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.
|
|
|
|
% type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReservedTag,
|
|
% Ctors, UserEqComp, FunctorName, FunctorArgType, MaybeFunctorArgName):
|
|
%
|
|
% Check whether some constructors are a no_tag type, and that this
|
|
% is compatible with the ReservedTag setting for this type and
|
|
% the grade options set in the globals.
|
|
% Assign single functor of arity one a `no_tag' tag (unless we are
|
|
% reserving a tag, or if it is one of the dummy types).
|
|
%
|
|
:- pred type_with_constructors_should_be_no_tag(globals::in, type_ctor::in,
|
|
bool::in, list(constructor)::in, maybe(unify_compare)::in, sym_name::out,
|
|
mer_type::out, maybe(string)::out) 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_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.
|
|
|
|
% This does the 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, ArgTypes, 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, list(mer_type)::in, tvarset::in,
|
|
tvar_kind_map::in, existq_tvars::in, list(mer_type)::in) is semidet.
|
|
|
|
% 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 libs.options.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module parse_tree.prog_out.
|
|
:- import_module parse_tree.prog_util.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
|
|
:- import_module string.
|
|
:- import_module svmap.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
type_is_var(Type) :-
|
|
strip_kind_annotation(Type) = type_variable(_, _).
|
|
|
|
type_is_nonvar(Type) :-
|
|
\+ 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,
|
|
PredArgTypes) :-
|
|
strip_kind_annotation(Type) =
|
|
higher_order_type(ArgTypes, MaybeRetType, Purity, EvalMethod),
|
|
(
|
|
MaybeRetType = yes(RetType),
|
|
PredOrFunc = pf_function,
|
|
PredArgTypes = list.append(ArgTypes, [RetType])
|
|
;
|
|
MaybeRetType = no,
|
|
PredOrFunc = pf_predicate,
|
|
PredArgTypes = ArgTypes
|
|
).
|
|
|
|
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)
|
|
;
|
|
Type = Type0
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
type_is_ground(Type) :-
|
|
\+ type_contains_var(Type, _).
|
|
|
|
type_is_nonground(Type) :-
|
|
type_contains_var(Type, _).
|
|
|
|
subst_type_is_ground(Type, TSubst) :-
|
|
\+ subst_type_is_nonground(Type, TSubst).
|
|
|
|
subst_type_is_nonground(Type, TSubst) :-
|
|
type_contains_var(Type, TVar),
|
|
( map.search(TSubst, TVar, Binding) ->
|
|
subst_type_is_nonground(Binding, TSubst)
|
|
;
|
|
true
|
|
).
|
|
|
|
type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) :-
|
|
( type_is_higher_order_details(Type, _Purity, PredOrFunc, _, TypeArgs0) ->
|
|
TypeArgs = TypeArgs0,
|
|
PredOrFuncStr = prog_out.pred_or_func_to_str(PredOrFunc),
|
|
TypeCtor = type_ctor(unqualified(PredOrFuncStr), 0)
|
|
; type_is_tuple(Type, TypeArgs1) ->
|
|
TypeArgs = TypeArgs1,
|
|
% XXX why tuple/0 and not {}/N ?
|
|
TypeCtor = type_ctor(unqualified("tuple"), 0)
|
|
;
|
|
fail
|
|
).
|
|
|
|
type_to_ctor_and_args(Type, TypeCtor, Args) :-
|
|
(
|
|
Type = defined_type(SymName, Args, _),
|
|
Arity = list.length(Args),
|
|
TypeCtor = type_ctor(SymName, Arity)
|
|
;
|
|
Type = builtin_type(BuiltinType),
|
|
builtin_type_to_string(BuiltinType, Name),
|
|
SymName = unqualified(Name),
|
|
Arity = 0,
|
|
Args = [],
|
|
TypeCtor = type_ctor(SymName, Arity)
|
|
;
|
|
Type = higher_order_type(Args0, MaybeRet, Purity, _EvalMethod),
|
|
Arity = list.length(Args0),
|
|
(
|
|
MaybeRet = yes(Ret),
|
|
PorFStr = "func",
|
|
Args = list.append(Args0, [Ret])
|
|
;
|
|
MaybeRet = no,
|
|
PorFStr = "pred",
|
|
Args = Args0
|
|
),
|
|
SymName0 = unqualified(PorFStr),
|
|
(
|
|
Purity = purity_pure,
|
|
SymName = SymName0
|
|
;
|
|
Purity = purity_semipure,
|
|
SymName = insert_module_qualifier("semipure", SymName0)
|
|
;
|
|
Purity = purity_impure,
|
|
SymName = insert_module_qualifier("impure", SymName0)
|
|
),
|
|
TypeCtor = type_ctor(SymName, Arity)
|
|
;
|
|
Type = tuple_type(Args, _),
|
|
SymName = unqualified("{}"),
|
|
Arity = list.length(Args),
|
|
TypeCtor = type_ctor(SymName, Arity)
|
|
;
|
|
Type = apply_n_type(_, _, _),
|
|
sorry(this_file, "apply/N types")
|
|
;
|
|
Type = kinded_type(SubType, _),
|
|
type_to_ctor_and_args(SubType, TypeCtor, Args)
|
|
).
|
|
|
|
type_to_ctor_and_args_det(Type, TypeCtor, Args) :-
|
|
( type_to_ctor_and_args(Type, TypeCtorPrime, ArgsPrime) ->
|
|
TypeCtor = TypeCtorPrime,
|
|
Args = ArgsPrime
|
|
;
|
|
unexpected(this_file,
|
|
"type_to_ctor_and_args_det: type_to_ctor_and_args failed")
|
|
).
|
|
|
|
type_to_ctor_det(Type, TypeCtor) :-
|
|
type_to_ctor_and_args_det(Type, TypeCtor, _Args).
|
|
|
|
type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc, EvalMethod) :-
|
|
TypeCtor = type_ctor(SymName, _Arity),
|
|
get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr),
|
|
(
|
|
PorFStr = "pred",
|
|
PredOrFunc = pf_predicate
|
|
;
|
|
PorFStr = "func",
|
|
PredOrFunc = pf_function
|
|
).
|
|
|
|
:- pred get_purity_and_eval_method(sym_name::in, purity::out,
|
|
lambda_eval_method::out, string::out) is semidet.
|
|
|
|
get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr) :-
|
|
(
|
|
SymName = qualified(unqualified(Qualifier), PorFStr),
|
|
(
|
|
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
|
|
).
|
|
|
|
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_list_to_type_list(_, [], []).
|
|
var_list_to_type_list(KindMap, [Var | Vars], [Type | Types]) :-
|
|
get_tvar_kind(KindMap, Var, Kind),
|
|
Type = type_variable(Var, Kind),
|
|
var_list_to_type_list(KindMap, Vars, Types).
|
|
|
|
type_vars(Type, TVars) :-
|
|
type_vars_2(Type, [], RevTVars),
|
|
list.reverse(RevTVars, TVarsDups),
|
|
list.remove_dups(TVarsDups, TVars).
|
|
|
|
:- pred type_vars_2(mer_type::in, list(tvar)::in, list(tvar)::out) is det.
|
|
|
|
type_vars_2(type_variable(Var, _), Vs, [Var | Vs]).
|
|
type_vars_2(defined_type(_, Args, _), !V) :-
|
|
type_vars_list_2(Args, !V).
|
|
type_vars_2(builtin_type(_), !V).
|
|
type_vars_2(higher_order_type(Args, MaybeRet, _, _), !V) :-
|
|
type_vars_list_2(Args, !V),
|
|
(
|
|
MaybeRet = yes(Ret),
|
|
type_vars_2(Ret, !V)
|
|
;
|
|
MaybeRet = no
|
|
).
|
|
type_vars_2(tuple_type(Args, _), !V) :-
|
|
type_vars_list_2(Args, !V).
|
|
type_vars_2(apply_n_type(Var, Args, _), !V) :-
|
|
!:V = [Var | !.V],
|
|
type_vars_list_2(Args, !V).
|
|
type_vars_2(kinded_type(Type, _), !V) :-
|
|
type_vars_2(Type, !V).
|
|
|
|
type_vars_list(Types, TVars) :-
|
|
type_vars_list_2(Types, [], RevTVars),
|
|
list.reverse(RevTVars, TVarsDups),
|
|
list.remove_dups(TVarsDups, TVars).
|
|
|
|
:- pred type_vars_list_2(list(mer_type)::in, list(tvar)::in, list(tvar)::out)
|
|
is det.
|
|
|
|
type_vars_list_2([], !V).
|
|
type_vars_list_2([Type | Types], !V) :-
|
|
type_vars_2(Type, !V),
|
|
type_vars_list_2(Types, !V).
|
|
|
|
type_contains_var(type_variable(Var, _), Var).
|
|
type_contains_var(defined_type(_, Args, _), Var) :-
|
|
type_list_contains_var(Args, Var).
|
|
type_contains_var(higher_order_type(Args, _, _, _), Var) :-
|
|
type_list_contains_var(Args, Var).
|
|
type_contains_var(higher_order_type(_, yes(Ret), _, _), Var) :-
|
|
type_contains_var(Ret, Var).
|
|
type_contains_var(tuple_type(Args, _), Var) :-
|
|
type_list_contains_var(Args, Var).
|
|
type_contains_var(apply_n_type(Var, _, _), Var).
|
|
type_contains_var(apply_n_type(_, Args, _), Var) :-
|
|
type_list_contains_var(Args, 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, Args, Type) :-
|
|
(
|
|
TypeCtor = type_ctor(unqualified(Name), 0),
|
|
builtin_type_to_string(BuiltinType, Name)
|
|
->
|
|
Type = builtin_type(BuiltinType)
|
|
;
|
|
type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc, EvalMethod)
|
|
->
|
|
construct_higher_order_type(Purity, PredOrFunc, EvalMethod, Args, Type)
|
|
;
|
|
type_ctor_is_tuple(TypeCtor)
|
|
->
|
|
% XXX kind inference: we assume the kind is star.
|
|
Type = tuple_type(Args, kind_star)
|
|
;
|
|
TypeCtor = type_ctor(SymName, _),
|
|
% XXX kind inference: we assume the kind is star.
|
|
Type = defined_type(SymName, Args, 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(ArgTypes, no, Purity, EvalMethod).
|
|
|
|
construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType,
|
|
Type) :-
|
|
Type = higher_order_type(ArgTypes, yes(RetType), Purity, EvalMethod).
|
|
|
|
strip_builtin_qualifiers_from_type(type_variable(Var, Kind),
|
|
type_variable(Var, Kind)).
|
|
strip_builtin_qualifiers_from_type(defined_type(Name0, Args0, Kind),
|
|
defined_type(Name, Args, Kind)) :-
|
|
(
|
|
Name0 = qualified(Module, Name1),
|
|
Module = mercury_public_builtin_module
|
|
->
|
|
Name = unqualified(Name1)
|
|
;
|
|
Name = Name0
|
|
),
|
|
strip_builtin_qualifiers_from_type_list(Args0, Args).
|
|
strip_builtin_qualifiers_from_type(builtin_type(BuiltinType),
|
|
builtin_type(BuiltinType)).
|
|
strip_builtin_qualifiers_from_type(
|
|
higher_order_type(Args0, MaybeRet0, Purity, EvalMethod),
|
|
higher_order_type(Args, MaybeRet, Purity, EvalMethod)) :-
|
|
strip_builtin_qualifiers_from_type_list(Args0, Args),
|
|
(
|
|
MaybeRet0 = yes(Ret0),
|
|
strip_builtin_qualifiers_from_type(Ret0, Ret),
|
|
MaybeRet = yes(Ret)
|
|
;
|
|
MaybeRet0 = no,
|
|
MaybeRet = no
|
|
).
|
|
strip_builtin_qualifiers_from_type(tuple_type(Args0, Kind),
|
|
tuple_type(Args, Kind)) :-
|
|
strip_builtin_qualifiers_from_type_list(Args0, Args).
|
|
strip_builtin_qualifiers_from_type(apply_n_type(Var, Args0, Kind),
|
|
apply_n_type(Var, Args, Kind)) :-
|
|
strip_builtin_qualifiers_from_type_list(Args0, Args).
|
|
strip_builtin_qualifiers_from_type(kinded_type(Type0, Kind),
|
|
kinded_type(Type, Kind)) :-
|
|
strip_builtin_qualifiers_from_type(Type0, Type).
|
|
|
|
strip_builtin_qualifiers_from_type_list(Types0, Types) :-
|
|
list.map(strip_builtin_qualifiers_from_type, Types0, Types).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
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(_Name, Args), TVars) :-
|
|
type_vars_list(Args, TVars).
|
|
|
|
get_unconstrained_tvars(Tvars, Constraints, Unconstrained) :-
|
|
constraint_list_get_tvars(Constraints, ConstrainedTvars),
|
|
list.delete_elems(Tvars, ConstrainedTvars, Unconstrained0),
|
|
list.remove_dups(Unconstrained0, Unconstrained).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
builtin_type_ctors_with_no_hlds_type_defn =
|
|
[ type_ctor(qualified(mercury_public_builtin_module, "int"), 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_builtin_dummy_argument_type(TypeCtor) :-
|
|
TypeCtor = type_ctor(CtorSymName, TypeArity),
|
|
CtorSymName = qualified(ModuleName, TypeName),
|
|
(
|
|
ModuleName = mercury_std_lib_module_name(unqualified("io")),
|
|
TypeName = "state",
|
|
TypeArity = 0
|
|
;
|
|
ModuleName = mercury_std_lib_module_name(unqualified("store")),
|
|
TypeName = "store",
|
|
TypeArity = 1
|
|
).
|
|
|
|
constructor_list_represents_dummy_argument_type([Ctor], no) :-
|
|
Ctor = ctor([], [], _, [], _).
|
|
|
|
type_is_io_state(Type) :-
|
|
type_to_ctor_and_args(Type, TypeCtor, []),
|
|
ModuleName = mercury_std_lib_module_name(unqualified("io")),
|
|
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_and_args(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(type_cat_int) = no.
|
|
is_introduced_type_info_type_category(type_cat_char) = no.
|
|
is_introduced_type_info_type_category(type_cat_string) = no.
|
|
is_introduced_type_info_type_category(type_cat_float) = no.
|
|
is_introduced_type_info_type_category(type_cat_higher_order) = no.
|
|
is_introduced_type_info_type_category(type_cat_tuple) = no.
|
|
is_introduced_type_info_type_category(type_cat_enum) = no.
|
|
is_introduced_type_info_type_category(type_cat_dummy) = no.
|
|
is_introduced_type_info_type_category(type_cat_variable) = no.
|
|
is_introduced_type_info_type_category(type_cat_type_info) = yes.
|
|
is_introduced_type_info_type_category(type_cat_type_ctor_info) = yes.
|
|
is_introduced_type_info_type_category(type_cat_typeclass_info) = yes.
|
|
is_introduced_type_info_type_category(type_cat_base_typeclass_info) = yes.
|
|
is_introduced_type_info_type_category(type_cat_void) = no.
|
|
is_introduced_type_info_type_category(type_cat_user_ctor) = no.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
put_typeinfo_vars_first(VarsList, VarTypes) =
|
|
TypeInfoVarsList ++ NonTypeInfoVarsList :-
|
|
split_vars_typeinfo_no_typeinfo(VarsList, VarTypes,
|
|
TypeInfoVarsList, NonTypeInfoVarsList).
|
|
|
|
remove_typeinfo_vars(VarTypes, VarsList) = NonTypeInfoVarsList :-
|
|
split_vars_typeinfo_no_typeinfo(VarsList, VarTypes, _,
|
|
NonTypeInfoVarsList).
|
|
|
|
remove_typeinfo_vars_from_set(VarTypes, VarsSet) =
|
|
set.from_list(remove_typeinfo_vars(VarTypes,
|
|
set.to_sorted_list(VarsSet))).
|
|
|
|
:- 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((pred(Var::in) is semidet :-
|
|
Type = map.lookup(VarTypes, Var),
|
|
is_introduced_type_info_type(Type)),
|
|
VarsList, TypeInfoVarsList, NonTypeInfoVarsList).
|
|
|
|
|
|
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).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
int_type = builtin_type(builtin_type_int).
|
|
|
|
string_type = builtin_type(builtin_type_string).
|
|
|
|
float_type = builtin_type(builtin_type_float).
|
|
|
|
char_type = builtin_type(builtin_type_character).
|
|
|
|
void_type = defined_type(unqualified("void"), [], kind_star).
|
|
|
|
c_pointer_type = defined_type(Name, [], kind_star) :-
|
|
BuiltinModule = mercury_public_builtin_module,
|
|
Name = qualified(BuiltinModule, "c_pointer").
|
|
|
|
heap_pointer_type = defined_type(Name, [], kind_star) :-
|
|
BuiltinModule = mercury_private_builtin_module,
|
|
Name = qualified(BuiltinModule, "heap_pointer").
|
|
|
|
sample_type_info_type = defined_type(Name, [], kind_star) :-
|
|
BuiltinModule = mercury_private_builtin_module,
|
|
Name = qualified(BuiltinModule, "sample_type_info").
|
|
|
|
sample_typeclass_info_type = defined_type(Name, [], kind_star) :-
|
|
BuiltinModule = mercury_private_builtin_module,
|
|
Name = qualified(BuiltinModule, "sample_typeclass_info").
|
|
|
|
comparison_result_type = defined_type(Name, [], kind_star) :-
|
|
BuiltinModule = mercury_public_builtin_module,
|
|
Name = qualified(BuiltinModule, "comparison_result").
|
|
|
|
type_info_type = defined_type(Name, [], kind_star) :-
|
|
BuiltinModule = mercury_private_builtin_module,
|
|
Name = qualified(BuiltinModule, "type_info").
|
|
|
|
type_ctor_info_type = defined_type(Name, [], kind_star) :-
|
|
BuiltinModule = mercury_private_builtin_module,
|
|
Name = qualified(BuiltinModule, "type_ctor_info").
|
|
|
|
io_state_type = defined_type(Name, [], kind_star) :-
|
|
Module = mercury_std_lib_module_name(unqualified("io")),
|
|
Name = qualified(Module, "state").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Given a constant and an arity, return a type_ctor.
|
|
% This really ought to take a name and an arity -
|
|
% use of integers/floats/strings as type names should
|
|
% be rejected by the parser in prog_io.m, not in module_qual.m.
|
|
|
|
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,
|
|
InstConsId = cons(qualified(PrivateBuiltin, Symbol), Arity).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
qualify_cons_id(Type, Args, ConsId0, ConsId, InstConsId) :-
|
|
(
|
|
ConsId0 = cons(Name0, OrigArity),
|
|
type_to_ctor_and_args(Type, TypeCtor, _),
|
|
TypeCtor = type_ctor(qualified(TypeModule, _), _)
|
|
->
|
|
UnqualName = unqualify_name(Name0),
|
|
Name = qualified(TypeModule, UnqualName),
|
|
ConsId = cons(Name, OrigArity),
|
|
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 = typeclass_info_cell_constructor,
|
|
InstConsId = cell_inst_cons_id(typeclass_info_cell, list.length(Args))
|
|
;
|
|
ConsId = ConsId0,
|
|
InstConsId = ConsId
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
type_constructors_are_no_tag_type(Ctors, Ctor, ArgType, MaybeArgName) :-
|
|
type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName0, ArgType),
|
|
|
|
% We don't handle unary tuples as no_tag types -- they are rare enough
|
|
% that it's not worth the implementation effort.
|
|
Ctor \= unqualified("{}"),
|
|
|
|
MaybeArgName = map_maybe(unqualify_name, MaybeArgName0).
|
|
|
|
type_constructors_are_type_info(Ctors) :-
|
|
type_is_single_ctor_single_arg(Ctors, Ctor, _, _),
|
|
ctor_is_type_info(Ctor).
|
|
|
|
:- pred type_is_single_ctor_single_arg(list(constructor)::in, sym_name::out,
|
|
maybe(ctor_field_name)::out, mer_type::out) is semidet.
|
|
|
|
type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName, ArgType) :-
|
|
Ctors = [SingleCtor],
|
|
SingleCtor = ctor(ExistQVars, _Constraints, Ctor,
|
|
[ctor_arg(MaybeArgName, ArgType, _)], _Ctxt),
|
|
ExistQVars = [].
|
|
|
|
:- pred ctor_is_type_info(sym_name::in) is semidet.
|
|
|
|
ctor_is_type_info(Ctor) :-
|
|
unqualify_private_builtin(Ctor, Name),
|
|
name_is_type_info(Name).
|
|
|
|
% 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").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Assign single functor of arity one a `no_tag' tag (unless we are
|
|
% reserving a tag, or if it is one of the dummy types).
|
|
%
|
|
type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReserveTagPragma,
|
|
Ctors, UserEqCmp, SingleFunc, SingleArg, MaybeArgName) :-
|
|
type_constructors_are_no_tag_type(Ctors, SingleFunc, SingleArg,
|
|
MaybeArgName),
|
|
(
|
|
ReserveTagPragma = no,
|
|
globals.lookup_bool_option(Globals, reserve_tag, no),
|
|
globals.lookup_bool_option(Globals, unboxed_no_tag_types, yes)
|
|
;
|
|
% Dummy types always need to be treated as no-tag types as the
|
|
% low-level C back end just passes around rubbish for them. When e.g.
|
|
% using the debugger, it is crucial that these values are treated
|
|
% as unboxed c_pointers, not as tagged pointers to c_pointers
|
|
% (otherwise the system winds up following a bogus pointer).
|
|
is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp)
|
|
).
|
|
|
|
:- pred is_dummy_argument_type_with_constructors(type_ctor::in,
|
|
list(constructor)::in, maybe(unify_compare)::in) is semidet.
|
|
|
|
is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp) :-
|
|
% Keep this in sync with is_dummy_argument_type below.
|
|
(
|
|
is_builtin_dummy_argument_type(TypeCtor)
|
|
;
|
|
constructor_list_represents_dummy_argument_type(Ctors, UserEqCmp)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Type unification.
|
|
%
|
|
|
|
type_unify(X, Y, HeadTypeParams, !Bindings) :-
|
|
( X = type_variable(VarX, _) ->
|
|
type_unify_var(VarX, Y, HeadTypeParams, !Bindings)
|
|
; Y = type_variable(VarY, _) ->
|
|
type_unify_var(VarY, X, HeadTypeParams, !Bindings)
|
|
; type_unify_nonvar(X, Y, HeadTypeParams, !Bindings) ->
|
|
true
|
|
;
|
|
% 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) :-
|
|
( TypeY = type_variable(VarY, KindY) ->
|
|
type_unify_var_var(VarX, VarY, KindY, HeadTypeParams, !Bindings)
|
|
; map.search(!.Bindings, VarX, BindingOfX) ->
|
|
% VarX has a binding. Y is not a variable.
|
|
type_unify(BindingOfX, TypeY, HeadTypeParams, !Bindings)
|
|
;
|
|
% VarX has no binding, so bind it to TypeY.
|
|
\+ type_occurs(TypeY, VarX, !.Bindings),
|
|
\+ list.member(VarX, HeadTypeParams),
|
|
svmap.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) :-
|
|
( list.member(Y, HeadTypeParams) ->
|
|
type_unify_head_type_param(X, Y, Kind, HeadTypeParams, !Bindings)
|
|
; list.member(X, HeadTypeParams) ->
|
|
type_unify_head_type_param(Y, X, Kind, HeadTypeParams, !Bindings)
|
|
; map.search(!.Bindings, X, BindingOfX) ->
|
|
( map.search(!.Bindings, Y, BindingOfY) ->
|
|
% Both X and Y already have bindings - just unify the
|
|
% types they are bound to.
|
|
type_unify(BindingOfX, BindingOfY, HeadTypeParams, !Bindings)
|
|
;
|
|
% Y hasn't been bound yet.
|
|
apply_rec_subst_to_type(!.Bindings, BindingOfX, SubstBindingOfX),
|
|
( SubstBindingOfX = type_variable(Y, _) ->
|
|
true
|
|
;
|
|
\+ type_occurs(SubstBindingOfX, Y, !.Bindings),
|
|
svmap.det_insert(Y, SubstBindingOfX, !Bindings)
|
|
)
|
|
)
|
|
;
|
|
% Neither X nor Y is a head type param. X had not been bound yet.
|
|
( map.search(!.Bindings, Y, BindingOfY) ->
|
|
apply_rec_subst_to_type(!.Bindings, BindingOfY, SubstBindingOfY),
|
|
( SubstBindingOfY = type_variable(X, _) ->
|
|
true
|
|
;
|
|
\+ type_occurs(SubstBindingOfY, X, !.Bindings),
|
|
svmap.det_insert(X, SubstBindingOfY, !Bindings)
|
|
)
|
|
;
|
|
% Both X and Y are unbound type variables - bind one to the other.
|
|
( X = Y ->
|
|
true
|
|
;
|
|
svmap.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) :-
|
|
( map.search(!.Bindings, Var, BindingOfVar) ->
|
|
BindingOfVar = type_variable(Var2, _),
|
|
type_unify_head_type_param(Var2, HeadVar, Kind, HeadTypeParams,
|
|
!Bindings)
|
|
;
|
|
( Var = HeadVar ->
|
|
true
|
|
;
|
|
\+ list.member(Var, HeadTypeParams),
|
|
svmap.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(defined_type(SymName, ArgsX, _),
|
|
defined_type(SymName, ArgsY, _), HeadTypeParams, !Bindings) :-
|
|
% 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(ArgsX, ArgsY, HeadTypeParams, !Bindings).
|
|
type_unify_nonvar(builtin_type(BuiltinType), builtin_type(BuiltinType), _,
|
|
!Bindings).
|
|
type_unify_nonvar(higher_order_type(ArgsX, no, Purity, EvalMethod),
|
|
higher_order_type(ArgsY, no, Purity, EvalMethod),
|
|
HeadTypeParams, !Bindings) :-
|
|
type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
|
|
type_unify_nonvar(higher_order_type(ArgsX, yes(RetX), Purity, EvalMethod),
|
|
higher_order_type(ArgsY, yes(RetY), Purity, EvalMethod),
|
|
HeadTypeParams, !Bindings) :-
|
|
type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings),
|
|
type_unify(RetX, RetY, HeadTypeParams, !Bindings).
|
|
type_unify_nonvar(tuple_type(ArgsX, _), tuple_type(ArgsY, _), HeadTypeParams,
|
|
!Bindings) :-
|
|
type_unify_list(ArgsX, ArgsY, 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(X, Y, HeadTypeParams, !Bindings) :-
|
|
( X = apply_n_type(VarX, ArgsX, _) ->
|
|
type_unify_apply(Y, VarX, ArgsX, HeadTypeParams, !Bindings)
|
|
; Y = apply_n_type(VarY, ArgsY, _) ->
|
|
type_unify_apply(X, VarY, ArgsY, HeadTypeParams, !Bindings)
|
|
; X = kinded_type(RawX, _) ->
|
|
( Y = kinded_type(RawY, _) ->
|
|
type_unify(RawX, RawY, HeadTypeParams, !Bindings)
|
|
;
|
|
type_unify(RawX, Y, HeadTypeParams, !Bindings)
|
|
)
|
|
; Y = kinded_type(RawY, _) ->
|
|
type_unify(X, RawY, HeadTypeParams, !Bindings)
|
|
;
|
|
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 then we fail.
|
|
% If we reach a variable before the arguments run out then we unify it
|
|
% with what remains of the apply_n expression. If we manage to unify
|
|
% all of the arguments then 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(defined_type(NameY, ArgsY0, KindY0), VarX, ArgsX,
|
|
HeadTypeParams, !Bindings) :-
|
|
type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
|
|
!Bindings),
|
|
type_unify_var(VarX, defined_type(NameY, ArgsY, KindY), HeadTypeParams,
|
|
!Bindings).
|
|
type_unify_apply(Type @ builtin_type(_), VarX, [], HeadTypeParams,
|
|
!Bindings) :-
|
|
type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
|
|
type_unify_apply(Type @ higher_order_type(_, _, _, _), VarX, [],
|
|
HeadTypeParams, !Bindings) :-
|
|
type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
|
|
type_unify_apply(tuple_type(ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
|
|
!Bindings) :-
|
|
type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
|
|
!Bindings),
|
|
type_unify_var(VarX, tuple_type(ArgsY, KindY), HeadTypeParams, !Bindings).
|
|
type_unify_apply(apply_n_type(VarY, ArgsY0, Kind0), VarX, ArgsX0,
|
|
HeadTypeParams, !Bindings) :-
|
|
list.length(ArgsX0, NArgsX0),
|
|
list.length(ArgsY0, NArgsY0),
|
|
compare(Result, NArgsX0, NArgsY0),
|
|
(
|
|
Result = (<),
|
|
type_unify_args(ArgsX0, ArgsY0, ArgsY, Kind0, Kind,
|
|
HeadTypeParams, !Bindings),
|
|
type_unify_var(VarX, apply_n_type(VarY, ArgsY, Kind),
|
|
HeadTypeParams, !Bindings)
|
|
;
|
|
Result = (=),
|
|
% We know here that the list of remaining args will be empty.
|
|
type_unify_args(ArgsX0, ArgsY0, _, Kind0, Kind, HeadTypeParams,
|
|
!Bindings),
|
|
type_unify_var_var(VarX, VarY, Kind, HeadTypeParams, !Bindings)
|
|
;
|
|
Result = (>),
|
|
type_unify_args(ArgsY0, ArgsX0, ArgsX, Kind0, Kind,
|
|
HeadTypeParams, !Bindings),
|
|
type_unify_var(VarY, apply_n_type(VarX, ArgsX, Kind),
|
|
HeadTypeParams, !Bindings)
|
|
).
|
|
type_unify_apply(kinded_type(RawY, _), VarX, ArgsX, HeadTypeParams,
|
|
!Bindings) :-
|
|
type_unify_apply(RawY, VarX, ArgsX, HeadTypeParams, !Bindings).
|
|
|
|
:- 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(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
|
|
!Bindings) :-
|
|
list.reverse(ArgsX, RevArgsX),
|
|
list.reverse(ArgsY0, RevArgsY0),
|
|
type_unify_rev_args(RevArgsX, RevArgsY0, RevArgsY, KindY0, KindY,
|
|
HeadTypeParams, !Bindings),
|
|
list.reverse(RevArgsY, ArgsY).
|
|
|
|
:- 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([], ArgsY, ArgsY, KindY, KindY, _, !Bindings).
|
|
type_unify_rev_args([ArgX | ArgsX], [ArgY0 | ArgsY0], ArgsY, KindY0, KindY,
|
|
HeadTypeParams, !Bindings) :-
|
|
type_unify(ArgX, ArgY0, HeadTypeParams, !Bindings),
|
|
KindY1 = kind_arrow(get_type_kind(ArgY0), KindY0),
|
|
type_unify_rev_args(ArgsX, ArgsY0, ArgsY, 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(type_variable(X, _), Y, Bindings) :-
|
|
( X = Y ->
|
|
true
|
|
;
|
|
map.search(Bindings, X, BindingOfX),
|
|
type_occurs(BindingOfX, Y, Bindings)
|
|
).
|
|
type_occurs(defined_type(_, Args, _), Y, Bindings) :-
|
|
type_occurs_list(Args, Y, Bindings).
|
|
type_occurs(higher_order_type(Args, MaybeRet, _, _), Y, Bindings) :-
|
|
(
|
|
type_occurs_list(Args, Y, Bindings)
|
|
;
|
|
MaybeRet = yes(Ret),
|
|
type_occurs(Ret, Y, Bindings)
|
|
).
|
|
type_occurs(tuple_type(Args, _), Y, Bindings) :-
|
|
type_occurs_list(Args, Y, Bindings).
|
|
type_occurs(apply_n_type(X, Args, _), Y, Bindings) :-
|
|
(
|
|
X = Y
|
|
;
|
|
type_occurs_list(Args, Y, Bindings)
|
|
;
|
|
map.search(Bindings, X, BindingOfX),
|
|
type_occurs(BindingOfX, Y, Bindings)
|
|
).
|
|
type_occurs(kinded_type(X, _), Y, Bindings) :-
|
|
type_occurs(X, Y, Bindings).
|
|
|
|
:- 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_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_list(TypesB, TypesBVars),
|
|
map.init(TypeSubst0),
|
|
type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
|
|
|
|
type_list_subsumes_det(TypesA, TypesB, TypeSubst) :-
|
|
( type_list_subsumes(TypesA, TypesB, TypeSubstPrime) ->
|
|
TypeSubst = TypeSubstPrime
|
|
;
|
|
unexpected(this_file,
|
|
"type_list_subsumes_det: type_list_subsumes failed")
|
|
).
|
|
|
|
arg_type_list_subsumes(TVarSet, ActualArgTypes, 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.]
|
|
|
|
type_list_subsumes(ParentArgTypes, ActualArgTypes, 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.
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
|
|
apply_partial_map_to_list(_PartialMap, [], []).
|
|
apply_partial_map_to_list(PartialMap, [X | Xs], [Y | Ys]) :-
|
|
( map.search(PartialMap, X, Y0) ->
|
|
Y = Y0
|
|
;
|
|
Y = X
|
|
),
|
|
apply_partial_map_to_list(PartialMap, Xs, Ys).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "prog_type.m".
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module prog_type.
|
|
%-----------------------------------------------------------------------------%
|