mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-14 13:23:53 +00:00
a23873984b
Estimated hours taken: 6
Branches: main
In the presence of large amounts of unresolved overloading, the compiler could
consume unbounded amounts of space and time. This diff fixes this problem.
I tried to avoid having this fix lead to a slowdown; in fact, the last three
changes to typecheck_info.m lead to a slight speedup.
compiler/options.m:
doc/user_guide.texi:
Add a new option, --typecheck-ambiguity-error-limit. This gives the
number of type assignments that cause the typechecker to stop
processing further goals. No such facility existed before.
Add a new option, --typecheck-ambiguity-warn-limit. This gives the
number of type assignments that cause the typechecker to emit a
warning. This generalizes the previous hard-coded value in typecheck.m.
Move the definitions of some existing options to the right set of
options.
compiler/typecheck_info.m:
Add the values of the two new options as fields to the typecheck_info,
since we will want to look them up often.
Separate out the error_specs concerned with overloading from the other
error specs, since we want to be able to have an error about excessive
overloading to overwrite a warning about excessive overloading
generated earlier.
Fix a performance bug: the pred_markers were being looked up in the
pred_info each time they were asked for, even though they were also
available directly in a field.
Move the least frequently accessed fields of the typecheck_info
into a separate substructure, to reduce amount of allocation required.
Delete the get and set predicates for the most frequently used fields,
to avoid the overhead of cross-module calls. These fields are now
accessed via field access functions.
compiler/typecheck.m:
Don't typecheck goals if the number of type assignments exceeds
the error limit.
Conform to the changes in typecheck_info.m.
compiler/typecheck_errors.m:
Add a function to generate the new error message.
Conform to the changes in typecheck_info.m.
tests/invalid/ambiguous_overloading_error.{m,err_exp}:
Add this new test case. It is a copy of the existing test case
warnings/ambiguous_overloading, but with more overloading. Old
compilers consume so much memory on it that they eventually run out
and crash, but the new compiler generates an error message
and finishes quickly.
tests/invalid/Mmakefile:
Enable the new test case.
tests/warnings/ambiguous_overloading.exp:
Update the output of this test case to account for the fact that
the context of the warning is now that of the goal *after* the point
at which the number of type assignments exceeds 50, not the goal
*before* this point.
1026 lines
41 KiB
Mathematica
1026 lines
41 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: typecheck_info.m.
|
|
% Main author: fjh.
|
|
%
|
|
% This module defines the typecheck_info and type_assign types, plus some
|
|
% useful predicates that work with those types.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds.typecheck_info.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module bool.
|
|
:- import_module io.
|
|
:- import_module list.
|
|
:- import_module maybe.
|
|
:- import_module map.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% The typecheck_info data structure.
|
|
%
|
|
|
|
:- type typecheck_sub_info
|
|
---> typecheck_sub_info(
|
|
% The id of the pred we're checking.
|
|
tc_sub_info_pred_id :: pred_id,
|
|
|
|
% Import status of the pred being checked.
|
|
tc_sub_info_pred_import_status :: import_status,
|
|
|
|
% Markers of the pred being checked.
|
|
tc_sub_info_pred_markers :: pred_markers,
|
|
|
|
% Is the pred we're checking a field access function? If so,
|
|
% there should only be a field access function application
|
|
% in the body, not predicate or function calls or constructor
|
|
% applications.
|
|
tc_sub_info_is_field_access_function :: bool,
|
|
|
|
% Variable names in the predicate being checked.
|
|
tc_sub_info_varset :: prog_varset,
|
|
|
|
% The list of errors found so far (if any), with one exception:
|
|
% any errors about overloading are in the overload_error field.
|
|
tc_sub_info_non_overload_errors :: list(error_spec),
|
|
|
|
% Have we already generated a warning or error message about
|
|
% highly ambiguous overloading? If yes, this has the message.
|
|
tc_sub_info_overload_error :: maybe(error_spec),
|
|
|
|
% The symbols used by the current predicate that have
|
|
% more than one accessible definition, mapped to the unsorted
|
|
% list of the locations that refer to them.
|
|
tc_sub_info_overloaded_symbols :: overloaded_symbol_map,
|
|
|
|
% The value of the option --typecheck-ambiguity-error-limit.
|
|
tc_sub_info_ambiguity_error_limit :: int
|
|
).
|
|
|
|
:- type typecheck_info
|
|
---> typecheck_info(
|
|
tc_info_sub_info :: typecheck_sub_info,
|
|
|
|
tc_info_module_info :: module_info,
|
|
|
|
% The call_id of the pred being called (if any).
|
|
tc_info_call_id :: call_id,
|
|
|
|
% The argument number within that pred call.
|
|
tc_info_arg_num :: int,
|
|
|
|
% The context of the goal we're checking.
|
|
tc_info_context :: prog_context,
|
|
|
|
% The original source of the unification we're checking.
|
|
tc_info_unify_context :: unify_context,
|
|
|
|
% This is the main piece of information that we are computing
|
|
% and which gets updated as we go along.
|
|
tc_info_type_assign_set :: type_assign_set,
|
|
|
|
% The value of the option --typecheck-ambiguity-warn-limit.
|
|
tc_info_ambiguity_warn_limit :: int
|
|
).
|
|
|
|
:- type overloaded_symbol_map == map(overloaded_symbol, list(prog_context)).
|
|
|
|
:- type overloaded_symbol
|
|
---> overloaded_pred(
|
|
simple_call_id,
|
|
list(pred_id)
|
|
)
|
|
; overloaded_func(
|
|
cons_id,
|
|
list(cons_type_info_source)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% typecheck_info initialisation and finalisation.
|
|
%
|
|
|
|
:- pred typecheck_info_init(module_info::in, pred_id::in, bool::in,
|
|
tvarset::in, prog_varset::in, vartypes::in, head_type_params::in,
|
|
hlds_constraints::in, import_status::in, pred_markers::in,
|
|
list(error_spec)::in, typecheck_info::out) is det.
|
|
|
|
% typecheck_info_get_final_info(Info, OldHeadTypeParams, OldExistQVars,
|
|
% OldExplicitVarTypes, NewTypeVarSet, New* ..., TypeRenaming,
|
|
% ExistTypeRenaming):
|
|
%
|
|
% Extracts the final inferred types from Info.
|
|
%
|
|
% OldHeadTypeParams should be the type variables from the head of the
|
|
% predicate.
|
|
% OldExistQVars should be the declared existentially quantified
|
|
% type variables (if any).
|
|
% OldExplicitVarTypes is the vartypes map containing the explicit
|
|
% type qualifications.
|
|
% New* is the newly inferred types, in NewTypeVarSet.
|
|
% TypeRenaming is a map to rename things from the old TypeVarSet
|
|
% to the NewTypeVarSet.
|
|
% ExistTypeRenaming is a map (which should be applied *before*
|
|
% applying TypeRenaming) to rename existential type variables
|
|
% in OldExistQVars.
|
|
%
|
|
:- pred typecheck_info_get_final_info(typecheck_info::in, list(tvar)::in,
|
|
existq_tvars::in, vartypes::in, tvarset::out, existq_tvars::out,
|
|
vartypes::out, prog_constraints::out,
|
|
constraint_proof_map::out, constraint_map::out,
|
|
tvar_renaming::out, tvar_renaming::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Basic access predicates for typecheck_info.
|
|
%
|
|
|
|
% :- func tc_info_module_info(typecheck_info) = module_info.
|
|
% :- func tc_info_arg_num(typecheck_info) = int.
|
|
% :- func tc_info_context(typecheck_info) = prog_context.
|
|
% :- func tc_info_unify_context(typecheck_info) = unify_context.
|
|
% :- func tc_info_type_assign_set(typecheck_info) = type_assign_set.
|
|
|
|
% :- func 'tc_info_arg_num :='(typecheck_info, int) = typecheck_info.
|
|
% :- func 'tc_info_context :='(typecheck_info, prog_context) = typecheck_info.
|
|
% :- func 'tc_info_unify_context :='(typecheck_info, unify_context)
|
|
% = typecheck_info.
|
|
% :- func 'tc_info_type_assign_set :='(typecheck_info, type_assign_set)
|
|
% = typecheck_info.
|
|
|
|
:- pred typecheck_info_get_predid(typecheck_info::in, pred_id::out) is det.
|
|
:- pred typecheck_info_get_pred_import_status(typecheck_info::in,
|
|
import_status::out) is det.
|
|
:- pred typecheck_info_get_pred_markers(typecheck_info::in, pred_markers::out)
|
|
is det.
|
|
:- pred typecheck_info_get_is_field_access_function(typecheck_info::in,
|
|
bool::out) is det.
|
|
:- pred typecheck_info_get_called_predid(typecheck_info::in, call_id::out)
|
|
is det.
|
|
|
|
:- pred typecheck_info_get_varset(typecheck_info::in, prog_varset::out) is det.
|
|
:- pred typecheck_info_get_overload_error(typecheck_info::in,
|
|
maybe(error_spec)::out) is det.
|
|
:- pred typecheck_info_get_overloaded_symbols(typecheck_info::in,
|
|
overloaded_symbol_map::out) is det.
|
|
:- pred typecheck_info_get_ambiguity_warn_limit(typecheck_info::in,
|
|
int::out) is det.
|
|
:- pred typecheck_info_get_ambiguity_error_limit(typecheck_info::in,
|
|
int::out) is det.
|
|
|
|
:- pred typecheck_info_set_called_predid(call_id::in,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
:- pred typecheck_info_set_overload_error(maybe(error_spec)::in,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
:- pred typecheck_info_set_overloaded_symbols(overloaded_symbol_map::in,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Utility predicates for typecheck_info.
|
|
%
|
|
|
|
:- pred typecheck_info_get_module_name(typecheck_info::in, module_name::out)
|
|
is det.
|
|
:- pred typecheck_info_get_preds(typecheck_info::in, predicate_table::out)
|
|
is det.
|
|
:- pred typecheck_info_get_types(typecheck_info::in, type_table::out) is det.
|
|
:- pred typecheck_info_get_ctors(typecheck_info::in, cons_table::out) is det.
|
|
|
|
:- pred typecheck_info_add_overloaded_symbol(overloaded_symbol::in,
|
|
prog_context::in, typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
:- pred typecheck_info_add_error(error_spec::in,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
:- pred typecheck_info_get_all_errors(typecheck_info::in,
|
|
list(error_spec)::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% The type_assign and type_assign_set data structures.
|
|
%
|
|
|
|
:- type type_assign_set == list(type_assign).
|
|
|
|
:- type type_assign
|
|
---> type_assign(
|
|
var_types :: vartypes,
|
|
type_varset :: tvarset,
|
|
head_type_params :: head_type_params,
|
|
% Universally quantified type variables.
|
|
type_bindings :: tsubst,
|
|
% Type bindings.
|
|
class_constraints :: hlds_constraints,
|
|
% The set of class constraints
|
|
% collected so far.
|
|
constraint_proofs :: constraint_proof_map,
|
|
% For each constraint found to be
|
|
% redundant, why is it so?
|
|
constraint_map :: constraint_map
|
|
% Maps constraint identifiers to the
|
|
% actual constraints.
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Access predicates for type_assign.
|
|
%
|
|
|
|
:- pred type_assign_get_var_types(type_assign::in,
|
|
vartypes::out) is det.
|
|
:- pred type_assign_get_typevarset(type_assign::in,
|
|
tvarset::out) is det.
|
|
:- pred type_assign_get_head_type_params(type_assign::in,
|
|
head_type_params::out) is det.
|
|
:- pred type_assign_get_type_bindings(type_assign::in,
|
|
tsubst::out) is det.
|
|
:- pred type_assign_get_typeclass_constraints(type_assign::in,
|
|
hlds_constraints::out) is det.
|
|
:- pred type_assign_get_constraint_proofs(type_assign::in,
|
|
constraint_proof_map::out) is det.
|
|
:- pred type_assign_get_constraint_map(type_assign::in,
|
|
constraint_map::out) is det.
|
|
|
|
:- pred type_assign_set_var_types(vartypes::in,
|
|
type_assign::in, type_assign::out) is det.
|
|
:- pred type_assign_set_typevarset(tvarset::in,
|
|
type_assign::in, type_assign::out) is det.
|
|
:- pred type_assign_set_head_type_params(head_type_params::in,
|
|
type_assign::in, type_assign::out) is det.
|
|
:- pred type_assign_set_type_bindings(tsubst::in,
|
|
type_assign::in, type_assign::out) is det.
|
|
:- pred type_assign_set_typeclass_constraints(hlds_constraints::in,
|
|
type_assign::in, type_assign::out) is det.
|
|
:- pred type_assign_set_constraint_proofs(constraint_proof_map::in,
|
|
type_assign::in, type_assign::out) is det.
|
|
:- pred type_assign_set_constraint_map(constraint_map::in,
|
|
type_assign::in, type_assign::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type args_type_assign_set == list(args_type_assign).
|
|
|
|
:- type args_type_assign
|
|
---> args(
|
|
caller_arg_assign :: type_assign,
|
|
% Type assignment.
|
|
callee_arg_types :: list(mer_type),
|
|
% Types of callee args, renamed apart.
|
|
callee_constraints :: hlds_constraints
|
|
% Constraints from callee, renamed apart.
|
|
).
|
|
|
|
:- func get_caller_arg_assign(args_type_assign) = type_assign.
|
|
:- func get_callee_arg_types(args_type_assign) = list(mer_type).
|
|
:- func get_callee_constraints(args_type_assign) = hlds_constraints.
|
|
|
|
% XXX document me
|
|
%
|
|
:- func convert_args_type_assign_set(args_type_assign_set) = type_assign_set.
|
|
|
|
% Same as convert_args_type_assign_set, but aborts when the args are
|
|
% non-empty.
|
|
%
|
|
:- func convert_args_type_assign_set_check_empty_args(args_type_assign_set) =
|
|
type_assign_set.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type cons_type_info
|
|
---> cons_type_info(
|
|
cti_varset :: tvarset,
|
|
% Type variables.
|
|
|
|
cti_exit_tvars :: existq_tvars,
|
|
% Existentially quantified type vars.
|
|
|
|
cti_result_type :: mer_type,
|
|
% Constructor type.
|
|
|
|
cti_arg_types :: list(mer_type),
|
|
% Types of the arguments.
|
|
|
|
cti_constraints :: hlds_constraints,
|
|
% Constraints introduced by this
|
|
% constructor (e.g. if it is actually
|
|
% a function, or if it is an existentially
|
|
% quantified data constructor).
|
|
|
|
cti_source :: cons_type_info_source
|
|
).
|
|
|
|
:- type cons_type_info_source
|
|
---> source_type(type_ctor)
|
|
; source_builtin_type(string)
|
|
; source_get_field_access(type_ctor)
|
|
; source_set_field_access(type_ctor)
|
|
; source_apply(string)
|
|
; source_pred(pred_id).
|
|
|
|
:- func project_cons_type_info_source(cons_type_info) = cons_type_info_source.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred write_type_assign_set(type_assign_set::in, prog_varset::in,
|
|
io::di, io::uo) is det.
|
|
|
|
:- func type_assign_set_to_pieces(type_assign_set, maybe(int), prog_varset)
|
|
= list(format_component).
|
|
|
|
:- pred write_args_type_assign_set(args_type_assign_set::in, prog_varset::in,
|
|
io::di, io::uo) is det.
|
|
|
|
:- func args_type_assign_set_to_pieces(args_type_assign_set, maybe(int),
|
|
prog_varset) = list(format_component).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Used for debugging typechecking.
|
|
%
|
|
:- pred type_checkpoint(string::in, typecheck_info::in, io::di, io::uo) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module libs.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module parse_tree.mercury_to_mercury.
|
|
:- import_module parse_tree.prog_out.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
|
|
:- import_module int.
|
|
:- import_module pair.
|
|
:- import_module string.
|
|
:- import_module svmap.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
typecheck_info_init(ModuleInfo, PredId, IsFieldAccessFunction,
|
|
TypeVarSet, VarSet, VarTypes, HeadTypeParams, Constraints,
|
|
Status, PredMarkers, NonOverloadErrors, Info) :-
|
|
CallPredId =
|
|
plain_call_id(simple_call_id(pf_predicate, unqualified(""), 0)),
|
|
term.context_init(Context),
|
|
map.init(TypeBindings),
|
|
map.init(Proofs),
|
|
map.init(ConstraintMap),
|
|
OverloadErrors = no,
|
|
map.init(OverloadedSymbols),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.lookup_int_option(Globals, typecheck_ambiguity_warn_limit,
|
|
WarnLimit),
|
|
globals.lookup_int_option(Globals, typecheck_ambiguity_error_limit,
|
|
ErrorLimit),
|
|
SubInfo = typecheck_sub_info(PredId, Status,
|
|
PredMarkers, IsFieldAccessFunction, VarSet,
|
|
NonOverloadErrors, OverloadErrors, OverloadedSymbols, ErrorLimit),
|
|
Info = typecheck_info(SubInfo, ModuleInfo, CallPredId, 0,
|
|
Context, unify_context(umc_explicit, []),
|
|
[type_assign(VarTypes, TypeVarSet, HeadTypeParams,
|
|
TypeBindings, Constraints, Proofs, ConstraintMap)],
|
|
WarnLimit
|
|
).
|
|
|
|
typecheck_info_get_final_info(Info, OldHeadTypeParams, OldExistQVars,
|
|
OldExplicitVarTypes, NewTypeVarSet, NewHeadTypeParams,
|
|
NewVarTypes, NewTypeConstraints, NewConstraintProofs,
|
|
NewConstraintMap, TSubst, ExistTypeRenaming) :-
|
|
TypeAssignSet = tc_info_type_assign_set(Info),
|
|
(
|
|
TypeAssignSet = [TypeAssign | _],
|
|
type_assign_get_head_type_params(TypeAssign, HeadTypeParams),
|
|
type_assign_get_typevarset(TypeAssign, OldTypeVarSet),
|
|
type_assign_get_var_types(TypeAssign, VarTypes0),
|
|
type_assign_get_type_bindings(TypeAssign, TypeBindings),
|
|
type_assign_get_typeclass_constraints(TypeAssign, HLDSTypeConstraints),
|
|
type_assign_get_constraint_proofs(TypeAssign, ConstraintProofs0),
|
|
type_assign_get_constraint_map(TypeAssign, ConstraintMap0),
|
|
|
|
map.keys(VarTypes0, Vars),
|
|
expand_types(Vars, TypeBindings, VarTypes0, VarTypes),
|
|
apply_rec_subst_to_constraint_proofs(TypeBindings,
|
|
ConstraintProofs0, ConstraintProofs),
|
|
apply_rec_subst_to_constraint_map(TypeBindings,
|
|
ConstraintMap0, ConstraintMap1),
|
|
|
|
% When inferring the typeclass constraints, the universal constraints
|
|
% here may be assumed (if this is the last pass) but will not have been
|
|
% eliminated during context reduction, hence they will not yet be
|
|
% in the constraint map. Since they may be required, put them in now.
|
|
%
|
|
% Additionally, existential constraints are assumed so don't need to be
|
|
% eliminated during context reduction, so they need to be put in the
|
|
% constraint map now.
|
|
|
|
HLDSTypeConstraints = constraints(HLDSUnivConstraints,
|
|
HLDSExistConstraints, _, _),
|
|
list.foldl(update_constraint_map, HLDSUnivConstraints,
|
|
ConstraintMap1, ConstraintMap2),
|
|
list.foldl(update_constraint_map, HLDSExistConstraints,
|
|
ConstraintMap2, ConstraintMap),
|
|
|
|
% Figure out how we should rename the existential types
|
|
% in the type declaration (if any).
|
|
|
|
get_existq_tvar_renaming(OldHeadTypeParams, OldExistQVars,
|
|
TypeBindings, ExistTypeRenaming),
|
|
|
|
% We used to just use the OldTypeVarSet that we got from the type
|
|
% assignment.
|
|
%
|
|
% However, that caused serious efficiency problems, because the
|
|
% typevarsets get bigger and bigger with each inference step. Instead,
|
|
% we now construct a new typevarset NewTypeVarSet which contains
|
|
% only the variables we want, and we rename the type variables so that
|
|
% they fit into this new typevarset.
|
|
|
|
% First, find the set (sorted list) of type variables that we need.
|
|
% This must include any type variables in the inferred types, the
|
|
% explicit type qualifications, and any existentially typed variables
|
|
% that will remain in the declaration.
|
|
%
|
|
% There may also be some type variables in the HeadTypeParams
|
|
% which do not occur in the type of any variable (e.g. this can happen
|
|
% in the case of code containing type errors). We'd better keep those,
|
|
% too, to avoid errors when we apply the TSubst to the HeadTypeParams.
|
|
% (XXX should we do the same for TypeConstraints and ConstraintProofs
|
|
% too?)
|
|
|
|
map.values(VarTypes, Types),
|
|
type_vars_list(Types, TypeVars0),
|
|
map.values(OldExplicitVarTypes, ExplicitTypes),
|
|
type_vars_list(ExplicitTypes, ExplicitTypeVars0),
|
|
map.keys(ExistTypeRenaming, ExistQVarsToBeRenamed),
|
|
list.delete_elems(OldExistQVars, ExistQVarsToBeRenamed,
|
|
ExistQVarsToRemain),
|
|
list.condense([ExistQVarsToRemain, HeadTypeParams,
|
|
TypeVars0, ExplicitTypeVars0], TypeVars1),
|
|
list.sort_and_remove_dups(TypeVars1, TypeVars),
|
|
|
|
% Next, create a new typevarset with the same number of variables.
|
|
varset.squash(OldTypeVarSet, TypeVars, NewTypeVarSet, TSubst),
|
|
|
|
% Finally, rename the types and type class constraints to use
|
|
% the new typevarset type variables.
|
|
apply_variable_renaming_to_type_list(TSubst, Types, NewTypes),
|
|
map.from_corresponding_lists(Vars, NewTypes, NewVarTypes),
|
|
map.apply_to_list(HeadTypeParams, TSubst, NewHeadTypeParams),
|
|
retrieve_prog_constraints(HLDSTypeConstraints, TypeConstraints),
|
|
apply_variable_renaming_to_prog_constraints(TSubst,
|
|
TypeConstraints, NewTypeConstraints),
|
|
apply_variable_renaming_to_constraint_proofs(TSubst,
|
|
ConstraintProofs, NewConstraintProofs),
|
|
apply_variable_renaming_to_constraint_map(TSubst,
|
|
ConstraintMap, NewConstraintMap)
|
|
;
|
|
TypeAssignSet = [],
|
|
unexpected(this_file, "internal error in typecheck_info_get_vartypes")
|
|
).
|
|
|
|
% Fully expand the types of the variables by applying the type bindings.
|
|
%
|
|
% The number of variables can be huge here (hundred of thousands for
|
|
% Doug Auclair's training_cars program). The code below prevents stack
|
|
% overflows in grades that do not permit tail recursion.
|
|
%
|
|
:- pred expand_types(list(prog_var)::in, tsubst::in,
|
|
vartypes::in, vartypes::out) is det.
|
|
|
|
expand_types(Vars, TypeSubst, !VarTypes) :-
|
|
expand_types_2(Vars, TypeSubst, 1000, LeftOverVars, !VarTypes),
|
|
(
|
|
LeftOverVars = []
|
|
;
|
|
LeftOverVars = [_ | _],
|
|
expand_types(LeftOverVars, TypeSubst, !VarTypes)
|
|
).
|
|
|
|
:- pred expand_types_2(list(prog_var)::in, tsubst::in, int::in,
|
|
list(prog_var)::out, vartypes::in, vartypes::out) is det.
|
|
|
|
expand_types_2([], _, _, [], !VarTypes).
|
|
expand_types_2([Var | Vars], TypeSubst, VarsToDo, LeftOverVars, !VarTypes) :-
|
|
( VarsToDo < 0 ->
|
|
LeftOverVars = [Var | Vars]
|
|
;
|
|
map.lookup(!.VarTypes, Var, Type0),
|
|
apply_rec_subst_to_type(TypeSubst, Type0, Type),
|
|
map.det_update(!.VarTypes, Var, Type, !:VarTypes),
|
|
expand_types_2(Vars, TypeSubst, VarsToDo - 1, LeftOverVars, !VarTypes)
|
|
).
|
|
|
|
% We rename any existentially quantified type variables which get mapped
|
|
% to other type variables, unless they are mapped to universally quantified
|
|
% type variables from the head of the predicate.
|
|
%
|
|
:- pred get_existq_tvar_renaming(list(tvar)::in, existq_tvars::in, tsubst::in,
|
|
tvar_renaming::out) is det.
|
|
|
|
get_existq_tvar_renaming(OldHeadTypeParams, ExistQVars, TypeBindings,
|
|
ExistTypeRenaming) :-
|
|
list.foldl(get_existq_tvar_renaming_2(OldHeadTypeParams, TypeBindings),
|
|
ExistQVars, map.init, ExistTypeRenaming).
|
|
|
|
:- pred get_existq_tvar_renaming_2(existq_tvars::in, tsubst::in,
|
|
tvar::in, tvar_renaming::in, tvar_renaming::out) is det.
|
|
|
|
get_existq_tvar_renaming_2(OldHeadTypeParams, TypeBindings, TVar, !Renaming) :-
|
|
(
|
|
tvar_maps_to_tvar(TypeBindings, TVar, NewTVar),
|
|
NewTVar \= TVar,
|
|
\+ list.member(NewTVar, OldHeadTypeParams)
|
|
->
|
|
svmap.det_insert(TVar, NewTVar, !Renaming)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred tvar_maps_to_tvar(tsubst::in, tvar::in, tvar::out) is semidet.
|
|
|
|
tvar_maps_to_tvar(TypeBindings, TVar0, TVar) :-
|
|
( map.search(TypeBindings, TVar0, Type) ->
|
|
Type = type_variable(TVar1, _),
|
|
tvar_maps_to_tvar(TypeBindings, TVar1, TVar)
|
|
;
|
|
TVar = TVar0
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred typecheck_info_get_non_overload_errors(typecheck_info::in,
|
|
list(error_spec)::out) is det.
|
|
:- pred typecheck_info_set_non_overload_errors(list(error_spec)::in,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
% These get and set functions are defined automatically.
|
|
|
|
% get_tc_info_module_info(Info) = Info ^ tc_info_module_info.
|
|
% get_tc_info_arg_num(Info) = Info ^ tc_info_arg_num.
|
|
% get_tc_info_context(Info) = Info ^ tc_info_context.
|
|
% get_tc_info_unify_context(Info) = Info ^ unify_context.
|
|
% get_tc_info_type_assign_set(Info) = Info ^ type_assign_set.
|
|
|
|
% set_tc_info_arg_num(ArgNum, Info, Info ^ tc_info_arg_num := ArgNum).
|
|
% set_tc_info_context(Context, Info, Info ^ tc_info_context := Context).
|
|
% set_tc_info_unify_context(UnifyContext, Info,
|
|
% Info ^ tc_info_unify_context := UnifyContext).
|
|
% set_tc_info_type_assign_set(TypeAssignSet, Info,
|
|
% Info ^ tc_info_type_assign_set := TypeAssignSet).
|
|
|
|
typecheck_info_get_predid(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_pred_id).
|
|
typecheck_info_get_pred_markers(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_pred_markers).
|
|
typecheck_info_get_pred_import_status(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_pred_import_status).
|
|
typecheck_info_get_is_field_access_function(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_is_field_access_function).
|
|
typecheck_info_get_called_predid(Info, Info ^ tc_info_call_id).
|
|
typecheck_info_get_varset(Info, Info ^ tc_info_sub_info ^ tc_sub_info_varset).
|
|
typecheck_info_get_non_overload_errors(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_non_overload_errors).
|
|
typecheck_info_get_overload_error(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_overload_error).
|
|
typecheck_info_get_overloaded_symbols(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_overloaded_symbols).
|
|
typecheck_info_get_ambiguity_error_limit(Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_ambiguity_error_limit).
|
|
typecheck_info_get_ambiguity_warn_limit(Info,
|
|
Info ^ tc_info_ambiguity_warn_limit).
|
|
|
|
typecheck_info_set_called_predid(PredCallId, Info,
|
|
Info ^ tc_info_call_id := PredCallId).
|
|
typecheck_info_set_non_overload_errors(Specs, Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_non_overload_errors := Specs).
|
|
typecheck_info_set_overload_error(OverloadSpec, Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_overload_error := OverloadSpec).
|
|
typecheck_info_set_overloaded_symbols(Symbols, Info,
|
|
Info ^ tc_info_sub_info ^ tc_sub_info_overloaded_symbols := Symbols).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
typecheck_info_get_module_name(Info, Name) :-
|
|
module_info_get_name(Info ^ tc_info_module_info, Name).
|
|
typecheck_info_get_preds(Info, Preds) :-
|
|
module_info_get_predicate_table(Info ^ tc_info_module_info, Preds).
|
|
typecheck_info_get_types(Info, Types) :-
|
|
module_info_get_type_table(Info ^ tc_info_module_info, Types).
|
|
typecheck_info_get_ctors(Info, Ctors) :-
|
|
module_info_get_cons_table(Info ^ tc_info_module_info, Ctors).
|
|
|
|
typecheck_info_add_overloaded_symbol(Symbol, Context, !Info) :-
|
|
typecheck_info_get_overloaded_symbols(!.Info, SymbolMap0),
|
|
( map.search(SymbolMap0, Symbol, OldContexts) ->
|
|
Contexts = [Context | OldContexts],
|
|
map.det_update(SymbolMap0, Symbol, Contexts, SymbolMap)
|
|
;
|
|
Contexts = [Context],
|
|
map.det_insert(SymbolMap0, Symbol, Contexts, SymbolMap)
|
|
),
|
|
typecheck_info_set_overloaded_symbols(SymbolMap, !Info).
|
|
|
|
typecheck_info_add_error(Error, !Info) :-
|
|
typecheck_info_get_non_overload_errors(!.Info, Errors0),
|
|
Errors = [Error | Errors0],
|
|
typecheck_info_set_non_overload_errors(Errors, !Info).
|
|
|
|
typecheck_info_get_all_errors(Info, Errors) :-
|
|
typecheck_info_get_non_overload_errors(Info, Errors0),
|
|
typecheck_info_get_overload_error(Info, MaybeOverloadError),
|
|
(
|
|
MaybeOverloadError = no,
|
|
Errors = Errors0
|
|
;
|
|
MaybeOverloadError = yes(OverloadError),
|
|
Errors = [OverloadError | Errors0]
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
type_assign_get_var_types(TA, TA ^ var_types).
|
|
type_assign_get_typevarset(TA, TA ^ type_varset).
|
|
type_assign_get_head_type_params(TA, TA ^ head_type_params).
|
|
type_assign_get_type_bindings(TA, TA ^ type_bindings).
|
|
type_assign_get_typeclass_constraints(TA, TA ^ class_constraints).
|
|
type_assign_get_constraint_proofs(TA, TA ^ constraint_proofs).
|
|
type_assign_get_constraint_map(TA, TA ^ constraint_map).
|
|
|
|
type_assign_set_var_types(X, TA, TA ^ var_types := X).
|
|
type_assign_set_typevarset(X, TA, TA ^ type_varset := X).
|
|
type_assign_set_head_type_params(X, TA, TA ^ head_type_params := X).
|
|
type_assign_set_type_bindings(X, TA, TA ^ type_bindings := X).
|
|
type_assign_set_typeclass_constraints(X, TA, TA ^ class_constraints := X).
|
|
type_assign_set_constraint_proofs(X, TA, TA ^ constraint_proofs := X).
|
|
type_assign_set_constraint_map(X, TA, TA ^ constraint_map := X).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
convert_args_type_assign_set([]) = [].
|
|
convert_args_type_assign_set([ArgsTypeAssign | ArgsTypeAssigns]) =
|
|
[convert_args_type_assign(ArgsTypeAssign) |
|
|
convert_args_type_assign_set(ArgsTypeAssigns)].
|
|
|
|
convert_args_type_assign_set_check_empty_args([]) = [].
|
|
convert_args_type_assign_set_check_empty_args([ArgTypeAssign | ArgTypeAssigns])
|
|
= Result :-
|
|
ArgTypeAssign = args(_, Args, _),
|
|
(
|
|
Args = [],
|
|
Result =
|
|
[convert_args_type_assign(ArgTypeAssign) |
|
|
convert_args_type_assign_set_check_empty_args(ArgTypeAssigns)]
|
|
;
|
|
Args = [_ | _],
|
|
% This should never happen, since the arguments should all have been
|
|
% processed at this point.
|
|
unexpected(this_file, "convert_nonempty_args_type_assign_set")
|
|
).
|
|
|
|
:- func convert_args_type_assign(args_type_assign) = type_assign.
|
|
|
|
convert_args_type_assign(args(TypeAssign0, _, Constraints0)) = TypeAssign :-
|
|
type_assign_get_typeclass_constraints(TypeAssign0, OldConstraints),
|
|
type_assign_get_type_bindings(TypeAssign0, Bindings),
|
|
apply_rec_subst_to_constraints(Bindings, Constraints0, Constraints),
|
|
merge_hlds_constraints(Constraints, OldConstraints, NewConstraints),
|
|
type_assign_set_typeclass_constraints(NewConstraints,
|
|
TypeAssign0, TypeAssign).
|
|
|
|
get_caller_arg_assign(ArgsTypeAssign) = ArgsTypeAssign ^ caller_arg_assign.
|
|
get_callee_arg_types(ArgsTypeAssign) = ArgsTypeAssign ^ callee_arg_types.
|
|
get_callee_constraints(ArgsTypeAssign) = ArgsTypeAssign ^ callee_constraints.
|
|
|
|
project_cons_type_info_source(CTI) = CTI ^ cti_source.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func varnums = bool.
|
|
|
|
varnums = yes.
|
|
|
|
:- func inc_maybe_seq(maybe(int)) = maybe(int).
|
|
|
|
inc_maybe_seq(no) = no.
|
|
inc_maybe_seq(yes(N)) = yes(N + 1).
|
|
|
|
write_type_assign_set([], _, !IO).
|
|
write_type_assign_set([TypeAssign | TypeAssigns], VarSet, !IO) :-
|
|
io.write_string("\t", !IO),
|
|
write_type_assign(TypeAssign, VarSet, !IO),
|
|
io.write_string("\n", !IO),
|
|
write_type_assign_set(TypeAssigns, VarSet, !IO).
|
|
|
|
type_assign_set_to_pieces([], _, _) = [].
|
|
type_assign_set_to_pieces([TypeAssign | TypeAssigns], MaybeSeq, VarSet) =
|
|
type_assign_to_pieces(TypeAssign, MaybeSeq, VarSet) ++
|
|
type_assign_set_to_pieces(TypeAssigns, inc_maybe_seq(MaybeSeq), VarSet).
|
|
|
|
write_args_type_assign_set([], _, !IO).
|
|
write_args_type_assign_set([ArgTypeAssign | ArgTypeAssigns], VarSet, !IO) :-
|
|
% XXX Why does this simply pick the TypeAssign part of the ArgTypeAssign,
|
|
% instead of invoking convert_args_type_assign?
|
|
ArgTypeAssign = args(TypeAssign, _ArgTypes, _Cnstrs),
|
|
io.write_string("\t", !IO),
|
|
write_type_assign(TypeAssign, VarSet, !IO),
|
|
io.write_string("\n", !IO),
|
|
write_args_type_assign_set(ArgTypeAssigns, VarSet, !IO).
|
|
|
|
args_type_assign_set_to_pieces([], _, _) = [].
|
|
args_type_assign_set_to_pieces([ArgTypeAssign | ArgTypeAssigns], MaybeSeq,
|
|
VarSet) = Pieces :-
|
|
% XXX Why does this simply pick the TypeAssign part of the ArgTypeAssign,
|
|
% instead of invoking convert_args_type_assign?
|
|
ArgTypeAssign = args(TypeAssign, _ArgTypes, _Cnstrs),
|
|
Pieces = type_assign_to_pieces(TypeAssign, MaybeSeq, VarSet) ++
|
|
args_type_assign_set_to_pieces(ArgTypeAssigns, inc_maybe_seq(MaybeSeq),
|
|
VarSet).
|
|
|
|
:- pred write_type_assign(type_assign::in, prog_varset::in, io::di, io::uo)
|
|
is det.
|
|
|
|
write_type_assign(TypeAssign, VarSet, !IO) :-
|
|
type_assign_get_head_type_params(TypeAssign, HeadTypeParams),
|
|
type_assign_get_var_types(TypeAssign, VarTypes),
|
|
type_assign_get_typeclass_constraints(TypeAssign, Constraints),
|
|
type_assign_get_type_bindings(TypeAssign, TypeBindings),
|
|
type_assign_get_typevarset(TypeAssign, TypeVarSet),
|
|
map.keys(VarTypes, Vars),
|
|
(
|
|
HeadTypeParams = []
|
|
;
|
|
HeadTypeParams = [_ | _],
|
|
io.write_string("some [", !IO),
|
|
mercury_output_vars(TypeVarSet, varnums, HeadTypeParams, !IO),
|
|
io.write_string("]\n\t", !IO)
|
|
),
|
|
write_type_assign_types(Vars, VarSet, VarTypes, TypeBindings, TypeVarSet,
|
|
no, !IO),
|
|
write_type_assign_hlds_constraints(Constraints, TypeBindings, TypeVarSet,
|
|
!IO),
|
|
io.write_string("\n", !IO).
|
|
|
|
:- func type_assign_to_pieces(type_assign, maybe(int), prog_varset)
|
|
= list(format_component).
|
|
|
|
type_assign_to_pieces(TypeAssign, MaybeSeq, VarSet) = Pieces :-
|
|
(
|
|
MaybeSeq = yes(N),
|
|
SeqPieces0 = [words("Type assignment"), int_fixed(N), suffix(":"), nl],
|
|
( N > 1 ->
|
|
SeqPieces = [blank_line | SeqPieces0]
|
|
;
|
|
SeqPieces = SeqPieces0
|
|
)
|
|
;
|
|
MaybeSeq = no,
|
|
SeqPieces = []
|
|
),
|
|
type_assign_get_head_type_params(TypeAssign, HeadTypeParams),
|
|
type_assign_get_var_types(TypeAssign, VarTypes),
|
|
type_assign_get_typeclass_constraints(TypeAssign, Constraints),
|
|
type_assign_get_type_bindings(TypeAssign, TypeBindings),
|
|
type_assign_get_typevarset(TypeAssign, TypeVarSet),
|
|
map.keys(VarTypes, Vars),
|
|
(
|
|
HeadTypeParams = [],
|
|
HeadPieces = []
|
|
;
|
|
HeadTypeParams = [_ | _],
|
|
VarsStr = mercury_vars_to_string(TypeVarSet, varnums, HeadTypeParams),
|
|
HeadPieces = [words("some [" ++ VarsStr ++ "]"), nl]
|
|
),
|
|
TypePieces = type_assign_types_to_pieces(Vars, VarSet, VarTypes,
|
|
TypeBindings, TypeVarSet, no),
|
|
ConstraintPieces = type_assign_hlds_constraints_to_pieces(Constraints,
|
|
TypeBindings, TypeVarSet),
|
|
Pieces = SeqPieces ++ HeadPieces ++ TypePieces ++ ConstraintPieces ++ [nl].
|
|
|
|
:- pred write_type_assign_types(list(prog_var)::in, prog_varset::in,
|
|
vartypes::in, tsubst::in, tvarset::in, bool::in, io::di, io::uo) is det.
|
|
|
|
write_type_assign_types([], _, _, _, _, FoundOne, !IO) :-
|
|
(
|
|
FoundOne = no,
|
|
io.write_string("(No variables were assigned a type)", !IO)
|
|
;
|
|
FoundOne = yes
|
|
).
|
|
write_type_assign_types([Var | Vars], VarSet, VarTypes, TypeBindings,
|
|
TypeVarSet, FoundOne, !IO) :-
|
|
( map.search(VarTypes, Var, Type) ->
|
|
(
|
|
FoundOne = yes,
|
|
io.write_string("\n\t", !IO)
|
|
;
|
|
FoundOne = no
|
|
),
|
|
mercury_output_var(VarSet, varnums, Var, !IO),
|
|
io.write_string(": ", !IO),
|
|
write_type_with_bindings(Type, TypeVarSet, TypeBindings, !IO),
|
|
write_type_assign_types(Vars, VarSet, VarTypes, TypeBindings,
|
|
TypeVarSet, yes, !IO)
|
|
;
|
|
write_type_assign_types(Vars, VarSet, VarTypes, TypeBindings,
|
|
TypeVarSet, FoundOne, !IO)
|
|
).
|
|
|
|
:- func type_assign_types_to_pieces(list(prog_var), prog_varset,
|
|
vartypes, tsubst, tvarset, bool) = list(format_component).
|
|
|
|
type_assign_types_to_pieces([], _, _, _, _, FoundOne) = Pieces :-
|
|
(
|
|
FoundOne = no,
|
|
Pieces = [words("(No variables were assigned a type)")]
|
|
;
|
|
FoundOne = yes,
|
|
Pieces = []
|
|
).
|
|
type_assign_types_to_pieces([Var | Vars], VarSet, VarTypes, TypeBindings,
|
|
TypeVarSet, FoundOne) = Pieces :-
|
|
( map.search(VarTypes, Var, Type) ->
|
|
(
|
|
FoundOne = yes,
|
|
PrefixPieces = [nl]
|
|
;
|
|
FoundOne = no,
|
|
PrefixPieces = []
|
|
),
|
|
VarStr = mercury_var_to_string(VarSet, varnums, Var),
|
|
TypeStr = type_with_bindings_to_string(Type, TypeVarSet, TypeBindings),
|
|
AssignPieces = [fixed(VarStr), suffix(":"), words(TypeStr)],
|
|
TailPieces = type_assign_types_to_pieces(Vars, VarSet, VarTypes,
|
|
TypeBindings, TypeVarSet, yes),
|
|
Pieces = PrefixPieces ++ AssignPieces ++ TailPieces
|
|
;
|
|
Pieces = type_assign_types_to_pieces(Vars, VarSet, VarTypes,
|
|
TypeBindings, TypeVarSet, FoundOne)
|
|
).
|
|
|
|
:- pred write_type_assign_hlds_constraints(hlds_constraints::in,
|
|
tsubst::in, tvarset::in, io::di, io::uo) is det.
|
|
|
|
write_type_assign_hlds_constraints(Constraints, TypeBindings, TypeVarSet,
|
|
!IO) :-
|
|
Constraints = constraints(ConstraintsToProve, AssumedConstraints, _, _),
|
|
write_type_assign_constraints("&", AssumedConstraints,
|
|
TypeBindings, TypeVarSet, no, !IO),
|
|
write_type_assign_constraints("<=", ConstraintsToProve,
|
|
TypeBindings, TypeVarSet, no, !IO).
|
|
|
|
:- func type_assign_hlds_constraints_to_pieces(hlds_constraints,
|
|
tsubst, tvarset) = list(format_component).
|
|
|
|
type_assign_hlds_constraints_to_pieces(Constraints, TypeBindings, TypeVarSet)
|
|
= Pieces1 ++ Pieces2 :-
|
|
Constraints = constraints(ConstraintsToProve, AssumedConstraints, _, _),
|
|
PiecesList1 = type_assign_constraints_to_pieces_list("&",
|
|
AssumedConstraints, TypeBindings, TypeVarSet, no),
|
|
PiecesList2 = type_assign_constraints_to_pieces_list("<=",
|
|
ConstraintsToProve, TypeBindings, TypeVarSet, no),
|
|
Pieces1 = component_list_to_line_pieces(PiecesList1, []),
|
|
Pieces2 = component_list_to_line_pieces(PiecesList2, []).
|
|
|
|
:- pred write_type_assign_constraints(string::in, list(hlds_constraint)::in,
|
|
tsubst::in, tvarset::in, bool::in, io::di, io::uo) is det.
|
|
|
|
write_type_assign_constraints(_, [], _, _, _, !IO).
|
|
write_type_assign_constraints(Operator, [Constraint | Constraints],
|
|
TypeBindings, TypeVarSet, FoundOne, !IO) :-
|
|
(
|
|
FoundOne = no,
|
|
io.write_strings(["\n\t", Operator, " "], !IO)
|
|
;
|
|
FoundOne = yes,
|
|
io.write_string(",\n\t ", !IO)
|
|
),
|
|
apply_rec_subst_to_constraint(TypeBindings, Constraint, BoundConstraint),
|
|
retrieve_prog_constraint(BoundConstraint, ProgConstraint),
|
|
mercury_output_constraint(TypeVarSet, varnums, ProgConstraint, !IO),
|
|
write_type_assign_constraints(Operator, Constraints, TypeBindings,
|
|
TypeVarSet, yes, !IO).
|
|
|
|
:- func type_assign_constraints_to_pieces_list(string, list(hlds_constraint),
|
|
tsubst, tvarset, bool) = list(list(format_component)).
|
|
|
|
type_assign_constraints_to_pieces_list(_, [], _, _, _) = [].
|
|
type_assign_constraints_to_pieces_list(Operator, [Constraint | Constraints],
|
|
TypeBindings, TypeVarSet, FoundOne) = [ThisPieces] ++ TailPieceLists :-
|
|
(
|
|
FoundOne = no,
|
|
Prefix = Operator ++ " "
|
|
;
|
|
FoundOne = yes,
|
|
Prefix = " "
|
|
),
|
|
apply_rec_subst_to_constraint(TypeBindings, Constraint, BoundConstraint),
|
|
retrieve_prog_constraint(BoundConstraint, ProgConstraint),
|
|
ThisPieces = [fixed(Prefix ++
|
|
mercury_constraint_to_string(TypeVarSet, ProgConstraint))],
|
|
TailPieceLists = type_assign_constraints_to_pieces_list(Operator,
|
|
Constraints, TypeBindings, TypeVarSet, yes).
|
|
|
|
% write_type_with_bindings writes out a type after applying the
|
|
% type bindings.
|
|
%
|
|
:- pred write_type_with_bindings(mer_type::in, tvarset::in, tsubst::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_type_with_bindings(Type0, TypeVarSet, TypeBindings, !IO) :-
|
|
apply_rec_subst_to_type(TypeBindings, Type0, Type1),
|
|
strip_builtin_qualifiers_from_type(Type1, Type),
|
|
mercury_output_type(TypeVarSet, no, Type, !IO).
|
|
|
|
:- func type_with_bindings_to_string(mer_type, tvarset, tsubst) = string.
|
|
|
|
type_with_bindings_to_string(Type0, TypeVarSet, TypeBindings) = Str :-
|
|
apply_rec_subst_to_type(TypeBindings, Type0, Type1),
|
|
strip_builtin_qualifiers_from_type(Type1, Type),
|
|
Str = mercury_type_to_string(TypeVarSet, no, Type).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
type_checkpoint(Msg, Info, !IO) :-
|
|
ModuleInfo = tc_info_module_info(Info),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals, debug_types, DoCheckPoint),
|
|
(
|
|
DoCheckPoint = yes,
|
|
do_type_checkpoint(Msg, Info, !IO)
|
|
;
|
|
DoCheckPoint = no
|
|
).
|
|
|
|
:- pred do_type_checkpoint(string::in, typecheck_info::in, io::di, io::uo)
|
|
is det.
|
|
|
|
do_type_checkpoint(Msg, Info, !IO) :-
|
|
io.write_string("At ", !IO),
|
|
io.write_string(Msg, !IO),
|
|
io.write_string(": ", !IO),
|
|
globals.io_lookup_bool_option(detailed_statistics, Statistics, !IO),
|
|
maybe_report_stats(Statistics, !IO),
|
|
io.write_string("\n", !IO),
|
|
TypeAssignSet = tc_info_type_assign_set(Info),
|
|
(
|
|
Statistics = yes,
|
|
TypeAssignSet = [TypeAssign | _]
|
|
->
|
|
type_assign_get_var_types(TypeAssign, VarTypes),
|
|
checkpoint_tree_stats("\t`var -> type' map", VarTypes, !IO),
|
|
type_assign_get_type_bindings(TypeAssign, TypeBindings),
|
|
checkpoint_tree_stats("\t`type var -> type' map", TypeBindings, !IO)
|
|
;
|
|
true
|
|
),
|
|
typecheck_info_get_varset(Info, VarSet),
|
|
write_type_assign_set(TypeAssignSet, VarSet, !IO).
|
|
|
|
:- pred checkpoint_tree_stats(string::in, map(_K, _V)::in, io::di, io::uo)
|
|
is det.
|
|
|
|
checkpoint_tree_stats(Description, Tree, !IO) :-
|
|
map.count(Tree, Count),
|
|
io.write_string(Description, !IO),
|
|
io.write_string(": count = ", !IO),
|
|
io.write_int(Count, !IO),
|
|
io.write_string("\n", !IO).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "typecheck_info.m".
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module check_hlds.typecheck_info.
|
|
%-----------------------------------------------------------------------------%
|