mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-18 02:43:40 +00:00
7633991604
compiler/typecheck_info.m:
Take a pred_info argument, whose meaning is obvious, instead of a boolean
argument, whose meaning is not.
compiler/typecheck.m:
Pass the pred_info to typecheck_info.m instead of the boolean, thus
replacing two tests with one.
Delete excess assignment unifications.
Add a comment.
3571 lines
153 KiB
Mathematica
3571 lines
153 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2012 The University of Melbourne.
|
|
% Copyright (C) 2014-2018 The Mercury team.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% File: typecheck.m.
|
|
% Main author: fjh.
|
|
%
|
|
% This file contains the Mercury type-checker.
|
|
%
|
|
% The predicates in this module are named as follows:
|
|
%
|
|
% - Predicates that type check a particular language construct
|
|
% (goal, clause, etc.) are called typecheck_*. These will eventually
|
|
% have to iterate over every type assignment in the type assignment set.
|
|
%
|
|
% - Predicates that unify two things with respect to a single type assignment,
|
|
% as opposed to a type assignment set are called type_assign_*.
|
|
%
|
|
% There are four sorts of types:
|
|
%
|
|
% 1 discriminated unions:
|
|
% :- type tree(T) ---> nil ; t(tree(T), T, tree(T)).
|
|
%
|
|
% 2 equivalence types (treated identically, ie, same name. Any number of types
|
|
% can be equivalent; the *canonical* one is the one which is not defined
|
|
% using ==):
|
|
% :- type real == float.
|
|
%
|
|
% Currently references to equivalence types are expanded in a separate pass
|
|
% by mercury_compile_front_end.m. It would be better to avoid expanding them
|
|
% (and instead modify the type unification algorithm to handle equivalent
|
|
% types) because this would give better error messages. However, this is
|
|
% not a high priority.
|
|
%
|
|
% 3 higher-order predicate and function types
|
|
% pred, pred(T), pred(T1, T2), pred(T1, T2, T3), ...
|
|
% func(T1) = T2, func(T1, T2) = T3, ...
|
|
%
|
|
% 4 builtin types
|
|
% character, int, float, string; These types have special syntax
|
|
% for constants. There may be other types (list(T), unit, univ, etc.)
|
|
% provided by the system, but they can just be part of the standard library.
|
|
%
|
|
% Each exported predicate must have a `:- pred' declaration specifying the
|
|
% types of the arguments for that predicate. For predicates that are
|
|
% local to a module, we infer the types.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Known Bugs:
|
|
%
|
|
% XXX Type inference doesn't handle ambiguity as well as it could do.
|
|
% We should do a topological sort, and then typecheck it all bottom-up.
|
|
% If we infer an ambiguous type for a pred, we should not reject it
|
|
% immediately; instead we should give it an overloaded type, and keep going.
|
|
% When we have finished type inference, we should then delete unused
|
|
% overloadings, and only then should we report ambiguity errors,
|
|
% if any overloading still remains.
|
|
%
|
|
% Wish list:
|
|
%
|
|
% - We should handle equivalence types here.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds.typecheck.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_util.
|
|
|
|
:- import_module bool.
|
|
:- import_module list.
|
|
|
|
% typecheck_module(!ModuleInfo, Specs, FoundSyntaxError,
|
|
% ExceededIterationLimit):
|
|
%
|
|
% Type checks ModuleInfo and annotates it with variable type information.
|
|
% Specs is set to the list of errors and warnings found, plus messages
|
|
% about the predicates and functions whose types have been inferred.
|
|
% We set FoundSyntaxError to yes if some of the clauses in the typechecked
|
|
% predicates contained syntax errors.
|
|
% We set ExceededIterationLimit to `yes' iff the type inference iteration
|
|
% limit was reached.
|
|
%
|
|
:- pred typecheck_module(module_info::in, module_info::out,
|
|
list(error_spec)::out, bool::out, bool::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.type_assign.
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module check_hlds.typecheck_errors.
|
|
:- import_module check_hlds.typecheck_info.
|
|
:- import_module check_hlds.typeclasses.
|
|
:- import_module hlds.goal_util.
|
|
:- import_module hlds.hlds_class.
|
|
:- import_module hlds.hlds_clauses.
|
|
:- import_module hlds.hlds_cons.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_error_util.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- import_module hlds.instmap.
|
|
:- import_module hlds.make_goal.
|
|
:- import_module hlds.passes_aux.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module hlds.special_pred.
|
|
:- import_module hlds.status.
|
|
:- import_module hlds.vartypes.
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.builtin_modules.
|
|
:- import_module mdbcomp.goal_path.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.builtin_lib_types.
|
|
:- import_module parse_tree.file_names. % undesirable dependency
|
|
:- import_module parse_tree.parse_tree_out_pred_decl.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_data_event.
|
|
:- import_module parse_tree.prog_data_foreign.
|
|
:- import_module parse_tree.prog_event.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.prog_util.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module set_tree234.
|
|
:- import_module string.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
typecheck_module(!ModuleInfo, Specs, FoundSyntaxError,
|
|
ExceededIterationLimit) :-
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.lookup_int_option(Globals, type_inference_iteration_limit,
|
|
MaxIterations),
|
|
|
|
module_info_get_valid_pred_id_set(!.ModuleInfo, OrigValidPredIdSet),
|
|
OrigValidPredIds = set_tree234.to_sorted_list(OrigValidPredIdSet),
|
|
|
|
typecheck_to_fixpoint(1, MaxIterations, !ModuleInfo,
|
|
OrigValidPredIds, OrigValidPredIdSet, FinalValidPredIdSet,
|
|
CheckSpecs, FoundSyntaxError, ExceededIterationLimit),
|
|
|
|
construct_type_inference_messages(!.ModuleInfo, FinalValidPredIdSet,
|
|
OrigValidPredIds, [], InferSpecs),
|
|
Specs = InferSpecs ++ CheckSpecs.
|
|
|
|
% Repeatedly typecheck the code for a group of predicates
|
|
% until a fixpoint is reached, or until some errors are detected.
|
|
%
|
|
:- pred typecheck_to_fixpoint(int::in, int::in,
|
|
module_info::in, module_info::out,
|
|
list(pred_id)::in, set_tree234(pred_id)::in, set_tree234(pred_id)::out,
|
|
list(error_spec)::out, bool::out, bool::out) is det.
|
|
|
|
typecheck_to_fixpoint(Iteration, MaxIterations, !ModuleInfo,
|
|
OrigValidPredIds, OrigValidPredIdSet, FinalValidPredIdSet,
|
|
Specs, FoundSyntaxError, ExceededIterationLimit) :-
|
|
module_info_get_preds(!.ModuleInfo, PredMap0),
|
|
map.to_assoc_list(PredMap0, PredIdsInfos0),
|
|
typecheck_module_one_iteration(!.ModuleInfo, OrigValidPredIdSet,
|
|
PredIdsInfos0, PredIdsInfos, [], NewlyInvalidPredIds,
|
|
[], CurSpecs, no, CurFoundSyntaxError,
|
|
next_iteration_is_not_needed, NextIteration),
|
|
map.from_sorted_assoc_list(PredIdsInfos, PredMap),
|
|
module_info_set_preds(PredMap, !ModuleInfo),
|
|
|
|
module_info_make_pred_ids_invalid(NewlyInvalidPredIds, !ModuleInfo),
|
|
module_info_get_valid_pred_id_set(!.ModuleInfo, NewValidPredIdSet),
|
|
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
( if
|
|
( NextIteration = next_iteration_is_not_needed
|
|
; contains_errors(Globals, CurSpecs) = yes
|
|
)
|
|
then
|
|
FinalValidPredIdSet = NewValidPredIdSet,
|
|
Specs = CurSpecs,
|
|
FoundSyntaxError = CurFoundSyntaxError,
|
|
ExceededIterationLimit = no
|
|
else
|
|
globals.lookup_bool_option(Globals, debug_types, DebugTypes),
|
|
(
|
|
DebugTypes = yes,
|
|
construct_type_inference_messages(!.ModuleInfo, NewValidPredIdSet,
|
|
OrigValidPredIds, [], ProgressSpecs),
|
|
trace [io(!IO)] (
|
|
write_error_specs_ignore(Globals, ProgressSpecs, !IO)
|
|
)
|
|
;
|
|
DebugTypes = no
|
|
),
|
|
( if Iteration < MaxIterations then
|
|
typecheck_to_fixpoint(Iteration + 1, MaxIterations, !ModuleInfo,
|
|
OrigValidPredIds, OrigValidPredIdSet, FinalValidPredIdSet,
|
|
Specs, FoundSyntaxError, ExceededIterationLimit)
|
|
else
|
|
FinalValidPredIdSet = NewValidPredIdSet,
|
|
Specs = [typecheck_report_max_iterations_exceeded(MaxIterations)],
|
|
FoundSyntaxError = CurFoundSyntaxError,
|
|
ExceededIterationLimit = yes
|
|
)
|
|
).
|
|
|
|
% Write out the inferred `pred' or `func' declarations for a list of
|
|
% predicates. Don't write out the inferred types for assertions.
|
|
%
|
|
:- pred construct_type_inference_messages(module_info::in,
|
|
set_tree234(pred_id)::in, list(pred_id)::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
construct_type_inference_messages(_, _, [], !Specs).
|
|
construct_type_inference_messages(ModuleInfo, ValidPredIdSet,
|
|
[PredId | PredIds], !Specs) :-
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_markers(PredInfo, Markers),
|
|
( if
|
|
check_marker(Markers, marker_infer_type),
|
|
set_tree234.contains(ValidPredIdSet, PredId),
|
|
not pred_info_is_promise(PredInfo, _)
|
|
then
|
|
Spec = construct_type_inference_message(ModuleInfo, PredId, PredInfo),
|
|
!:Specs = [Spec | !.Specs]
|
|
else
|
|
true
|
|
),
|
|
construct_type_inference_messages(ModuleInfo, ValidPredIdSet,
|
|
PredIds, !Specs).
|
|
|
|
% Construct a message containing the inferred `pred' or `func' declaration
|
|
% for a single predicate.
|
|
%
|
|
:- func construct_type_inference_message(module_info, pred_id, pred_info)
|
|
= error_spec.
|
|
|
|
construct_type_inference_message(ModuleInfo, PredId, PredInfo) = Spec :-
|
|
PredName = pred_info_name(PredInfo),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
UnqualPredSymName = unqualified(PredName),
|
|
pred_info_get_context(PredInfo, Context),
|
|
pred_info_get_arg_types(PredInfo, VarSet, ExistQVars, Types0),
|
|
strip_builtin_qualifiers_from_type_list(Types0, Types),
|
|
pred_info_get_class_context(PredInfo, ClassContext),
|
|
pred_info_get_purity(PredInfo, Purity),
|
|
MaybeDet = no,
|
|
VarNamePrint = print_name_only,
|
|
(
|
|
PredOrFunc = pf_predicate,
|
|
ArgTypes = Types,
|
|
MaybeReturnType = no,
|
|
TypeStr = mercury_pred_type_to_string(VarSet, VarNamePrint, ExistQVars,
|
|
UnqualPredSymName, Types, MaybeDet, Purity, ClassContext)
|
|
;
|
|
PredOrFunc = pf_function,
|
|
pred_args_to_func_args(Types, ArgTypes, ReturnType),
|
|
MaybeReturnType = yes(ReturnType),
|
|
TypeStr = mercury_func_type_to_string(VarSet, VarNamePrint, ExistQVars,
|
|
UnqualPredSymName, ArgTypes, ReturnType, MaybeDet, Purity,
|
|
ClassContext)
|
|
),
|
|
InferredPieces = [invis_order_default_start(2),
|
|
words("Inferred"), words(TypeStr), nl],
|
|
|
|
module_info_get_predicate_table(ModuleInfo, PredicateTable),
|
|
ModuleName = pred_info_module(PredInfo),
|
|
QualPredSymName = qualified(ModuleName, PredName),
|
|
predicate_table_lookup_pf_sym(PredicateTable, is_fully_qualified,
|
|
PredOrFunc, QualPredSymName, AllPredIds),
|
|
list.delete_all(AllPredIds, PredId, AllOtherPredIds),
|
|
PredIsDeclared =
|
|
( pred(OtherPredId::in) is semidet :-
|
|
module_info_pred_info(ModuleInfo, OtherPredId, OtherPredInfo),
|
|
pred_info_get_markers(OtherPredInfo, OtherPredMarkers),
|
|
not check_marker(OtherPredMarkers, marker_infer_type)
|
|
),
|
|
list.filter(PredIsDeclared, AllOtherPredIds, AllOtherDeclaredPredIds),
|
|
(
|
|
AllOtherDeclaredPredIds = [],
|
|
Spec = conditional_spec($pred, inform_inferred_types, yes,
|
|
severity_informational, phase_type_check,
|
|
[simplest_msg(Context, InferredPieces)])
|
|
;
|
|
AllOtherDeclaredPredIds = [_ | _],
|
|
list.map(
|
|
construct_pred_decl_diff(ModuleInfo, ArgTypes, MaybeReturnType),
|
|
AllOtherDeclaredPredIds, DiffPieceLists),
|
|
Pieces = [invis_order_default_start(2)] ++ InferredPieces ++
|
|
list.condense(DiffPieceLists),
|
|
Spec = simplest_spec($pred, severity_informational, phase_type_check,
|
|
Context, Pieces)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- func typecheck_report_max_iterations_exceeded(int) = error_spec.
|
|
|
|
typecheck_report_max_iterations_exceeded(MaxIterations) = Spec :-
|
|
Pieces = [words("Type inference iteration limit exceeded."),
|
|
words("This probably indicates that your program has a type error."),
|
|
words("You should declare the types explicitly."),
|
|
words("(The current limit is"), int_fixed(MaxIterations),
|
|
words("iterations."),
|
|
words("You can use the"), quote("--type-inference-iteration-limit"),
|
|
words("option to increase the limit).")],
|
|
Msg = error_msg(no, do_not_treat_as_first, 0, [always(Pieces)]),
|
|
Spec = error_spec($pred, severity_error, phase_type_check, [Msg]).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type next_iteration
|
|
---> next_iteration_is_not_needed
|
|
; next_iteration_is_needed.
|
|
|
|
% Iterate over the list of pred_ids in a module.
|
|
%
|
|
% NOTE: Please update Mercury.options if this predicate is moved to another
|
|
% module. It must be compiled with --optimize-constructor-last-call.
|
|
%
|
|
:- pred typecheck_module_one_iteration(module_info::in,
|
|
set_tree234(pred_id)::in,
|
|
assoc_list(pred_id, pred_info)::in, assoc_list(pred_id, pred_info)::out,
|
|
list(pred_id)::in, list(pred_id)::out,
|
|
list(error_spec)::in, list(error_spec)::out,
|
|
bool::in, bool::out, next_iteration::in, next_iteration::out) is det.
|
|
|
|
typecheck_module_one_iteration(_, _, [], [],
|
|
!NewlyInvalidPredIds, !Specs, !FoundSyntaxError, !NextIteration).
|
|
typecheck_module_one_iteration(ModuleInfo, ValidPredIdSet,
|
|
[HeadPredIdInfo0 | TailPredIdsInfos0], PredIdInfos,
|
|
!NewlyInvalidPredIds, !Specs, !FoundSyntaxError, !NextIteration) :-
|
|
HeadPredIdInfo0 = PredId - PredInfo0,
|
|
( if
|
|
(
|
|
pred_info_is_imported(PredInfo0)
|
|
;
|
|
not set_tree234.contains(ValidPredIdSet, PredId)
|
|
)
|
|
then
|
|
HeadPredIdInfo = HeadPredIdInfo0,
|
|
typecheck_module_one_iteration(ModuleInfo, ValidPredIdSet,
|
|
TailPredIdsInfos0, TailPredIdsInfos, !NewlyInvalidPredIds,
|
|
!Specs, !FoundSyntaxError, !NextIteration),
|
|
PredIdInfos = [HeadPredIdInfo | TailPredIdsInfos] % lcmc
|
|
else
|
|
% Potential parallelization site.
|
|
typecheck_pred_if_needed(ModuleInfo, PredId, PredInfo0, PredInfo,
|
|
PredSpecs, PredSyntaxError, ContainsErrors, PredNextIteration),
|
|
(
|
|
ContainsErrors = no
|
|
;
|
|
ContainsErrors = yes,
|
|
% This code is not needed at the moment, since currently we don't
|
|
% run mode analysis if there are any type errors. And this code
|
|
% also causes problems: if there are undefined modes, it can end up
|
|
% calling error/1, since post_finish_ill_typed_pred assumes that
|
|
% there are no undefined modes.
|
|
%
|
|
% If we get an error, we need to call post_finish_ill_typed_pred
|
|
% on the pred, to ensure that its mode declaration gets properly
|
|
% module qualified; then we call `remove_predid', so that the
|
|
% predicate's definition will be ignored by later passes
|
|
% (the declaration will still be used to check any calls to it).
|
|
%
|
|
% post_finish_ill_typed_pred(ModuleInfo0, PredId,
|
|
% PredInfo1, PredInfo)
|
|
!:NewlyInvalidPredIds = [PredId | !.NewlyInvalidPredIds]
|
|
),
|
|
HeadPredIdInfo = PredId - PredInfo,
|
|
!:Specs = PredSpecs ++ !.Specs,
|
|
bool.or(PredSyntaxError, !FoundSyntaxError),
|
|
(
|
|
PredNextIteration = next_iteration_is_not_needed
|
|
;
|
|
PredNextIteration = next_iteration_is_needed,
|
|
!:NextIteration = next_iteration_is_needed
|
|
),
|
|
typecheck_module_one_iteration(ModuleInfo, ValidPredIdSet,
|
|
TailPredIdsInfos0, TailPredIdsInfos, !NewlyInvalidPredIds,
|
|
!Specs, !FoundSyntaxError, !NextIteration),
|
|
PredIdInfos = [HeadPredIdInfo | TailPredIdsInfos] % lcmc
|
|
).
|
|
|
|
:- pred typecheck_pred_if_needed(module_info::in, pred_id::in,
|
|
pred_info::in, pred_info::out, list(error_spec)::out,
|
|
bool::out, bool::out, next_iteration::out) is det.
|
|
|
|
typecheck_pred_if_needed(ModuleInfo, PredId, !PredInfo, !:Specs,
|
|
FoundSyntaxError, ContainsErrors, NextIteration) :-
|
|
( if is_pred_created_type_correct(ModuleInfo, !PredInfo) then
|
|
!:Specs = [],
|
|
FoundSyntaxError = no,
|
|
ContainsErrors = no,
|
|
NextIteration = next_iteration_is_not_needed
|
|
else
|
|
pred_info_get_clauses_info(!.PredInfo, ClausesInfo0),
|
|
clauses_info_get_had_syntax_errors(ClausesInfo0, FoundSyntaxError0),
|
|
( FoundSyntaxError0 = no_clause_syntax_errors, FoundSyntaxError = no
|
|
; FoundSyntaxError0 = some_clause_syntax_errors, FoundSyntaxError = yes
|
|
),
|
|
typecheck_predicate_if_stub(ModuleInfo, PredId, !PredInfo,
|
|
FoundSyntaxError, !:Specs, MaybeNeedTypecheck),
|
|
(
|
|
MaybeNeedTypecheck = do_not_need_typecheck(ContainsErrors,
|
|
NextIteration)
|
|
;
|
|
MaybeNeedTypecheck = do_need_typecheck,
|
|
do_typecheck_pred(ModuleInfo, PredId, !PredInfo, !Specs,
|
|
NextIteration),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
ContainsErrors = contains_errors(Globals, !.Specs)
|
|
)
|
|
).
|
|
|
|
:- pred is_pred_created_type_correct(module_info::in,
|
|
pred_info::in, pred_info::out) is semidet.
|
|
|
|
is_pred_created_type_correct(ModuleInfo, !PredInfo) :-
|
|
( if
|
|
(
|
|
% Most compiler-generated unify and compare predicates are created
|
|
% already type-correct, so there is no need to typecheck them.
|
|
% The exceptions are predicates that call a user-defined equality
|
|
% or comparison predicate, and unify and compare predicates for
|
|
% existentially typed data types.
|
|
is_unify_index_or_compare_pred(!.PredInfo),
|
|
not special_pred_needs_typecheck(!.PredInfo, ModuleInfo)
|
|
;
|
|
% Most predicates for builtins are also created already
|
|
% type-correct. The exceptions still need to have their stub
|
|
% clauses generated; these are marked with marker_builtin_stub.
|
|
% XXX Why the delay?
|
|
pred_info_is_builtin(!.PredInfo),
|
|
pred_info_get_markers(!.PredInfo, Markers),
|
|
not check_marker(Markers, marker_builtin_stub)
|
|
)
|
|
then
|
|
pred_info_get_clauses_info(!.PredInfo, ClausesInfo0),
|
|
clauses_info_get_clauses_rep(ClausesInfo0, ClausesRep0, _ItemNumbers),
|
|
IsEmpty = clause_list_is_empty(ClausesRep0),
|
|
(
|
|
IsEmpty = yes,
|
|
pred_info_mark_as_external(!PredInfo)
|
|
;
|
|
IsEmpty = no
|
|
)
|
|
else
|
|
fail
|
|
).
|
|
|
|
:- type maybe_need_typecheck
|
|
---> do_not_need_typecheck(
|
|
notc_contains_errors :: bool,
|
|
notc_next_iteration :: next_iteration
|
|
)
|
|
; do_need_typecheck.
|
|
|
|
:- pred typecheck_predicate_if_stub(module_info::in, pred_id::in,
|
|
pred_info::in, pred_info::out, bool::in,
|
|
list(error_spec)::out, maybe_need_typecheck::out) is det.
|
|
|
|
typecheck_predicate_if_stub(ModuleInfo, PredId, !PredInfo, FoundSyntaxError,
|
|
!:Specs, MaybeNeedTypecheck) :-
|
|
% Handle the --allow-stubs and --warn-stubs options.
|
|
% If --allow-stubs is set, and there are no clauses, then
|
|
% - issue a warning (if --warn-stubs is set), and then
|
|
% - generate a "stub" clause that just throws an exception.
|
|
% The real work is done by do_typecheck_pred.
|
|
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
pred_info_get_markers(!.PredInfo, Markers0),
|
|
|
|
pred_info_get_clauses_info(!.PredInfo, ClausesInfo0),
|
|
clauses_info_get_clauses_rep(ClausesInfo0, ClausesRep0, ItemNumbers0),
|
|
clause_list_is_empty(ClausesRep0) = ClausesRep0IsEmpty,
|
|
(
|
|
ClausesRep0IsEmpty = yes,
|
|
% There are no clauses, so there can be no clause non-contiguity
|
|
% errors.
|
|
( if
|
|
globals.lookup_bool_option(Globals, allow_stubs, yes),
|
|
not check_marker(Markers0, marker_class_method)
|
|
then
|
|
!:Specs =
|
|
maybe_report_no_clauses_stub(ModuleInfo, PredId, !.PredInfo),
|
|
generate_stub_clause(ModuleInfo, PredId, !PredInfo)
|
|
else if
|
|
check_marker(Markers0, marker_builtin_stub)
|
|
then
|
|
!:Specs = [],
|
|
generate_stub_clause(ModuleInfo, PredId, !PredInfo)
|
|
else
|
|
!:Specs = []
|
|
)
|
|
;
|
|
ClausesRep0IsEmpty = no,
|
|
% There are clauses, so there can be no need to add stub clauses.
|
|
globals.lookup_bool_option(Globals, warn_non_contiguous_foreign_procs,
|
|
WarnNonContiguousForeignProcs),
|
|
(
|
|
WarnNonContiguousForeignProcs = yes,
|
|
!:Specs = report_any_non_contiguous_clauses(ModuleInfo,
|
|
PredId, !.PredInfo, ItemNumbers0, clauses_and_foreign_procs)
|
|
;
|
|
WarnNonContiguousForeignProcs = no,
|
|
globals.lookup_bool_option(Globals, warn_non_contiguous_clauses,
|
|
WarnNonContiguousClauses),
|
|
(
|
|
WarnNonContiguousClauses = yes,
|
|
!:Specs = report_any_non_contiguous_clauses(ModuleInfo,
|
|
PredId, !.PredInfo, ItemNumbers0, only_clauses)
|
|
;
|
|
WarnNonContiguousClauses = no,
|
|
!:Specs = []
|
|
)
|
|
)
|
|
),
|
|
|
|
% The above code may add stub clauses to the predicate, which would
|
|
% invalidate ClausesInfo0.
|
|
pred_info_get_clauses_info(!.PredInfo, ClausesInfo1),
|
|
clauses_info_get_clauses_rep(ClausesInfo1, ClausesRep1, _ItemNumbers),
|
|
clause_list_is_empty(ClausesRep1) = ClausesRep1IsEmpty,
|
|
(
|
|
ClausesRep1IsEmpty = yes,
|
|
expect(unify(!.Specs, []), $pred, "starting Specs not empty"),
|
|
|
|
% There are no clauses for class methods. The clauses are generated
|
|
% later on, in polymorphism.expand_class_method_bodies.
|
|
% XXX Why the delay?
|
|
( if check_marker(Markers0, marker_class_method) then
|
|
% For the moment, we just insert the types of the head vars
|
|
% into the clauses_info.
|
|
clauses_info_get_headvar_list(ClausesInfo1, HeadVars),
|
|
pred_info_get_arg_types(!.PredInfo, _ArgTypeVarSet, _ExistQVars,
|
|
ArgTypes),
|
|
vartypes_from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
|
|
clauses_info_set_vartypes(VarTypes, ClausesInfo1, ClausesInfo),
|
|
pred_info_set_clauses_info(ClausesInfo, !PredInfo),
|
|
% We also need to set the external_type_params field
|
|
% to indicate that all the existentially quantified tvars
|
|
% in the head of this pred are indeed bound by this predicate.
|
|
type_vars_list(ArgTypes, HeadVarsInclExistentials),
|
|
pred_info_set_external_type_params(HeadVarsInclExistentials,
|
|
!PredInfo),
|
|
ContainsErrors = no,
|
|
!:Specs = []
|
|
else
|
|
ContainsErrors = yes,
|
|
(
|
|
FoundSyntaxError = no,
|
|
!:Specs =
|
|
maybe_report_no_clauses(ModuleInfo, PredId, !.PredInfo)
|
|
;
|
|
FoundSyntaxError = yes,
|
|
% There were clauses, they just had errors. Printing a message
|
|
% saying that there were no clauses would be misleading,
|
|
% and the messages for the syntax errors will mean that
|
|
% this compiler invocation won't succeed anyway.
|
|
!:Specs = []
|
|
)
|
|
),
|
|
MaybeNeedTypecheck = do_not_need_typecheck(ContainsErrors,
|
|
next_iteration_is_not_needed)
|
|
;
|
|
ClausesRep1IsEmpty = no,
|
|
(
|
|
FoundSyntaxError = no,
|
|
MaybeNeedTypecheck = do_need_typecheck
|
|
;
|
|
FoundSyntaxError = yes,
|
|
% Printing the messages we generated above could be misleading,
|
|
% and the messages for the syntax errors will mean that
|
|
% this compiler invocation won't succeed anyway.
|
|
!:Specs = [],
|
|
ContainsErrors = yes,
|
|
MaybeNeedTypecheck = do_not_need_typecheck(ContainsErrors,
|
|
next_iteration_is_not_needed)
|
|
)
|
|
).
|
|
|
|
:- func report_any_non_contiguous_clauses(module_info, pred_id, pred_info,
|
|
clause_item_numbers, clause_item_number_types) = list(error_spec).
|
|
|
|
report_any_non_contiguous_clauses(ModuleInfo, PredId, PredInfo, ItemNumbers,
|
|
Type) = Specs :-
|
|
( if
|
|
clauses_are_non_contiguous(ItemNumbers, Type,
|
|
FirstRegion, SecondRegion, LaterRegions)
|
|
then
|
|
Spec = report_non_contiguous_clauses(ModuleInfo, PredId,
|
|
PredInfo, FirstRegion, SecondRegion, LaterRegions),
|
|
Specs = [Spec]
|
|
else
|
|
Specs = []
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred do_typecheck_pred(module_info::in, pred_id::in,
|
|
pred_info::in, pred_info::out,
|
|
list(error_spec)::in, list(error_spec)::out, next_iteration::out) is det.
|
|
|
|
do_typecheck_pred(ModuleInfo, PredId, !PredInfo, !Specs, NextIteration) :-
|
|
some [!Info, !TypeAssignSet, !ClausesInfo, !ExternalTypeParams] (
|
|
pred_info_get_clauses_info(!.PredInfo, !:ClausesInfo),
|
|
clauses_info_get_clauses_rep(!.ClausesInfo, ClausesRep0, ItemNumbers),
|
|
clauses_info_get_headvar_list(!.ClausesInfo, HeadVars),
|
|
clauses_info_get_varset(!.ClausesInfo, ClauseVarSet),
|
|
clauses_info_get_explicit_vartypes(!.ClausesInfo, ExplicitVarTypes0),
|
|
pred_info_get_status(!.PredInfo, PredStatus),
|
|
pred_info_get_typevarset(!.PredInfo, TypeVarSet0),
|
|
pred_info_get_arg_types(!.PredInfo, _ArgTypeVarSet, ExistQVars0,
|
|
ArgTypes0),
|
|
pred_info_get_markers(!.PredInfo, Markers0),
|
|
( if check_marker(Markers0, marker_infer_type) then
|
|
% For a predicate whose type is inferred, the predicate is allowed
|
|
% to bind the type variables in the head of the predicate's type
|
|
% declaration. Such predicates are given an initial type
|
|
% declaration of `pred foo(T1, T2, ..., TN)' by make_hlds.m.
|
|
Inferring = yes,
|
|
trace [io(!IO)] (
|
|
write_pred_progress_message("% Inferring type of ",
|
|
PredId, ModuleInfo, !IO)
|
|
),
|
|
!:ExternalTypeParams = [],
|
|
PredConstraints = constraints([], [])
|
|
else
|
|
Inferring = no,
|
|
trace [io(!IO)] (
|
|
write_pred_progress_message("% Type-checking ", PredId,
|
|
ModuleInfo, !IO)
|
|
),
|
|
type_vars_list(ArgTypes0, !:ExternalTypeParams),
|
|
pred_info_get_class_context(!.PredInfo, PredConstraints),
|
|
constraint_list_get_tvars(PredConstraints ^ univ_constraints,
|
|
UnivTVars),
|
|
!:ExternalTypeParams = UnivTVars ++ !.ExternalTypeParams,
|
|
list.sort_and_remove_dups(!ExternalTypeParams),
|
|
list.delete_elems(!.ExternalTypeParams, ExistQVars0,
|
|
!:ExternalTypeParams)
|
|
),
|
|
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
make_head_hlds_constraints(ClassTable, TypeVarSet0,
|
|
PredConstraints, Constraints),
|
|
type_assign_set_init(TypeVarSet0, ExplicitVarTypes0,
|
|
!.ExternalTypeParams, Constraints, !:TypeAssignSet),
|
|
pred_info_get_markers(!.PredInfo, PredMarkers),
|
|
typecheck_info_init(ModuleInfo, PredId, !.PredInfo,
|
|
ClauseVarSet, PredStatus, PredMarkers, !.Specs, !:Info),
|
|
get_clause_list_for_replacement(ClausesRep0, Clauses0),
|
|
typecheck_clause_list(HeadVars, ArgTypes0, Clauses0, Clauses,
|
|
!TypeAssignSet, !Info),
|
|
% We need to perform a final pass of context reduction at the end,
|
|
% before checking the typeclass constraints.
|
|
pred_info_get_context(!.PredInfo, Context),
|
|
perform_context_reduction(Context, !TypeAssignSet, !Info),
|
|
typecheck_check_for_ambiguity(Context, whole_pred, HeadVars,
|
|
!.TypeAssignSet, !Info),
|
|
type_assign_set_get_final_info(!.TypeAssignSet,
|
|
!.ExternalTypeParams, ExistQVars0, ExplicitVarTypes0, TypeVarSet,
|
|
!:ExternalTypeParams, InferredVarTypes0, InferredTypeConstraints0,
|
|
ConstraintProofMap, ConstraintMap,
|
|
TVarRenaming, ExistTypeRenaming),
|
|
vartypes_optimize(InferredVarTypes0, InferredVarTypes),
|
|
clauses_info_set_vartypes(InferredVarTypes, !ClausesInfo),
|
|
|
|
% Apply substitutions to the explicit vartypes.
|
|
(
|
|
ExistQVars0 = [],
|
|
ExplicitVarTypes1 = ExplicitVarTypes0
|
|
;
|
|
ExistQVars0 = [_ | _],
|
|
apply_variable_renaming_to_vartypes(ExistTypeRenaming,
|
|
ExplicitVarTypes0, ExplicitVarTypes1)
|
|
),
|
|
apply_variable_renaming_to_vartypes(TVarRenaming,
|
|
ExplicitVarTypes1, ExplicitVarTypes),
|
|
|
|
clauses_info_set_explicit_vartypes(ExplicitVarTypes, !ClausesInfo),
|
|
set_clause_list(Clauses, ClausesRep),
|
|
clauses_info_set_clauses_rep(ClausesRep, ItemNumbers, !ClausesInfo),
|
|
pred_info_set_clauses_info(!.ClausesInfo, !PredInfo),
|
|
pred_info_set_typevarset(TypeVarSet, !PredInfo),
|
|
pred_info_set_constraint_proof_map(ConstraintProofMap, !PredInfo),
|
|
pred_info_set_constraint_map(ConstraintMap, !PredInfo),
|
|
|
|
% Split the inferred type class constraints into those that apply
|
|
% only to the head variables, and those that apply to type variables
|
|
% which occur only in the body.
|
|
lookup_var_types(InferredVarTypes, HeadVars, ArgTypes),
|
|
type_vars_list(ArgTypes, ArgTypeVars),
|
|
restrict_to_head_vars(InferredTypeConstraints0, ArgTypeVars,
|
|
InferredTypeConstraints, UnprovenBodyConstraints),
|
|
|
|
% If there are any as-yet-unproven constraints on type variables
|
|
% in the body, then save these in the pred_info. If it turns out that
|
|
% this pass was the last pass of type inference, the post_typecheck
|
|
% pass will report an error. But we can't report an error now, because
|
|
% a later pass of type inference could cause some type variables
|
|
% to become bound to types that make the constraints satisfiable,
|
|
% causing the error to go away.
|
|
pred_info_set_unproven_body_constraints(UnprovenBodyConstraints,
|
|
!PredInfo),
|
|
|
|
(
|
|
Inferring = yes,
|
|
% We need to infer which of the head variable types must be
|
|
% existentially quantified.
|
|
infer_existential_types(ArgTypeVars, ExistQVars,
|
|
!ExternalTypeParams),
|
|
|
|
% Now save the information we inferred in the pred_info.
|
|
pred_info_set_external_type_params(!.ExternalTypeParams,
|
|
!PredInfo),
|
|
pred_info_set_arg_types(TypeVarSet, ExistQVars, ArgTypes,
|
|
!PredInfo),
|
|
pred_info_get_class_context(!.PredInfo, OldTypeConstraints),
|
|
pred_info_set_class_context(InferredTypeConstraints, !PredInfo),
|
|
|
|
% Check if anything changed.
|
|
( if
|
|
(
|
|
% If the argument types and the type constraints are
|
|
% identical up to renaming, then nothing has changed.
|
|
pred_info_get_tvar_kind_map(!.PredInfo, TVarKindMap),
|
|
argtypes_identical_up_to_renaming(TVarKindMap, ExistQVars0,
|
|
ArgTypes0, OldTypeConstraints, ExistQVars, ArgTypes,
|
|
InferredTypeConstraints)
|
|
;
|
|
% Promises cannot be called from anywhere. Therefore
|
|
% even if the types of their arguments have changed,
|
|
% this fact won't affect the type analysis of any other
|
|
% predicate.
|
|
pred_info_get_goal_type(!.PredInfo, GoalType),
|
|
GoalType = goal_type_promise(_)
|
|
)
|
|
then
|
|
NextIteration = next_iteration_is_not_needed
|
|
else
|
|
NextIteration = next_iteration_is_needed
|
|
)
|
|
;
|
|
Inferring = no,
|
|
pred_info_set_external_type_params(!.ExternalTypeParams,
|
|
!PredInfo),
|
|
pred_info_get_origin(!.PredInfo, Origin0),
|
|
|
|
% Leave the original argtypes etc., but apply any substitutions
|
|
% that map existentially quantified type variables to other
|
|
% type vars, and then rename them all to match the new typevarset,
|
|
% so that the type variables names match up (e.g. with the type
|
|
% variables in the constraint_proofs)
|
|
|
|
% Apply any type substitutions that map existentially quantified
|
|
% type variables to other type vars.
|
|
(
|
|
ExistQVars0 = [],
|
|
% Optimize common case.
|
|
ExistQVars1 = [],
|
|
ArgTypes1 = ArgTypes0,
|
|
PredConstraints1 = PredConstraints,
|
|
Origin1 = Origin0
|
|
;
|
|
ExistQVars0 = [_ | _],
|
|
list.foldl(
|
|
check_existq_clause(TypeVarSet0, ExistQVars0),
|
|
Clauses, !Info),
|
|
|
|
apply_renaming_in_vars(ExistTypeRenaming,
|
|
ExistQVars0, ExistQVars1),
|
|
apply_variable_renaming_to_type_list(ExistTypeRenaming,
|
|
ArgTypes0, ArgTypes1),
|
|
apply_variable_renaming_to_prog_constraints(
|
|
ExistTypeRenaming, PredConstraints, PredConstraints1),
|
|
rename_instance_method_constraints(ExistTypeRenaming,
|
|
Origin0, Origin1)
|
|
),
|
|
|
|
% Rename them all to match the new typevarset.
|
|
apply_renaming_in_vars(TVarRenaming,
|
|
ExistQVars1, ExistQVars),
|
|
apply_variable_renaming_to_type_list(TVarRenaming, ArgTypes1,
|
|
RenamedOldArgTypes),
|
|
apply_variable_renaming_to_prog_constraints(TVarRenaming,
|
|
PredConstraints1, RenamedOldConstraints),
|
|
rename_instance_method_constraints(TVarRenaming, Origin1, Origin),
|
|
|
|
% Save the results in the pred_info.
|
|
pred_info_set_arg_types(TypeVarSet, ExistQVars, RenamedOldArgTypes,
|
|
!PredInfo),
|
|
pred_info_set_class_context(RenamedOldConstraints, !PredInfo),
|
|
pred_info_set_origin(Origin, !PredInfo),
|
|
|
|
NextIteration = next_iteration_is_not_needed
|
|
),
|
|
typecheck_info_get_all_errors(!.Info, !:Specs)
|
|
).
|
|
|
|
:- pred check_existq_clause(tvarset::in, existq_tvars::in, clause::in,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
check_existq_clause(TypeVarSet, ExistQVars, Clause, !Info) :-
|
|
Goal = Clause ^ clause_body,
|
|
( if Goal = hlds_goal(call_foreign_proc(_, _, _, _, _, _, Impl), _) then
|
|
Context = Clause ^ clause_context,
|
|
list.foldl2(check_mention_existq_var(Context, TypeVarSet, Impl),
|
|
ExistQVars, 1, _N, !Info)
|
|
else
|
|
true
|
|
).
|
|
|
|
:- pred check_mention_existq_var(prog_context::in, tvarset::in,
|
|
pragma_foreign_proc_impl::in, tvar::in, int::in, int::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
check_mention_existq_var(Context, TypeVarSet, Impl, TVar, !ExistQVarNum,
|
|
!Info) :-
|
|
varset.lookup_name(TypeVarSet, TVar, Name),
|
|
OldVarName = "TypeInfo_for_" ++ Name,
|
|
NewVarName = "TypeInfo_Out_" ++ string.int_to_string(!.ExistQVarNum),
|
|
!:ExistQVarNum = !.ExistQVarNum + 1,
|
|
( if
|
|
( foreign_proc_uses_variable(Impl, OldVarName)
|
|
; foreign_proc_uses_variable(Impl, NewVarName)
|
|
)
|
|
then
|
|
true
|
|
else
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
Spec = report_missing_tvar_in_foreign_code(ClauseContext, Context,
|
|
OldVarName),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
).
|
|
|
|
% Mark the predicate as a stub, and generate a clause of the form
|
|
% <p>(...) :-
|
|
% PredName = "<Predname>",
|
|
% private_builtin.no_clauses(PredName).
|
|
% or
|
|
% <p>(...) :-
|
|
% PredName = "<Predname>",
|
|
% private_builtin.sorry(PredName).
|
|
% depending on whether the predicate is part of
|
|
% the Mercury standard library or not.
|
|
%
|
|
:- pred generate_stub_clause(module_info::in, pred_id::in,
|
|
pred_info::in, pred_info::out) is det.
|
|
|
|
generate_stub_clause(ModuleInfo, PredId, !PredInfo) :-
|
|
some [!ClausesInfo] (
|
|
pred_info_get_clauses_info(!.PredInfo, !:ClausesInfo),
|
|
clauses_info_get_varset(!.ClausesInfo, VarSet0),
|
|
PredPieces = describe_one_pred_name(ModuleInfo, should_module_qualify,
|
|
PredId),
|
|
PredName = error_pieces_to_string(PredPieces),
|
|
generate_stub_clause_2(PredName, !PredInfo, ModuleInfo, StubClause,
|
|
VarSet0, VarSet),
|
|
set_clause_list([StubClause], ClausesRep),
|
|
ItemNumbers = init_clause_item_numbers_comp_gen,
|
|
clauses_info_set_clauses_rep(ClausesRep, ItemNumbers, !ClausesInfo),
|
|
clauses_info_set_varset(VarSet, !ClausesInfo),
|
|
pred_info_set_clauses_info(!.ClausesInfo, !PredInfo)
|
|
).
|
|
|
|
:- pred generate_stub_clause_2(string::in, pred_info::in, pred_info::out,
|
|
module_info::in, clause::out, prog_varset::in, prog_varset::out) is det.
|
|
|
|
generate_stub_clause_2(PredName, !PredInfo, ModuleInfo, StubClause, !VarSet) :-
|
|
% Mark the predicate as a stub, i.e. record that it originally
|
|
% had no clauses.
|
|
pred_info_get_markers(!.PredInfo, Markers0),
|
|
add_marker(marker_stub, Markers0, Markers),
|
|
pred_info_set_markers(Markers, !PredInfo),
|
|
|
|
% Generate `PredName = "<PredName>"'.
|
|
pred_info_get_context(!.PredInfo, Context),
|
|
varset.new_named_var("PredName", PredNameVar, !VarSet),
|
|
make_string_const_construction(Context, PredNameVar, PredName, UnifyGoal),
|
|
|
|
% Generate `private_builtin.no_clauses(PredName)'
|
|
% or `private_builtin.sorry(PredName)'
|
|
ModuleName = pred_info_module(!.PredInfo),
|
|
( if mercury_std_library_module_name(ModuleName) then
|
|
CalleeName = "sorry"
|
|
else
|
|
CalleeName = "no_clauses"
|
|
),
|
|
generate_simple_call(ModuleInfo, mercury_private_builtin_module,
|
|
CalleeName, pf_predicate, only_mode, detism_det, purity_pure,
|
|
[PredNameVar], [], instmap_delta_bind_no_var, Context, CallGoal),
|
|
|
|
% Combine the unification and call into a conjunction.
|
|
goal_info_init(Context, GoalInfo),
|
|
Body = hlds_goal(conj(plain_conj, [UnifyGoal, CallGoal]), GoalInfo),
|
|
StubClause = clause(all_modes, Body, impl_lang_mercury, Context, []).
|
|
|
|
:- pred rename_instance_method_constraints(tvar_renaming::in,
|
|
pred_origin::in, pred_origin::out) is det.
|
|
|
|
rename_instance_method_constraints(Renaming, Origin0, Origin) :-
|
|
( if Origin0 = origin_instance_method(MethodName, Constraints0) then
|
|
Constraints0 = instance_method_constraints(ClassId, InstanceTypes0,
|
|
InstanceConstraints0, ClassMethodClassContext0),
|
|
apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
|
|
InstanceTypes),
|
|
apply_variable_renaming_to_prog_constraint_list(Renaming,
|
|
InstanceConstraints0, InstanceConstraints),
|
|
apply_variable_renaming_to_prog_constraints(Renaming,
|
|
ClassMethodClassContext0, ClassMethodClassContext),
|
|
Constraints = instance_method_constraints(ClassId,
|
|
InstanceTypes, InstanceConstraints, ClassMethodClassContext),
|
|
Origin = origin_instance_method(MethodName, Constraints)
|
|
else
|
|
Origin = Origin0
|
|
).
|
|
|
|
% Infer which of the head variable types must be existentially quantified.
|
|
%
|
|
:- pred infer_existential_types(list(tvar)::in, existq_tvars::out,
|
|
external_type_params::in, external_type_params::out) is det.
|
|
|
|
infer_existential_types(ArgTypeVars, ExistQVars,
|
|
ExternalTypeParams0, ExternalTypeParams) :-
|
|
% First, infer which of the head variable types must be existentially
|
|
% quantified: anything that was inserted into the ExternalTypeParams0 set
|
|
% must have been inserted due to an existential type in something we
|
|
% called, and thus must be existentially quantified. (Note that concrete
|
|
% types are "more general" than existentially quantified types, so we
|
|
% prefer to infer a concrete type if we can rather than an
|
|
% existential type.)
|
|
|
|
set.list_to_set(ArgTypeVars, ArgTypeVarsSet),
|
|
set.list_to_set(ExternalTypeParams0, ExternalTypeParamsSet),
|
|
set.intersect(ArgTypeVarsSet, ExternalTypeParamsSet, ExistQVarsSet),
|
|
set.difference(ArgTypeVarsSet, ExistQVarsSet, UnivQVarsSet),
|
|
set.to_sorted_list(ExistQVarsSet, ExistQVars),
|
|
set.to_sorted_list(UnivQVarsSet, UnivQVars),
|
|
|
|
% Then we need to insert the universally quantified head variable types
|
|
% into the ExternalTypeParams set, which will now contain all the type
|
|
% variables that are produced either by stuff we call or by our caller.
|
|
% This is needed so that it has the right value when post_typecheck.m
|
|
% uses it to check for unbound type variables.
|
|
ExternalTypeParams = UnivQVars ++ ExternalTypeParams0.
|
|
|
|
% restrict_to_head_vars(Constraints0, HeadVarTypes, Constraints,
|
|
% UnprovenConstraints):
|
|
%
|
|
% Constraints is the subset of Constraints0 which contain no type variables
|
|
% other than those in HeadVarTypes. UnprovenConstraints is any unproven
|
|
% (universally quantified) type constraints on variables not in
|
|
% HeadVarTypes.
|
|
%
|
|
:- pred restrict_to_head_vars(prog_constraints::in, list(tvar)::in,
|
|
prog_constraints::out, list(prog_constraint)::out) is det.
|
|
|
|
restrict_to_head_vars(constraints(UnivCs0, ExistCs0), ArgVarTypes,
|
|
constraints(UnivCs, ExistCs), UnprovenCs) :-
|
|
restrict_to_head_vars_2(UnivCs0, ArgVarTypes, UnivCs, UnprovenCs),
|
|
restrict_to_head_vars_2(ExistCs0, ArgVarTypes, ExistCs, _).
|
|
|
|
:- pred restrict_to_head_vars_2(list(prog_constraint)::in, list(tvar)::in,
|
|
list(prog_constraint)::out, list(prog_constraint)::out) is det.
|
|
|
|
restrict_to_head_vars_2(ClassConstraints, HeadTypeVars, HeadClassConstraints,
|
|
OtherClassConstraints) :-
|
|
list.filter(is_head_class_constraint(HeadTypeVars),
|
|
ClassConstraints, HeadClassConstraints, OtherClassConstraints).
|
|
|
|
:- pred is_head_class_constraint(list(tvar)::in, prog_constraint::in)
|
|
is semidet.
|
|
|
|
is_head_class_constraint(HeadTypeVars, Constraint) :-
|
|
Constraint = constraint(_ClassName, ArgTypes),
|
|
all [TVar] (
|
|
prog_type.type_list_contains_var(ArgTypes, TVar)
|
|
=>
|
|
list.member(TVar, HeadTypeVars)
|
|
).
|
|
|
|
% Check whether the argument types, type quantifiers, and type constraints
|
|
% are identical up to renaming.
|
|
%
|
|
% Note that we can't compare each of the parts separately, since we need
|
|
% to ensure that the renaming (if any) is consistent over all the arguments
|
|
% and all the constraints. So we need to append all the relevant types
|
|
% into one big type list and then compare them in a single call
|
|
% to identical_up_to_renaming.
|
|
%
|
|
:- pred argtypes_identical_up_to_renaming(tvar_kind_map::in,
|
|
existq_tvars::in, list(mer_type)::in, prog_constraints::in,
|
|
existq_tvars::in, list(mer_type)::in, prog_constraints::in) is semidet.
|
|
|
|
argtypes_identical_up_to_renaming(KindMap, ExistQVarsA, ArgTypesA,
|
|
TypeConstraintsA, ExistQVarsB, ArgTypesB, TypeConstraintsB) :-
|
|
same_structure(TypeConstraintsA, TypeConstraintsB,
|
|
ConstrainedTypesA, ConstrainedTypesB),
|
|
prog_type.var_list_to_type_list(KindMap, ExistQVarsA, ExistQVarTypesA),
|
|
prog_type.var_list_to_type_list(KindMap, ExistQVarsB, ExistQVarTypesB),
|
|
list.condense([ExistQVarTypesA, ArgTypesA, ConstrainedTypesA], TypesListA),
|
|
list.condense([ExistQVarTypesB, ArgTypesB, ConstrainedTypesB], TypesListB),
|
|
identical_up_to_renaming(TypesListA, TypesListB).
|
|
|
|
% Check if two sets of type class constraints have the same structure
|
|
% (i.e. they specify the same list of type classes with the same arities)
|
|
% and if so, concatenate the argument types for all the type classes
|
|
% in each set of type class constraints and return them.
|
|
%
|
|
:- pred same_structure(prog_constraints::in, prog_constraints::in,
|
|
list(mer_type)::out, list(mer_type)::out) is semidet.
|
|
|
|
same_structure(ConstraintsA, ConstraintsB, TypesA, TypesB) :-
|
|
ConstraintsA = constraints(UnivCsA, ExistCsA),
|
|
ConstraintsB = constraints(UnivCsB, ExistCsB),
|
|
% these calls to same_length are just an optimization,
|
|
% to catch the simple cases quicker
|
|
list.same_length(UnivCsA, UnivCsB),
|
|
list.same_length(ExistCsA, ExistCsB),
|
|
same_structure_2(UnivCsA, UnivCsB, UnivTypesA, UnivTypesB),
|
|
same_structure_2(ExistCsA, ExistCsB, ExistTypesA, ExistTypesB),
|
|
TypesA = ExistTypesA ++ UnivTypesA,
|
|
TypesB = ExistTypesB ++ UnivTypesB.
|
|
|
|
:- pred same_structure_2(list(prog_constraint)::in, list(prog_constraint)::in,
|
|
list(mer_type)::out, list(mer_type)::out) is semidet.
|
|
|
|
same_structure_2([], [], [], []).
|
|
same_structure_2([ConstraintA | ConstraintsA], [ConstraintB | ConstraintsB],
|
|
TypesA, TypesB) :-
|
|
ConstraintA = constraint(ClassName, ArgTypesA),
|
|
ConstraintB = constraint(ClassName, ArgTypesB),
|
|
list.same_length(ArgTypesA, ArgTypesB),
|
|
same_structure_2(ConstraintsA, ConstraintsB, TypesA0, TypesB0),
|
|
TypesA = ArgTypesA ++ TypesA0,
|
|
TypesB = ArgTypesB ++ TypesB0.
|
|
|
|
% Check whether two lists of types are identical up to renaming.
|
|
%
|
|
:- pred identical_up_to_renaming(list(mer_type)::in, list(mer_type)::in)
|
|
is semidet.
|
|
|
|
identical_up_to_renaming(TypesList1, TypesList2) :-
|
|
% They are identical up to renaming if they each subsume each other.
|
|
type_list_subsumes(TypesList1, TypesList2, _),
|
|
type_list_subsumes(TypesList2, TypesList1, _).
|
|
|
|
% A compiler-generated predicate only needs type checking if
|
|
% (a) it is a user-defined equality pred, or
|
|
% (b) it is the unification or comparison predicate for an existentially
|
|
% quantified type.
|
|
%
|
|
% In case (b), we need to typecheck it to fill in the external_type_params
|
|
% field in the pred_info.
|
|
%
|
|
:- pred special_pred_needs_typecheck(pred_info::in, module_info::in)
|
|
is semidet.
|
|
|
|
special_pred_needs_typecheck(PredInfo, ModuleInfo) :-
|
|
% Check if the predicate is a compiler-generated special
|
|
% predicate, and if so, for which type.
|
|
pred_info_get_origin(PredInfo, Origin),
|
|
Origin = origin_special_pred(SpecialPredId, TypeCtor),
|
|
|
|
% Check that the special pred isn't one of the builtin types which don't
|
|
% have a hlds_type_defn.
|
|
not list.member(TypeCtor, builtin_type_ctors_with_no_hlds_type_defn),
|
|
|
|
% Check whether that type is a type for which there is a user-defined
|
|
% equality predicate, or which is existentially typed.
|
|
module_info_get_type_table(ModuleInfo, TypeTable),
|
|
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
|
|
hlds_data.get_type_defn_body(TypeDefn, Body),
|
|
special_pred_for_type_needs_typecheck(ModuleInfo, SpecialPredId, Body).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Iterate over the list of clauses for a predicate.
|
|
%
|
|
:- pred typecheck_clause_list(list(prog_var)::in, list(mer_type)::in,
|
|
list(clause)::in, list(clause)::out,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_clause_list(_, _, [], [], !TypeAssignSet, !Info).
|
|
typecheck_clause_list(HeadVars, ArgTypes, [Clause0 | Clauses0],
|
|
[Clause | Clauses], !TypeAssignSet, !Info) :-
|
|
typecheck_clause(HeadVars, ArgTypes, Clause0, Clause,
|
|
!TypeAssignSet, !Info),
|
|
typecheck_clause_list(HeadVars, ArgTypes, Clauses0, Clauses,
|
|
!TypeAssignSet, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Type-check a single clause.
|
|
%
|
|
% As we go through a clause, we determine the set of possible type
|
|
% assignments for the clause. A type assignment is an assignment of a type
|
|
% to each variable in the clause.
|
|
%
|
|
% Note that this may have exponential complexity for both time and space.
|
|
% If there are n variables Vi (for i in 1..n) that may each have either
|
|
% type Ti1 or Ti2, then we generate 2^n type assignments to represent all
|
|
% the possible combinations of their types. This can easily be a serious
|
|
% problem for even medium-sized predicates that extensively use function
|
|
% symbols that belong to more than one type (such as `no', which belongs
|
|
% to both `bool' and `maybe').
|
|
%
|
|
% The pragmatic short-term solution we apply here is to generate a warning
|
|
% when the number of type assignments exceeds one bound (given by the value
|
|
% of the typecheck_ambiguity_warn_limit option), and an error when it
|
|
% exceeds another, higher bound (given by typecheck_ambiguity_error_limit).
|
|
%
|
|
% The better but more long-term solution is to switch to using
|
|
% a constraint based type checker, which does not need to materialize
|
|
% the cross product of all the possible type assignments of different
|
|
% variables in a clause. The module type_constraints.m contains
|
|
% an incomplete prototype of such a type checker.
|
|
%
|
|
:- pred typecheck_clause(list(prog_var)::in, list(mer_type)::in,
|
|
clause::in, clause::out, type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_clause(HeadVars, ArgTypes, !Clause, !TypeAssignSet, !Info) :-
|
|
Body0 = !.Clause ^ clause_body,
|
|
Context = !.Clause ^ clause_context,
|
|
|
|
% Typecheck the clause - first the head unification, and then the body.
|
|
ArgVectorKind = arg_vector_clause_head,
|
|
typecheck_vars_have_types(ArgVectorKind, Context, HeadVars, ArgTypes,
|
|
!TypeAssignSet, !Info),
|
|
typecheck_goal(Body0, Body, Context, !TypeAssignSet, !Info),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
ModuleInfo = ClauseContext ^ tecc_module_info,
|
|
VarSet = ClauseContext ^ tecc_varset,
|
|
type_checkpoint("end of clause", ModuleInfo, VarSet, !.TypeAssignSet,
|
|
!IO)
|
|
),
|
|
!Clause ^ clause_body := Body,
|
|
typecheck_check_for_ambiguity(Context, clause_only, HeadVars,
|
|
!.TypeAssignSet, !Info).
|
|
% We should perhaps do manual garbage collection here.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type stuff_to_check
|
|
---> clause_only
|
|
; whole_pred.
|
|
|
|
% If there are multiple type assignments, then issue an error message.
|
|
%
|
|
% If stuff-to-check = whole_pred, report an error for any ambiguity,
|
|
% and also check for unbound type variables.
|
|
% But if stuff-to-check = clause_only, then only report errors
|
|
% for type ambiguities that don't involve the head vars, because
|
|
% we may be able to resolve a type ambiguity for a head var in one clause
|
|
% by looking at later clauses. (Ambiguities in the head variables
|
|
% can only arise if we are inferring the type for this pred.)
|
|
%
|
|
:- pred typecheck_check_for_ambiguity(prog_context::in, stuff_to_check::in,
|
|
list(prog_var)::in, type_assign_set::in,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_check_for_ambiguity(Context, StuffToCheck, HeadVars,
|
|
TypeAssignSet, !Info) :-
|
|
(
|
|
% There should always be a type assignment, because if there is
|
|
% an error somewhere, instead of setting the current type assignment
|
|
% set to the empty set, the type-checker should continue with the
|
|
% previous type assignment set (so that it can detect other errors
|
|
% in the same clause).
|
|
TypeAssignSet = [],
|
|
unexpected($pred, "no type-assignment")
|
|
;
|
|
TypeAssignSet = [_SingleTypeAssign]
|
|
;
|
|
TypeAssignSet = [TypeAssign1, TypeAssign2 | _],
|
|
% XXX Why do we check only the first two type assigns?
|
|
|
|
% We only report an ambiguity error if
|
|
% (a) we haven't encountered any other errors and if
|
|
% StuffToCheck = clause_only(_), and also
|
|
% (b) the ambiguity occurs only in the body, rather than in the
|
|
% head variables (and hence can't be resolved by looking at
|
|
% later clauses).
|
|
|
|
typecheck_info_get_all_errors(!.Info, ErrorsSoFar),
|
|
( if
|
|
ErrorsSoFar = [],
|
|
(
|
|
StuffToCheck = whole_pred
|
|
;
|
|
StuffToCheck = clause_only,
|
|
|
|
% Only report an error if the headvar types are identical
|
|
% (which means that the ambiguity must have occurred
|
|
% in the body).
|
|
type_assign_get_var_types(TypeAssign1, VarTypes1),
|
|
type_assign_get_var_types(TypeAssign2, VarTypes2),
|
|
type_assign_get_type_bindings(TypeAssign1, TypeBindings1),
|
|
type_assign_get_type_bindings(TypeAssign2, TypeBindings2),
|
|
lookup_var_types(VarTypes1, HeadVars, HeadTypes1),
|
|
lookup_var_types(VarTypes2, HeadVars, HeadTypes2),
|
|
apply_rec_subst_to_type_list(TypeBindings1, HeadTypes1,
|
|
FinalHeadTypes1),
|
|
apply_rec_subst_to_type_list(TypeBindings2, HeadTypes2,
|
|
FinalHeadTypes2),
|
|
identical_up_to_renaming(FinalHeadTypes1, FinalHeadTypes2)
|
|
)
|
|
then
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
typecheck_info_get_overloaded_symbol_map(!.Info,
|
|
OverloadedSymbolMap),
|
|
Spec = report_ambiguity_error(ClauseContext, Context,
|
|
OverloadedSymbolMap, TypeAssign1, TypeAssign2),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
else
|
|
true
|
|
)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred typecheck_goal(hlds_goal::in, hlds_goal::out, prog_context::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_goal(Goal0, Goal, EnclosingContext, !TypeAssignSet, !Info) :-
|
|
% If the context of the goal is empty, we set the context of the goal
|
|
% to the surrounding context. (That should probably be done in make_hlds,
|
|
% but it was easier to do here.)
|
|
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
|
|
Context0 = goal_info_get_context(GoalInfo0),
|
|
( if is_dummy_context(Context0) then
|
|
Context = EnclosingContext,
|
|
goal_info_set_context(Context, GoalInfo0, GoalInfo)
|
|
else
|
|
Context = Context0,
|
|
GoalInfo = GoalInfo0
|
|
),
|
|
|
|
% Our algorithm handles overloading quite inefficiently: for each
|
|
% unification of a variable with a function symbol that matches N type
|
|
% declarations, we make N copies of the existing set of type assignments.
|
|
% In the worst case, therefore, the complexity of our algorithm
|
|
% (space complexity as well as time complexity) is therefore exponential
|
|
% in the number of ambiguous symbols.
|
|
%
|
|
% We issue a warning whenever the number of type assignments exceeds
|
|
% the warn limit, and stop typechecking (after generating an error)
|
|
% whenever it exceeds the error limit.
|
|
|
|
list.length(!.TypeAssignSet, NumTypeAssignSets),
|
|
typecheck_info_get_ambiguity_warn_limit(!.Info, WarnLimit),
|
|
( if NumTypeAssignSets > WarnLimit then
|
|
typecheck_info_get_ambiguity_error_limit(!.Info, ErrorLimit),
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
typecheck_info_get_overloaded_symbol_map(!.Info, OverloadedSymbolMap),
|
|
( if NumTypeAssignSets > ErrorLimit then
|
|
% Override any existing overload warning.
|
|
ErrorSpec = report_error_too_much_overloading(ClauseContext,
|
|
Context, OverloadedSymbolMap),
|
|
typecheck_info_set_overload_error(yes(ErrorSpec), !Info),
|
|
|
|
% Don't call typecheck_goal_expr to do the actual typechecking,
|
|
% since it will almost certainly take too much time and memory.
|
|
GoalExpr = GoalExpr0
|
|
else
|
|
typecheck_info_get_overload_error(!.Info, MaybePrevSpec),
|
|
(
|
|
MaybePrevSpec = no,
|
|
WarnSpec = report_warning_too_much_overloading(ClauseContext,
|
|
Context, OverloadedSymbolMap),
|
|
typecheck_info_set_overload_error(yes(WarnSpec), !Info)
|
|
;
|
|
MaybePrevSpec = yes(_)
|
|
),
|
|
typecheck_goal_expr(GoalExpr0, GoalExpr, GoalInfo,
|
|
!TypeAssignSet, !Info)
|
|
)
|
|
else
|
|
typecheck_goal_expr(GoalExpr0, GoalExpr, GoalInfo,
|
|
!TypeAssignSet, !Info)
|
|
),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo).
|
|
|
|
:- pred typecheck_goal_expr(hlds_goal_expr::in, hlds_goal_expr::out,
|
|
hlds_goal_info::in, type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_goal_expr(GoalExpr0, GoalExpr, GoalInfo, !TypeAssignSet, !Info) :-
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
ModuleInfo = ClauseContext ^ tecc_module_info,
|
|
VarSet = ClauseContext ^ tecc_varset,
|
|
Context = goal_info_get_context(GoalInfo),
|
|
(
|
|
GoalExpr0 = conj(ConjType, List0),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("conj", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal_list(List0, List, Context, !TypeAssignSet, !Info),
|
|
GoalExpr = conj(ConjType, List)
|
|
;
|
|
GoalExpr0 = disj(List0),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("disj", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal_list(List0, List, Context, !TypeAssignSet, !Info),
|
|
GoalExpr = disj(List)
|
|
;
|
|
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("if", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal(Cond0, Cond, Context, !TypeAssignSet, !Info),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("then", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal(Then0, Then, Context, !TypeAssignSet, !Info),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("else", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal(Else0, Else, Context, !TypeAssignSet, !Info),
|
|
ensure_vars_have_a_type(var_vector_cond_quant, Context, Vars,
|
|
!TypeAssignSet, !Info),
|
|
GoalExpr = if_then_else(Vars, Cond, Then, Else)
|
|
;
|
|
GoalExpr0 = negation(SubGoal0),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("not", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal(SubGoal0, SubGoal, Context, !TypeAssignSet, !Info),
|
|
GoalExpr = negation(SubGoal)
|
|
;
|
|
GoalExpr0 = scope(Reason, SubGoal0),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("scope", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal(SubGoal0, SubGoal, Context, !TypeAssignSet, !Info),
|
|
(
|
|
(
|
|
(
|
|
Reason = exist_quant(Vars),
|
|
VarVectorKind = var_vector_exist_quant
|
|
;
|
|
Reason = promise_solutions(Vars, _),
|
|
VarVectorKind = var_vector_promise_solutions
|
|
)
|
|
;
|
|
% These variables are introduced by the compiler and may
|
|
% only have a single, specific type.
|
|
Reason = loop_control(LCVar, LCSVar, _),
|
|
Vars = [LCVar, LCSVar],
|
|
VarVectorKind = var_vector_loop_control
|
|
),
|
|
ensure_vars_have_a_type(VarVectorKind, Context, Vars,
|
|
!TypeAssignSet, !Info)
|
|
;
|
|
( Reason = disable_warnings(_, _)
|
|
; Reason = promise_purity(_)
|
|
; Reason = require_detism(_)
|
|
; Reason = require_complete_switch(_)
|
|
; Reason = require_switch_arms_detism(_, _)
|
|
; Reason = commit(_)
|
|
; Reason = barrier(_)
|
|
; Reason = from_ground_term(_, _)
|
|
; Reason = trace_goal(_, _, _, _, _)
|
|
)
|
|
),
|
|
GoalExpr = scope(Reason, SubGoal)
|
|
;
|
|
GoalExpr0 = plain_call(_, ProcId, Args, BI, UC, Name),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("call", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
list.length(Args, Arity),
|
|
SymNameArity = sym_name_arity(Name, Arity),
|
|
GoalId = goal_info_get_goal_id(GoalInfo),
|
|
typecheck_call_pred_name(SymNameArity, Context, GoalId, Args, PredId,
|
|
!TypeAssignSet, !Info),
|
|
GoalExpr = plain_call(PredId, ProcId, Args, BI, UC, Name)
|
|
;
|
|
GoalExpr0 = generic_call(GenericCall, Args, _Modes, _MaybeArgRegs,
|
|
_Detism),
|
|
(
|
|
GenericCall = higher_order(PredVar, Purity, _, _),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("higher-order call", ModuleInfo, VarSet,
|
|
!.TypeAssignSet,
|
|
!IO)
|
|
),
|
|
hlds_goal.generic_call_to_id(GenericCall, GenericCallId),
|
|
typecheck_higher_order_call(GenericCallId, Context,
|
|
PredVar, Purity, Args, !TypeAssignSet, !Info)
|
|
;
|
|
GenericCall = class_method(_, _, _, _),
|
|
unexpected($pred, "unexpected class method call")
|
|
;
|
|
GenericCall = event_call(EventName),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("event call", ModuleInfo, VarSet,
|
|
!.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_event_call(Context, EventName, Args,
|
|
!TypeAssignSet, !Info)
|
|
;
|
|
GenericCall = cast(_)
|
|
% A cast imposes no restrictions on its argument types,
|
|
% so nothing needs to be done here.
|
|
),
|
|
GoalExpr = GoalExpr0
|
|
;
|
|
GoalExpr0 = unify(LHS, RHS0, UnifyMode, Unification, UnifyContext),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("unify", ModuleInfo, VarSet, !.TypeAssignSet, !IO)
|
|
),
|
|
GoalId = goal_info_get_goal_id(GoalInfo),
|
|
typecheck_unification(UnifyContext, Context, GoalId,
|
|
LHS, RHS0, RHS, !TypeAssignSet, !Info),
|
|
GoalExpr = unify(LHS, RHS, UnifyMode, Unification, UnifyContext)
|
|
;
|
|
GoalExpr0 = switch(_, _, _),
|
|
% We haven't run switch detection yet.
|
|
unexpected($pred, "switch")
|
|
;
|
|
GoalExpr0 = call_foreign_proc(_, PredId, _, Args, _, _, _),
|
|
% Foreign_procs are automatically generated, so they will always be
|
|
% type-correct, but we need to do the type analysis in order to
|
|
% correctly compute the HeadTypeParams that result from existentially
|
|
% typed foreign_procs. (We could probably do that more efficiently
|
|
% than the way it is done below, though.)
|
|
ArgVectorKind = arg_vector_foreign_proc_call(PredId),
|
|
ArgVars = list.map(foreign_arg_var, Args),
|
|
GoalId = goal_info_get_goal_id(GoalInfo),
|
|
typecheck_call_pred_id(ArgVectorKind, Context, GoalId,
|
|
PredId, ArgVars, !TypeAssignSet, !Info),
|
|
perform_context_reduction(Context, !TypeAssignSet, !Info),
|
|
GoalExpr = GoalExpr0
|
|
;
|
|
GoalExpr0 = shorthand(ShortHand0),
|
|
(
|
|
ShortHand0 = bi_implication(LHS0, RHS0),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("<=>", ModuleInfo, VarSet,
|
|
!.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal(LHS0, LHS, Context, !TypeAssignSet, !Info),
|
|
typecheck_goal(RHS0, RHS, Context, !TypeAssignSet, !Info),
|
|
ShortHand = bi_implication(LHS, RHS)
|
|
;
|
|
ShortHand0 = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars,
|
|
MainGoal0, OrElseGoals0, OrElseInners),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("atomic_goal", ModuleInfo, VarSet,
|
|
!.TypeAssignSet, !IO)
|
|
),
|
|
(
|
|
MaybeOutputVars = yes(OutputVars),
|
|
VarVectorKindOutput = var_vector_atomic_output,
|
|
ensure_vars_have_a_type(VarVectorKindOutput, Context,
|
|
OutputVars, !TypeAssignSet, !Info)
|
|
;
|
|
MaybeOutputVars = no
|
|
),
|
|
|
|
typecheck_goal(MainGoal0, MainGoal, Context,
|
|
!TypeAssignSet, !Info),
|
|
typecheck_goal_list(OrElseGoals0, OrElseGoals, Context,
|
|
!TypeAssignSet, !Info),
|
|
|
|
VarVectorKindOuter = var_vector_atomic_outer,
|
|
Outer = atomic_interface_vars(OuterDI, OuterUO),
|
|
ensure_vars_have_a_single_type(VarVectorKindOuter, Context,
|
|
[OuterDI, OuterUO], !TypeAssignSet, !Info),
|
|
|
|
% The outer variables must either be both I/O states or STM states.
|
|
% Checking that here could double the number of type assign sets.
|
|
% We therefore delay the check until after we have typechecked
|
|
% the predicate body, in post_typecheck. The code in the
|
|
% post_typecheck pass (actually in purity.m) will do this
|
|
% if the GoalType is unknown_atomic_goal_type.
|
|
InnerVars =
|
|
atomic_interface_list_to_var_list([Inner | OrElseInners]),
|
|
list.foldl2(typecheck_var_has_stm_atomic_type(Context),
|
|
InnerVars, !TypeAssignSet, !Info),
|
|
expect(unify(GoalType, unknown_atomic_goal_type), $pred,
|
|
"GoalType != unknown_atomic_goal_type"),
|
|
ShortHand = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars,
|
|
MainGoal, OrElseGoals, OrElseInners)
|
|
;
|
|
ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0),
|
|
trace [compiletime(flag("type_checkpoint")), io(!IO)] (
|
|
type_checkpoint("try_goal", ModuleInfo, VarSet,
|
|
!.TypeAssignSet, !IO)
|
|
),
|
|
typecheck_goal(SubGoal0, SubGoal, Context, !TypeAssignSet, !Info),
|
|
(
|
|
MaybeIO = yes(try_io_state_vars(InitialIO, FinalIO)),
|
|
VarVectorKind = var_vector_try_io,
|
|
ensure_vars_have_a_type(VarVectorKind, Context,
|
|
[InitialIO, FinalIO], !TypeAssignSet, !Info),
|
|
InitialGoalContext =
|
|
type_error_in_var_vector(VarVectorKind, 1),
|
|
FinalGoalContext =
|
|
type_error_in_var_vector(VarVectorKind, 2),
|
|
typecheck_var_has_type(InitialGoalContext, Context,
|
|
InitialIO, io_state_type, !TypeAssignSet, !Info),
|
|
typecheck_var_has_type(FinalGoalContext, Context,
|
|
FinalIO, io_state_type, !TypeAssignSet, !Info)
|
|
;
|
|
MaybeIO = no
|
|
),
|
|
ShortHand = try_goal(MaybeIO, ResultVar, SubGoal)
|
|
),
|
|
GoalExpr = shorthand(ShortHand)
|
|
).
|
|
|
|
:- func atomic_interface_list_to_var_list(list(atomic_interface_vars)) =
|
|
list(prog_var).
|
|
|
|
atomic_interface_list_to_var_list([]) = [].
|
|
atomic_interface_list_to_var_list([atomic_interface_vars(I, O) | Interfaces]) =
|
|
[I, O | atomic_interface_list_to_var_list(Interfaces)].
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred typecheck_goal_list(list(hlds_goal)::in, list(hlds_goal)::out,
|
|
prog_context::in, type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_goal_list([], [], _, !TypeAssignSet, !Info).
|
|
typecheck_goal_list([Goal0 | Goals0], [Goal | Goals], Context,
|
|
!TypeAssignSet, !Info) :-
|
|
typecheck_goal(Goal0, Goal, Context, !TypeAssignSet, !Info),
|
|
typecheck_goal_list(Goals0, Goals, Context, !TypeAssignSet, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Ensure that each variable in Vars has been assigned a type.
|
|
%
|
|
:- pred ensure_vars_have_a_type(var_vector_kind::in, prog_context::in,
|
|
list(prog_var)::in, type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
ensure_vars_have_a_type(VarVectorKind, Context, Vars, !TypeAssignSet, !Info) :-
|
|
(
|
|
Vars = []
|
|
;
|
|
Vars = [_ | _],
|
|
% Invent some new type variables to use as the types of these
|
|
% variables. Since each type is the type of a program variable,
|
|
% each must have kind `star'.
|
|
list.length(Vars, NumVars),
|
|
varset.init(TypeVarSet0),
|
|
varset.new_vars(NumVars, TypeVars, TypeVarSet0, TypeVarSet),
|
|
prog_type.var_list_to_type_list(map.init, TypeVars, Types),
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
typecheck_var_has_polymorphic_type_list(VarVectorKind, Context,
|
|
Vars, TypeVarSet, [], Types, EmptyConstraints,
|
|
!TypeAssignSet, !Info)
|
|
).
|
|
|
|
% Ensure that each variable in Vars has been assigned a single type.
|
|
%
|
|
:- pred ensure_vars_have_a_single_type(var_vector_kind::in, prog_context::in,
|
|
list(prog_var)::in, type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
ensure_vars_have_a_single_type(VarVectorKind, Context, Vars,
|
|
!TypeAssignSet, !Info) :-
|
|
(
|
|
Vars = []
|
|
;
|
|
Vars = [_ | _],
|
|
% Invent a new type variable to use as the type of these
|
|
% variables. Since the type is the type of a program variable,
|
|
% each must have kind `star'.
|
|
varset.init(TypeVarSet0),
|
|
varset.new_var(TypeVar, TypeVarSet0, TypeVarSet),
|
|
Type = type_variable(TypeVar, kind_star),
|
|
list.length(Vars, NumVars),
|
|
list.duplicate(NumVars, Type, Types),
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
typecheck_var_has_polymorphic_type_list(VarVectorKind, Context,
|
|
Vars, TypeVarSet, [], Types, EmptyConstraints,
|
|
!TypeAssignSet, !Info)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred typecheck_higher_order_call(generic_call_id::in, prog_context::in,
|
|
prog_var::in, purity::in, list(prog_var)::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_higher_order_call(GenericCallId, Context, PredVar, Purity, Args,
|
|
!TypeAssignSet, !Info) :-
|
|
list.length(Args, Arity),
|
|
higher_order_pred_type(Purity, Arity, lambda_normal,
|
|
TypeVarSet, PredVarType, ArgTypes),
|
|
VarVectorKind = var_vector_args(arg_vector_generic_call(GenericCallId)),
|
|
% The class context is empty because higher-order predicates
|
|
% are always monomorphic. Similarly for ExistQVars.
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
ExistQVars = [],
|
|
typecheck_var_has_polymorphic_type_list(VarVectorKind, Context,
|
|
[PredVar | Args], TypeVarSet, ExistQVars, [PredVarType | ArgTypes],
|
|
EmptyConstraints, !TypeAssignSet, !Info).
|
|
|
|
% higher_order_pred_type(Purity, N, EvalMethod,
|
|
% TypeVarSet, PredType, ArgTypes):
|
|
%
|
|
% Given an arity N, let TypeVarSet = {T1, T2, ..., TN},
|
|
% PredType = `Purity EvalMethod pred(T1, T2, ..., TN)', and
|
|
% ArgTypes = [T1, T2, ..., TN].
|
|
%
|
|
:- pred higher_order_pred_type(purity::in, int::in, lambda_eval_method::in,
|
|
tvarset::out, mer_type::out, list(mer_type)::out) is det.
|
|
|
|
higher_order_pred_type(Purity, Arity, EvalMethod, TypeVarSet, PredType,
|
|
ArgTypes) :-
|
|
varset.init(TypeVarSet0),
|
|
varset.new_vars(Arity, ArgTypeVars, TypeVarSet0, TypeVarSet),
|
|
% Argument types always have kind `star'.
|
|
prog_type.var_list_to_type_list(map.init, ArgTypeVars, ArgTypes),
|
|
construct_higher_order_type(Purity, pf_predicate, EvalMethod, ArgTypes,
|
|
PredType).
|
|
|
|
% higher_order_func_type(Purity, N, EvalMethod, TypeVarSet,
|
|
% FuncType, ArgTypes, RetType):
|
|
%
|
|
% Given an arity N, let TypeVarSet = {T0, T1, T2, ..., TN},
|
|
% FuncType = `Purity EvalMethod func(T1, T2, ..., TN) = T0',
|
|
% ArgTypes = [T1, T2, ..., TN], and
|
|
% RetType = T0.
|
|
%
|
|
:- pred higher_order_func_type(purity::in, int::in, lambda_eval_method::in,
|
|
tvarset::out, mer_type::out, list(mer_type)::out, mer_type::out) is det.
|
|
|
|
higher_order_func_type(Purity, Arity, EvalMethod, TypeVarSet,
|
|
FuncType, ArgTypes, RetType) :-
|
|
varset.init(TypeVarSet0),
|
|
varset.new_vars(Arity, ArgTypeVars, TypeVarSet0, TypeVarSet1),
|
|
varset.new_var(RetTypeVar, TypeVarSet1, TypeVarSet),
|
|
% Argument and return types always have kind `star'.
|
|
prog_type.var_list_to_type_list(map.init, ArgTypeVars, ArgTypes),
|
|
RetType = type_variable(RetTypeVar, kind_star),
|
|
construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType,
|
|
FuncType).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred typecheck_event_call(prog_context::in, string::in, list(prog_var)::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_event_call(Context, EventName, Args, !TypeAssignSet, !Info) :-
|
|
typecheck_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_event_set(ModuleInfo, EventSet),
|
|
EventSpecMap = EventSet ^ event_set_spec_map,
|
|
( if event_arg_types(EventSpecMap, EventName, EventArgTypes) then
|
|
list.length(Args, NumArgs),
|
|
list.length(EventArgTypes, NumEventArgTypes),
|
|
( if NumArgs = NumEventArgTypes then
|
|
ArgVectorKind = arg_vector_event(EventName),
|
|
typecheck_vars_have_types(ArgVectorKind, Context,
|
|
Args, EventArgTypes, !TypeAssignSet, !Info)
|
|
else
|
|
Spec = report_event_args_mismatch(Context,
|
|
EventName, EventArgTypes, Args),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
)
|
|
else
|
|
Spec = report_unknown_event_call_error(Context, EventName),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred typecheck_call_pred_name(sym_name_arity::in, prog_context::in,
|
|
goal_id::in, list(prog_var)::in, pred_id::out,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_call_pred_name(SymNameArity, Context, GoalId, Args, PredId,
|
|
!TypeAssignSet, !Info) :-
|
|
% Look up the called predicate's arg types.
|
|
typecheck_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_predicate_table(ModuleInfo, PredicateTable),
|
|
SymNameArity = sym_name_arity(SymName, Arity),
|
|
typecheck_info_get_calls_are_fully_qualified(!.Info, IsFullyQualified),
|
|
predicate_table_lookup_pf_sym_arity(PredicateTable, IsFullyQualified,
|
|
pf_predicate, SymName, Arity, PredIds),
|
|
(
|
|
PredIds = [],
|
|
PredId = invalid_pred_id,
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
Spec = report_pred_call_error(ClauseContext, Context, SymNameArity),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
;
|
|
PredIds = [HeadPredId | TailPredIds],
|
|
(
|
|
TailPredIds = [],
|
|
% Handle the case of a non-overloaded predicate specially
|
|
% (so that we can optimize the case of a non-overloaded,
|
|
% non-polymorphic predicate).
|
|
PredId = HeadPredId,
|
|
ArgVectorKind = arg_vector_plain_call_pred_id(PredId),
|
|
typecheck_call_pred_id(ArgVectorKind, Context, GoalId,
|
|
PredId, Args, !TypeAssignSet, !Info)
|
|
;
|
|
TailPredIds = [_ | _],
|
|
typecheck_call_overloaded_pred(SymNameArity, Context, GoalId,
|
|
PredIds, Args, !TypeAssignSet, !Info),
|
|
|
|
% In general, we can't figure out which predicate it is until
|
|
% after we have resolved any overloading, which may require
|
|
% type-checking the entire clause. Hence, for the moment, we just
|
|
% record an invalid pred_id in the HLDS. This will be rectified
|
|
% by modes.m during mode-checking; at that point, enough
|
|
% information is available to determine which predicate it is.
|
|
PredId = invalid_pred_id
|
|
),
|
|
|
|
% Arguably, we could do context reduction at a different point.
|
|
% See the paper: "Type classes: an exploration of the design space",
|
|
% S. Peyton-Jones, M. Jones 1997, for a discussion of some of the
|
|
% issues.
|
|
perform_context_reduction(Context, !TypeAssignSet, !Info)
|
|
).
|
|
|
|
% Typecheck a call to a specific predicate.
|
|
%
|
|
:- pred typecheck_call_pred_id(arg_vector_kind::in, prog_context::in,
|
|
goal_id::in, pred_id::in, list(prog_var)::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_call_pred_id(ArgVectorKind, Context, GoalId, PredId, Args,
|
|
!TypeAssignSet, !Info) :-
|
|
typecheck_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_predicate_table(ModuleInfo, PredicateTable),
|
|
predicate_table_get_preds(PredicateTable, Preds),
|
|
map.lookup(Preds, PredId, PredInfo),
|
|
pred_info_get_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes),
|
|
pred_info_get_class_context(PredInfo, PredClassContext),
|
|
|
|
% Rename apart the type variables in the called predicate's arg types
|
|
% and then unify the types of the call arguments with the called
|
|
% predicates' arg types (optimize for the common case of a non-polymorphic,
|
|
% non-constrained predicate).
|
|
( if
|
|
varset.is_empty(PredTypeVarSet),
|
|
PredClassContext = constraints([], [])
|
|
then
|
|
typecheck_vars_have_types(ArgVectorKind, Context, Args,
|
|
PredArgTypes, !TypeAssignSet, !Info)
|
|
else
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
make_body_hlds_constraints(ClassTable, PredTypeVarSet,
|
|
GoalId, PredClassContext, PredConstraints),
|
|
typecheck_var_has_polymorphic_type_list(var_vector_args(ArgVectorKind),
|
|
Context, Args, PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes, PredConstraints, !TypeAssignSet, !Info)
|
|
).
|
|
|
|
:- pred typecheck_call_overloaded_pred(sym_name_arity::in, prog_context::in,
|
|
goal_id::in, list(pred_id)::in, list(prog_var)::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_call_overloaded_pred(SymNameArity, Context, GoalId, PredIdList,
|
|
Args, TypeAssignSet0, TypeAssignSet, !Info) :-
|
|
Symbol = overloaded_pred(SymNameArity, PredIdList),
|
|
typecheck_info_add_overloaded_symbol(Symbol, Context, !Info),
|
|
|
|
% Let the new arg_type_assign_set be the cross-product of the current
|
|
% type_assign_set and the set of possible lists of argument types
|
|
% for the overloaded predicate, suitable renamed apart.
|
|
typecheck_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
module_info_get_predicate_table(ModuleInfo, PredicateTable),
|
|
predicate_table_get_preds(PredicateTable, Preds),
|
|
get_overloaded_pred_arg_types(PredIdList, Preds, ClassTable, GoalId,
|
|
TypeAssignSet0, [], ArgsTypeAssignSet),
|
|
|
|
% Then unify the types of the call arguments with the
|
|
% called predicates' arg types.
|
|
VarVectorKind = var_vector_args(arg_vector_plain_pred_call(SymNameArity)),
|
|
typecheck_var_has_arg_type_list(VarVectorKind, 1, Context, Args,
|
|
ArgsTypeAssignSet, TypeAssignSet, !Info).
|
|
|
|
:- pred get_overloaded_pred_arg_types(list(pred_id)::in, pred_table::in,
|
|
class_table::in, goal_id::in, type_assign_set::in,
|
|
args_type_assign_set::in, args_type_assign_set::out) is det.
|
|
|
|
get_overloaded_pred_arg_types([], _Preds, _ClassTable, _GoalId,
|
|
_TypeAssignSet0, !ArgsTypeAssignSet).
|
|
get_overloaded_pred_arg_types([PredId | PredIds], Preds, ClassTable, GoalId,
|
|
TypeAssignSet0, !ArgsTypeAssignSet) :-
|
|
map.lookup(Preds, PredId, PredInfo),
|
|
pred_info_get_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes),
|
|
pred_info_get_class_context(PredInfo, PredClassContext),
|
|
pred_info_get_typevarset(PredInfo, TVarSet),
|
|
make_body_hlds_constraints(ClassTable, TVarSet, GoalId,
|
|
PredClassContext, PredConstraints),
|
|
rename_apart(TypeAssignSet0, PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes, PredConstraints, !ArgsTypeAssignSet),
|
|
get_overloaded_pred_arg_types(PredIds, Preds, ClassTable, GoalId,
|
|
TypeAssignSet0, !ArgsTypeAssignSet).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Rename apart the type variables in called predicate's arg types
|
|
% separately for each type assignment, resulting in an "arg type
|
|
% assignment set", and then for each arg type assignment in the
|
|
% arg type assignment set, check that the argument variables have
|
|
% the expected types.
|
|
% A set of class constraints are also passed in, which must have the
|
|
% types contained within renamed apart.
|
|
%
|
|
:- pred typecheck_var_has_polymorphic_type_list(var_vector_kind::in,
|
|
prog_context::in, list(prog_var)::in, tvarset::in,
|
|
existq_tvars::in, list(mer_type)::in, hlds_constraints::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_var_has_polymorphic_type_list(VarVectorKind, Context, Args,
|
|
PredTypeVarSet, PredExistQVars, PredArgTypes, PredConstraints,
|
|
TypeAssignSet0, TypeAssignSet, !Info) :-
|
|
rename_apart(TypeAssignSet0, PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes, PredConstraints, [], ArgsTypeAssignSet),
|
|
typecheck_var_has_arg_type_list(VarVectorKind, 1, Context, Args,
|
|
ArgsTypeAssignSet, TypeAssignSet, !Info).
|
|
|
|
:- pred rename_apart(type_assign_set::in, tvarset::in, existq_tvars::in,
|
|
list(mer_type)::in, hlds_constraints::in,
|
|
args_type_assign_set::in, args_type_assign_set::out) is det.
|
|
|
|
rename_apart([], _, _, _, _, !ArgTypeAssigns).
|
|
rename_apart([TypeAssign0 | TypeAssigns0], PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes, PredConstraints, !ArgTypeAssigns) :-
|
|
% Rename everything apart.
|
|
type_assign_rename_apart(TypeAssign0, PredTypeVarSet, PredArgTypes,
|
|
TypeAssign1, ParentArgTypes, Renaming),
|
|
apply_variable_renaming_to_tvar_list(Renaming, PredExistQVars,
|
|
ParentExistQVars),
|
|
apply_variable_renaming_to_constraints(Renaming, PredConstraints,
|
|
ParentConstraints),
|
|
|
|
% Insert the existentially quantified type variables for the called
|
|
% predicate into HeadTypeParams (which holds the set of type
|
|
% variables which the caller is not allowed to bind).
|
|
type_assign_get_external_type_params(TypeAssign1, HeadTypeParams0),
|
|
list.append(ParentExistQVars, HeadTypeParams0, HeadTypeParams),
|
|
type_assign_set_external_type_params(HeadTypeParams,
|
|
TypeAssign1, TypeAssign),
|
|
|
|
% Save the results and recurse.
|
|
NewArgTypeAssign =
|
|
args_type_assign(TypeAssign, ParentArgTypes, ParentConstraints),
|
|
!:ArgTypeAssigns = [NewArgTypeAssign | !.ArgTypeAssigns],
|
|
rename_apart(TypeAssigns0, PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes, PredConstraints, !ArgTypeAssigns).
|
|
|
|
:- pred type_assign_rename_apart(type_assign::in, tvarset::in,
|
|
list(mer_type)::in, type_assign::out, list(mer_type)::out,
|
|
tvar_renaming::out) is det.
|
|
|
|
type_assign_rename_apart(TypeAssign0, PredTypeVarSet, PredArgTypes,
|
|
TypeAssign, ParentArgTypes, Renaming) :-
|
|
type_assign_get_typevarset(TypeAssign0, TypeVarSet0),
|
|
tvarset_merge_renaming(TypeVarSet0, PredTypeVarSet, TypeVarSet, Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, PredArgTypes,
|
|
ParentArgTypes),
|
|
type_assign_set_typevarset(TypeVarSet, TypeAssign0, TypeAssign).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred typecheck_var_has_arg_type_list(var_vector_kind::in, int::in,
|
|
prog_context::in, list(prog_var)::in,
|
|
args_type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_var_has_arg_type_list(_, _, _, [],
|
|
ArgTypeAssignSet, TypeAssignSet, !Info) :-
|
|
TypeAssignSet =
|
|
convert_args_type_assign_set_check_empty_args(ArgTypeAssignSet).
|
|
typecheck_var_has_arg_type_list(VarVectorKind, ArgNum, Context, [Var | Vars],
|
|
ArgTypeAssignSet0, TypeAssignSet, !Info) :-
|
|
GoalContext = type_error_in_var_vector(VarVectorKind, ArgNum),
|
|
typecheck_var_has_arg_type(GoalContext, Context, Var,
|
|
ArgTypeAssignSet0, ArgTypeAssignSet1, !Info),
|
|
typecheck_var_has_arg_type_list(VarVectorKind, ArgNum + 1, Context,
|
|
Vars, ArgTypeAssignSet1, TypeAssignSet, !Info).
|
|
|
|
:- pred typecheck_var_has_arg_type(type_error_goal_context::in,
|
|
prog_context::in, prog_var::in,
|
|
args_type_assign_set::in, args_type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_var_has_arg_type(GoalContext, Context, Var,
|
|
ArgTypeAssignSet0, ArgTypeAssignSet, !Info) :-
|
|
typecheck_var_has_arg_type_2(ArgTypeAssignSet0,
|
|
Var, [], ArgTypeAssignSet1),
|
|
( if
|
|
ArgTypeAssignSet1 = [],
|
|
ArgTypeAssignSet0 = [_ | _]
|
|
then
|
|
delete_first_arg_in_each_arg_type_assign(ArgTypeAssignSet0,
|
|
ArgTypeAssignSet),
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
Spec = report_error_arg_var(!.Info, ClauseContext, GoalContext,
|
|
Context, Var, ArgTypeAssignSet0),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
else
|
|
ArgTypeAssignSet = ArgTypeAssignSet1
|
|
).
|
|
|
|
:- pred delete_first_arg_in_each_arg_type_assign(args_type_assign_set::in,
|
|
args_type_assign_set::out) is det.
|
|
|
|
delete_first_arg_in_each_arg_type_assign([], []).
|
|
delete_first_arg_in_each_arg_type_assign([ArgTypeAssign0 | ArgTypeAssigns0],
|
|
[ArgTypeAssign | ArgTypeAssigns]) :-
|
|
ArgTypeAssign0 = args_type_assign(TypeAssign, Args0, Constraints),
|
|
(
|
|
Args0 = [_ | Args]
|
|
;
|
|
Args0 = [],
|
|
% this should never happen
|
|
unexpected($pred, "skip_arg")
|
|
),
|
|
ArgTypeAssign = args_type_assign(TypeAssign, Args, Constraints),
|
|
delete_first_arg_in_each_arg_type_assign(ArgTypeAssigns0, ArgTypeAssigns).
|
|
|
|
:- pred typecheck_var_has_arg_type_2(args_type_assign_set::in, prog_var::in,
|
|
args_type_assign_set::in, args_type_assign_set::out) is det.
|
|
|
|
typecheck_var_has_arg_type_2([], _, !ArgTypeAssignSet).
|
|
typecheck_var_has_arg_type_2([ArgsTypeAssign | ArgsTypeAssignSets], Var,
|
|
!ArgsTypeAssignSet) :-
|
|
ArgsTypeAssign = args_type_assign(TypeAssign0, ArgTypes0, ClassContext),
|
|
arg_type_assign_var_has_type(TypeAssign0, ArgTypes0,
|
|
Var, ClassContext, !ArgsTypeAssignSet),
|
|
typecheck_var_has_arg_type_2(ArgsTypeAssignSets, Var,
|
|
!ArgsTypeAssignSet).
|
|
|
|
:- pred arg_type_assign_var_has_type(type_assign::in, list(mer_type)::in,
|
|
prog_var::in, hlds_constraints::in,
|
|
args_type_assign_set::in, args_type_assign_set::out) is det.
|
|
|
|
arg_type_assign_var_has_type(TypeAssign0, ArgTypes0, Var, ClassContext,
|
|
!ArgTypeAssignSet) :-
|
|
type_assign_get_var_types(TypeAssign0, VarTypes0),
|
|
(
|
|
ArgTypes0 = [Type | ArgTypes],
|
|
search_insert_var_type(Var, Type, MaybeOldVarType,
|
|
VarTypes0, VarTypes),
|
|
(
|
|
MaybeOldVarType = yes(OldVarType),
|
|
( if
|
|
type_assign_unify_type(OldVarType, Type,
|
|
TypeAssign0, TypeAssign1)
|
|
then
|
|
NewTypeAssign =
|
|
args_type_assign(TypeAssign1, ArgTypes, ClassContext),
|
|
!:ArgTypeAssignSet = [NewTypeAssign | !.ArgTypeAssignSet]
|
|
else
|
|
true
|
|
)
|
|
;
|
|
MaybeOldVarType = no,
|
|
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
|
|
NewTypeAssign =
|
|
args_type_assign(TypeAssign, ArgTypes, ClassContext),
|
|
!:ArgTypeAssignSet = [NewTypeAssign | !.ArgTypeAssignSet]
|
|
)
|
|
;
|
|
ArgTypes0 = [],
|
|
unexpected($pred, "ArgTypes0 = []")
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Given a list of variables and a list of types, ensure that
|
|
% each variable has the corresponding type.
|
|
%
|
|
:- pred typecheck_vars_have_types(arg_vector_kind::in,
|
|
prog_context::in, list(prog_var)::in, list(mer_type)::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_vars_have_types(ArgVectorKind, Context, Vars, Types,
|
|
!TypeAssignSet, !Info) :-
|
|
typecheck_vars_have_types_in_arg_vector(!.Info, Context, ArgVectorKind, 1,
|
|
Vars, Types, !TypeAssignSet, [], Specs, yes([]),
|
|
MaybeArgVectorTypeErrors),
|
|
( if
|
|
MaybeArgVectorTypeErrors = yes(ArgVectorTypeErrors),
|
|
ArgVectorTypeErrors = [_, _ | _]
|
|
then
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
AllArgsSpec = report_arg_vector_type_errors(!.Info, ClauseContext,
|
|
Context, ArgVectorKind, !.TypeAssignSet, ArgVectorTypeErrors),
|
|
typecheck_info_add_error(AllArgsSpec, !Info)
|
|
else
|
|
list.foldl(typecheck_info_add_error, Specs, !Info)
|
|
).
|
|
|
|
:- pred typecheck_vars_have_types_in_arg_vector(typecheck_info::in,
|
|
prog_context::in, arg_vector_kind::in, int::in,
|
|
list(prog_var)::in, list(mer_type)::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
list(error_spec)::in, list(error_spec)::out,
|
|
maybe(list(arg_vector_type_error))::in,
|
|
maybe(list(arg_vector_type_error))::out) is det.
|
|
|
|
typecheck_vars_have_types_in_arg_vector(_, _, _, _, [], [],
|
|
!TypeAssignSet, !Specs, !MaybeArgVectorTypeErrors).
|
|
typecheck_vars_have_types_in_arg_vector(_, _, _, _, [], [_ | _],
|
|
!TypeAssignSet, !Specs, !MaybeArgVectorTypeErrors) :-
|
|
unexpected($pred, "length mismatch").
|
|
typecheck_vars_have_types_in_arg_vector(_, _, _, _, [_ | _], [],
|
|
!TypeAssignSet, !Specs, !MaybeArgVectorTypeErrors) :-
|
|
unexpected($pred, "length mismatch").
|
|
typecheck_vars_have_types_in_arg_vector(Info, Context, ArgVectorKind, ArgNum,
|
|
[Var | Vars], [Type | Types], !TypeAssignSet, !Specs,
|
|
!MaybeArgVectorTypeErrors) :-
|
|
typecheck_var_has_type_in_arg_vector(Info, Context, ArgVectorKind, ArgNum,
|
|
Var, Type, !TypeAssignSet, !Specs, !MaybeArgVectorTypeErrors),
|
|
typecheck_vars_have_types_in_arg_vector(Info, Context,
|
|
ArgVectorKind, ArgNum + 1, Vars, Types, !TypeAssignSet, !Specs,
|
|
!MaybeArgVectorTypeErrors).
|
|
|
|
:- pred typecheck_var_has_type_in_arg_vector(typecheck_info::in,
|
|
prog_context::in, arg_vector_kind::in, int::in,
|
|
prog_var::in, mer_type::in, type_assign_set::in, type_assign_set::out,
|
|
list(error_spec)::in, list(error_spec)::out,
|
|
maybe(list(arg_vector_type_error))::in,
|
|
maybe(list(arg_vector_type_error))::out) is det.
|
|
|
|
typecheck_var_has_type_in_arg_vector(Info, Context, ArgVectorKind, ArgNum,
|
|
Var, Type, TypeAssignSet0, TypeAssignSet, !Specs,
|
|
!MaybeArgVectorTypeErrors) :-
|
|
typecheck_var_has_type_2(TypeAssignSet0, Var, Type, [], TypeAssignSet1),
|
|
( if
|
|
TypeAssignSet1 = [],
|
|
TypeAssignSet0 = [_ | _]
|
|
then
|
|
TypeAssignSet = TypeAssignSet0,
|
|
GoalContext =
|
|
type_error_in_var_vector(var_vector_args(ArgVectorKind), ArgNum),
|
|
SpecAndMaybeActualExpected = report_error_var(Info,
|
|
GoalContext, Context, Var, Type, TypeAssignSet0),
|
|
SpecAndMaybeActualExpected =
|
|
spec_and_maybe_actual_expected(Spec, MaybeActualExpected),
|
|
!:Specs = [Spec | !.Specs],
|
|
(
|
|
!.MaybeArgVectorTypeErrors = no
|
|
;
|
|
!.MaybeArgVectorTypeErrors = yes(ArgVectorTypeErrors0),
|
|
(
|
|
MaybeActualExpected = no,
|
|
!:MaybeArgVectorTypeErrors = no
|
|
;
|
|
MaybeActualExpected = yes(ActualExpected),
|
|
ArgVectorTypeError = arg_vector_type_error(ArgNum, Var,
|
|
ActualExpected),
|
|
ArgVectorTypeErrors =
|
|
[ArgVectorTypeError | ArgVectorTypeErrors0],
|
|
!:MaybeArgVectorTypeErrors = yes(ArgVectorTypeErrors)
|
|
)
|
|
)
|
|
else
|
|
TypeAssignSet = TypeAssignSet1
|
|
).
|
|
|
|
:- pred typecheck_var_has_stm_atomic_type(prog_context::in, prog_var::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_var_has_stm_atomic_type(Context, Var, !TypeAssignSet, !Info) :-
|
|
typecheck_var_has_type(type_error_in_atomic_inner, Context,
|
|
Var, stm_atomic_type, !TypeAssignSet, !Info).
|
|
|
|
:- pred typecheck_var_has_type(type_error_goal_context::in, prog_context::in,
|
|
prog_var::in, mer_type::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_var_has_type(GoalContext, Context, Var, Type,
|
|
TypeAssignSet0, TypeAssignSet, !Info) :-
|
|
typecheck_var_has_type_2(TypeAssignSet0, Var, Type, [], TypeAssignSet1),
|
|
( if
|
|
TypeAssignSet1 = [],
|
|
TypeAssignSet0 = [_ | _]
|
|
then
|
|
TypeAssignSet = TypeAssignSet0,
|
|
SpecAndMaybeActualExpected = report_error_var(!.Info,
|
|
GoalContext, Context, Var, Type, TypeAssignSet0),
|
|
SpecAndMaybeActualExpected = spec_and_maybe_actual_expected(Spec, _),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
else
|
|
TypeAssignSet = TypeAssignSet1
|
|
).
|
|
|
|
:- pred typecheck_var_has_type_2(type_assign_set::in, prog_var::in,
|
|
mer_type::in, type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
typecheck_var_has_type_2([], _, _, !TypeAssignSet).
|
|
typecheck_var_has_type_2([TypeAssign0 | TypeAssigns0], Var, Type,
|
|
!TypeAssignSet) :-
|
|
type_assign_var_has_type(TypeAssign0, Var, Type, !TypeAssignSet),
|
|
typecheck_var_has_type_2(TypeAssigns0, Var, Type, !TypeAssignSet).
|
|
|
|
:- pred type_assign_var_has_type(type_assign::in, prog_var::in, mer_type::in,
|
|
type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
type_assign_var_has_type(TypeAssign0, Var, Type, !TypeAssignSet) :-
|
|
type_assign_get_var_types(TypeAssign0, VarTypes0),
|
|
search_insert_var_type(Var, Type, MaybeOldVarType, VarTypes0, VarTypes),
|
|
(
|
|
MaybeOldVarType = yes(OldVarType),
|
|
( if
|
|
type_assign_unify_type(OldVarType, Type, TypeAssign0, TypeAssign1)
|
|
then
|
|
!:TypeAssignSet = [TypeAssign1 | !.TypeAssignSet]
|
|
else
|
|
!:TypeAssignSet = !.TypeAssignSet
|
|
)
|
|
;
|
|
MaybeOldVarType = no,
|
|
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
|
|
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Type check a unification.
|
|
% Get the type assignment set from the type info, and then just iterate
|
|
% over all the possible type assignments.
|
|
%
|
|
:- pred typecheck_unification(unify_context::in, prog_context::in, goal_id::in,
|
|
prog_var::in, unify_rhs::in, unify_rhs::out,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_unification(UnifyContext, Context, GoalId, X, RHS0, RHS,
|
|
!TypeAssignSet, !Info) :-
|
|
(
|
|
RHS0 = rhs_var(Y),
|
|
typecheck_unify_var_var(UnifyContext, Context, X, Y,
|
|
!TypeAssignSet, !Info),
|
|
RHS = RHS0
|
|
;
|
|
RHS0 = rhs_functor(Functor, _ExistConstraints, Args),
|
|
typecheck_unify_var_functor(UnifyContext, Context, X,
|
|
Functor, Args, GoalId, !TypeAssignSet, !Info),
|
|
perform_context_reduction(Context, !TypeAssignSet, !Info),
|
|
RHS = RHS0
|
|
;
|
|
RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
NonLocals, Vars, Modes, Det, Goal0),
|
|
typecheck_lambda_var_has_type(UnifyContext, Context, Purity,
|
|
PredOrFunc, EvalMethod, X, Vars, !TypeAssignSet, !Info),
|
|
typecheck_goal(Goal0, Goal, Context, !TypeAssignSet, !Info),
|
|
RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
NonLocals, Vars, Modes, Det, Goal)
|
|
).
|
|
|
|
:- pred typecheck_unify_var_var(unify_context::in, prog_context::in,
|
|
prog_var::in, prog_var::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_unify_var_var(UnifyContext, Context, X, Y,
|
|
TypeAssignSet0, TypeAssignSet, !Info) :-
|
|
type_assigns_unify_var_var(TypeAssignSet0, X, Y, [], TypeAssignSet1),
|
|
( if
|
|
TypeAssignSet1 = [],
|
|
TypeAssignSet0 = [_ | _]
|
|
then
|
|
TypeAssignSet = TypeAssignSet0,
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
Spec = report_error_unif_var_var(!.Info, ClauseContext, UnifyContext,
|
|
Context, X, Y, TypeAssignSet0),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
else
|
|
TypeAssignSet = TypeAssignSet1
|
|
).
|
|
|
|
:- pred cons_id_must_be_builtin_type(cons_id::in, mer_type::out, string::out)
|
|
is semidet.
|
|
|
|
cons_id_must_be_builtin_type(ConsId, ConsType, BuiltinTypeName) :-
|
|
(
|
|
ConsId = int_const(_),
|
|
BuiltinTypeName = "int",
|
|
BuiltinType = builtin_type_int(int_type_int)
|
|
;
|
|
ConsId = uint_const(_),
|
|
BuiltinTypeName = "uint",
|
|
BuiltinType = builtin_type_int(int_type_uint)
|
|
;
|
|
ConsId = int8_const(_),
|
|
BuiltinTypeName = "int8",
|
|
BuiltinType = builtin_type_int(int_type_int8)
|
|
;
|
|
ConsId = uint8_const(_),
|
|
BuiltinTypeName = "uint8",
|
|
BuiltinType = builtin_type_int(int_type_uint8)
|
|
;
|
|
ConsId = int16_const(_),
|
|
BuiltinTypeName = "int16",
|
|
BuiltinType = builtin_type_int(int_type_int16)
|
|
;
|
|
ConsId = uint16_const(_),
|
|
BuiltinTypeName = "uint16",
|
|
BuiltinType = builtin_type_int(int_type_uint16)
|
|
;
|
|
ConsId = int32_const(_),
|
|
BuiltinTypeName = "int32",
|
|
BuiltinType = builtin_type_int(int_type_int32)
|
|
;
|
|
ConsId = uint32_const(_),
|
|
BuiltinTypeName = "uint32",
|
|
BuiltinType = builtin_type_int(int_type_uint32)
|
|
;
|
|
ConsId = int64_const(_),
|
|
BuiltinTypeName = "int64",
|
|
BuiltinType = builtin_type_int(int_type_int64)
|
|
;
|
|
ConsId = uint64_const(_),
|
|
BuiltinTypeName = "uint64",
|
|
BuiltinType = builtin_type_int(int_type_uint64)
|
|
;
|
|
ConsId = float_const(_),
|
|
BuiltinTypeName = "float",
|
|
BuiltinType = builtin_type_float
|
|
;
|
|
ConsId = string_const(_),
|
|
BuiltinTypeName = "string",
|
|
BuiltinType = builtin_type_string
|
|
),
|
|
ConsType = builtin_type(BuiltinType).
|
|
|
|
:- pred typecheck_unify_var_functor(unify_context::in, prog_context::in,
|
|
prog_var::in, cons_id::in, list(prog_var)::in, goal_id::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_unify_var_functor(UnifyContext, Context, Var, ConsId, ArgVars,
|
|
GoalId, TypeAssignSet0, TypeAssignSet, !Info) :-
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
( if cons_id_must_be_builtin_type(ConsId, ConsType, BuiltinTypeName) then
|
|
( if ConsType = builtin_type(builtin_type_int(int_type_int)) then
|
|
typecheck_info_add_nosuffix_integer_var(Var, !Info)
|
|
else
|
|
true
|
|
),
|
|
list.foldl(
|
|
type_assign_check_functor_type_builtin(ConsType, Var),
|
|
TypeAssignSet0, [], TypeAssignSet1),
|
|
(
|
|
TypeAssignSet1 = [_ | _],
|
|
TypeAssignSet = TypeAssignSet1
|
|
;
|
|
TypeAssignSet1 = [],
|
|
% If we encountered an error, continue checking with the
|
|
% original type assign set.
|
|
TypeAssignSet = TypeAssignSet0,
|
|
(
|
|
TypeAssignSet0 = []
|
|
% The error did not originate here, so generating an error
|
|
% message here would be misleading.
|
|
;
|
|
TypeAssignSet0 = [_ | _],
|
|
varset.init(ConsTypeVarSet),
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
ConsDefn = cons_type_info(ConsTypeVarSet, [], ConsType, [],
|
|
EmptyConstraints, source_builtin_type(BuiltinTypeName)),
|
|
ConsIdSpec = report_error_functor_type(!.Info,
|
|
UnifyContext, Context, Var, [ConsDefn],
|
|
ConsId, 0, TypeAssignSet0),
|
|
typecheck_info_add_error(ConsIdSpec, !Info)
|
|
)
|
|
)
|
|
else
|
|
% Get the list of possible constructors that match this functor/arity.
|
|
% If there aren't any, report an undefined constructor error.
|
|
list.length(ArgVars, Arity),
|
|
typecheck_info_get_ctor_list(!.Info, ConsId, Arity, GoalId,
|
|
ConsDefns, ConsErrors),
|
|
(
|
|
ConsDefns = [],
|
|
TypeAssignSet = TypeAssignSet0,
|
|
GoalContext = type_error_in_unify(UnifyContext),
|
|
Spec = report_error_undef_cons(ClauseContext, GoalContext,
|
|
Context, ConsErrors, ConsId, Arity),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
;
|
|
(
|
|
ConsDefns = [_]
|
|
;
|
|
ConsDefns = [_, _ | _],
|
|
Sources = list.map(project_cons_type_info_source, ConsDefns),
|
|
Symbol = overloaded_func(ConsId, Sources),
|
|
typecheck_info_add_overloaded_symbol(Symbol, Context, !Info)
|
|
),
|
|
|
|
% Produce the ConsTypeAssignSet, which is essentially the
|
|
% cross-product of the ConsDefns and the TypeAssignSet0.
|
|
get_cons_type_assigns_for_cons_defns(ConsDefns, TypeAssignSet0,
|
|
[], ConsTypeAssignSet),
|
|
( if
|
|
ConsTypeAssignSet = [],
|
|
TypeAssignSet0 = [_ | _]
|
|
then
|
|
% This should never happen, since undefined ctors
|
|
% should be caught by the check just above.
|
|
unexpected($pred, "undefined cons?")
|
|
else
|
|
true
|
|
),
|
|
|
|
% Check that the type of the functor matches the type of the
|
|
% variable.
|
|
typecheck_var_functor_types(Var, ConsTypeAssignSet,
|
|
[], ArgsTypeAssignSet),
|
|
( if
|
|
ArgsTypeAssignSet = [],
|
|
ConsTypeAssignSet = [_ | _]
|
|
then
|
|
ConsIdSpec = report_error_functor_type(!.Info,
|
|
UnifyContext, Context, Var, ConsDefns, ConsId, Arity,
|
|
TypeAssignSet0),
|
|
typecheck_info_add_error(ConsIdSpec, !Info)
|
|
else
|
|
true
|
|
),
|
|
|
|
% Check that the type of the arguments of the functor matches
|
|
% their expected type for this functor.
|
|
typecheck_functor_arg_types(!.Info, ArgVars, ArgsTypeAssignSet,
|
|
[], TypeAssignSet1),
|
|
(
|
|
TypeAssignSet1 = [_ | _],
|
|
TypeAssignSet = TypeAssignSet1
|
|
;
|
|
TypeAssignSet1 = [],
|
|
% If we encountered an error, continue checking with the
|
|
% original type assign set.
|
|
TypeAssignSet = TypeAssignSet0,
|
|
(
|
|
ArgsTypeAssignSet = []
|
|
% The error did not originate here, so generating an error
|
|
% message here would be misleading.
|
|
;
|
|
ArgsTypeAssignSet = [_ | _],
|
|
ArgSpec = report_error_functor_arg_types(!.Info,
|
|
ClauseContext, UnifyContext, Context, Var,
|
|
ConsDefns, ConsId, ArgVars, ArgsTypeAssignSet),
|
|
typecheck_info_add_error(ArgSpec, !Info)
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
%---------------------%
|
|
|
|
:- type cons_type_assign
|
|
---> cons_type_assign(type_assign, mer_type, list(mer_type)).
|
|
|
|
:- type cons_type_assign_set == list(cons_type_assign).
|
|
|
|
% typecheck_unify_var_functor_get_ctors_for_type_assigns(TypeAssignSet,
|
|
% ConsDefns, !ConsTypeAssignSet):
|
|
%
|
|
% Iterate over all the different possible type assignments and
|
|
% constructor definitions.
|
|
% For each type assignment in `TypeAssignSet', and constructor
|
|
% definition in `ConsDefns', produce a pair
|
|
%
|
|
% TypeAssign - cons_type(Type, ArgTypes)
|
|
%
|
|
% where `cons_type(Type, ArgTypes)' records one of the possible types
|
|
% for the constructor in `ConsDefns', and where `TypeAssign' is the type
|
|
% assignment renamed apart from the types of the constructors.
|
|
%
|
|
% This predicate iterates over the type assign sets;
|
|
% typecheck_unify_var_functor_get_ctors iterates over the cons defns.
|
|
%
|
|
:- pred get_cons_type_assigns_for_cons_defns(list(cons_type_info)::in,
|
|
type_assign_set::in,
|
|
cons_type_assign_set::in, cons_type_assign_set::out) is det.
|
|
|
|
get_cons_type_assigns_for_cons_defns([], _, !ConsTypeAssignSet).
|
|
get_cons_type_assigns_for_cons_defns([ConsDefn | ConsDefns], TypeAssigns,
|
|
!ConsTypeAssignSet) :-
|
|
get_cons_type_assigns_for_cons_defn(ConsDefn, TypeAssigns,
|
|
!ConsTypeAssignSet),
|
|
get_cons_type_assigns_for_cons_defns(ConsDefns, TypeAssigns,
|
|
!ConsTypeAssignSet).
|
|
|
|
:- pred get_cons_type_assigns_for_cons_defn(cons_type_info::in,
|
|
type_assign_set::in,
|
|
cons_type_assign_set::in, cons_type_assign_set::out) is det.
|
|
|
|
get_cons_type_assigns_for_cons_defn(_, [], !ConsTypeAssignSet).
|
|
get_cons_type_assigns_for_cons_defn(ConsDefn, [TypeAssign | TypeAssigns],
|
|
!ConsTypeAssignSet) :-
|
|
get_cons_type_assign(ConsDefn, TypeAssign, ConsTypeAssign),
|
|
!:ConsTypeAssignSet = [ConsTypeAssign | !.ConsTypeAssignSet],
|
|
get_cons_type_assigns_for_cons_defn(ConsDefn, TypeAssigns,
|
|
!ConsTypeAssignSet).
|
|
|
|
% Given an cons_type_info, construct a type for the constructor
|
|
% and a list of types of the arguments, suitably renamed apart
|
|
% from the current type_assign's typevarset. Return them in a
|
|
% cons_type_assign with the updated-for-the-renaming type_assign.
|
|
%
|
|
:- pred get_cons_type_assign(cons_type_info::in, type_assign::in,
|
|
cons_type_assign::out) is det.
|
|
|
|
get_cons_type_assign(ConsDefn, TypeAssign0, ConsTypeAssign) :-
|
|
ConsDefn = cons_type_info(ConsTypeVarSet, ConsExistQVars0,
|
|
ConsType0, ArgTypes0, ClassConstraints0, _Source),
|
|
|
|
% Rename apart the type vars in the type of the constructor
|
|
% and the types of its arguments.
|
|
% (Optimize the common case of a non-polymorphic type.)
|
|
( if
|
|
varset.is_empty(ConsTypeVarSet)
|
|
then
|
|
ConsType = ConsType0,
|
|
ArgTypes = ArgTypes0,
|
|
TypeAssign2 = TypeAssign0,
|
|
ConstraintsToAdd = ClassConstraints0
|
|
else if
|
|
type_assign_rename_apart(TypeAssign0, ConsTypeVarSet,
|
|
[ConsType0 | ArgTypes0], TypeAssign1, [ConsType1 | ArgTypes1],
|
|
Renaming)
|
|
then
|
|
apply_variable_renaming_to_tvar_list(Renaming,
|
|
ConsExistQVars0, ConsExistQVars),
|
|
apply_variable_renaming_to_constraints(Renaming,
|
|
ClassConstraints0, ConstraintsToAdd),
|
|
type_assign_get_external_type_params(TypeAssign1, HeadTypeParams0),
|
|
HeadTypeParams = ConsExistQVars ++ HeadTypeParams0,
|
|
type_assign_set_external_type_params(HeadTypeParams,
|
|
TypeAssign1, TypeAssign2),
|
|
|
|
ConsType = ConsType1,
|
|
ArgTypes = ArgTypes1
|
|
else
|
|
unexpected($pred, "type_assign_rename_apart failed")
|
|
),
|
|
|
|
% Add the constraints for this functor to the current constraint set.
|
|
% Note that there can still be (ground) constraints even if the varset
|
|
% is empty.
|
|
%
|
|
% For functors which are data constructors, the fact that we don't take
|
|
% the dual corresponds to assuming that they will be used as deconstructors
|
|
% rather than as constructors.
|
|
|
|
type_assign_get_typeclass_constraints(TypeAssign2, OldConstraints),
|
|
merge_hlds_constraints(ConstraintsToAdd, OldConstraints, ClassConstraints),
|
|
type_assign_set_typeclass_constraints(ClassConstraints,
|
|
TypeAssign2, TypeAssign),
|
|
ConsTypeAssign = cons_type_assign(TypeAssign, ConsType, ArgTypes).
|
|
|
|
%---------------------%
|
|
|
|
% typecheck_functor_arg_types(ConsTypeAssignSet, Var, Args, ...):
|
|
%
|
|
% For each possible cons type assignment in `ConsTypeAssignSet',
|
|
% for each possible constructor argument types,
|
|
% check that the types of `Args' matches these types.
|
|
%
|
|
:- pred typecheck_functor_arg_types(typecheck_info::in, list(prog_var)::in,
|
|
args_type_assign_set::in,
|
|
type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
typecheck_functor_arg_types(_, _, [], !TypeAssignSet).
|
|
typecheck_functor_arg_types(Info, ArgVars, [ConsTypeAssign | ConsTypeAssigns],
|
|
!TypeAssignSet) :-
|
|
ConsTypeAssign = args_type_assign(TypeAssign, ArgTypes, _),
|
|
type_assign_vars_have_types(Info, TypeAssign, ArgVars, ArgTypes,
|
|
!TypeAssignSet),
|
|
typecheck_functor_arg_types(Info, ArgVars, ConsTypeAssigns,
|
|
!TypeAssignSet).
|
|
|
|
% type_assign_vars_have_types(Info, TypeAssign, ArgVars, Types,
|
|
% TypeAssignSet0, TypeAssignSet):
|
|
% Let TAs = { TA | TA is an extension of TypeAssign for which
|
|
% the types of the ArgVars unify with their respective Types },
|
|
% list.append(TAs, TypeAssignSet0, TypeAssignSet).
|
|
%
|
|
:- pred type_assign_vars_have_types(typecheck_info::in, type_assign::in,
|
|
list(prog_var)::in, list(mer_type)::in,
|
|
type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
type_assign_vars_have_types(_, TypeAssign, [], [],
|
|
TypeAssignSet, [TypeAssign | TypeAssignSet]).
|
|
type_assign_vars_have_types(_, _, [], [_ | _], _, _) :-
|
|
unexpected($pred, "length mismatch").
|
|
type_assign_vars_have_types(_, _, [_ | _], [], _, _) :-
|
|
unexpected($pred, "length mismatch").
|
|
type_assign_vars_have_types(Info, TypeAssign0,
|
|
[ArgVar | ArgVars], [Type | Types], TypeAssignSet0, TypeAssignSet) :-
|
|
type_assign_var_has_type(TypeAssign0, ArgVar, Type, [], TypeAssignSet1),
|
|
type_assigns_vars_have_types(Info, TypeAssignSet1,
|
|
ArgVars, Types, TypeAssignSet0, TypeAssignSet).
|
|
|
|
% type_assigns_vars_have_types(Info, TypeAssigns, ArgVars, Types,
|
|
% TypeAssignSet0, TypeAssignSet):
|
|
% Let TAs = { TA | TA is an extension of a member of TypeAssigns for which
|
|
% the types of the ArgVars unify with their respective Types },
|
|
% list.append(TAs, TypeAssignSet0, TypeAssignSet).
|
|
%
|
|
:- pred type_assigns_vars_have_types(typecheck_info::in,
|
|
type_assign_set::in, list(prog_var)::in, list(mer_type)::in,
|
|
type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
type_assigns_vars_have_types(_, [], _, _, !TypeAssignSet).
|
|
type_assigns_vars_have_types(Info, [TypeAssign | TypeAssigns],
|
|
ArgVars, Types, !TypeAssignSet) :-
|
|
type_assign_vars_have_types(Info, TypeAssign, ArgVars, Types,
|
|
!TypeAssignSet),
|
|
type_assigns_vars_have_types(Info, TypeAssigns, ArgVars, Types,
|
|
!TypeAssignSet).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Iterate type_assign_unify_var_var over all the given type assignments.
|
|
%
|
|
:- pred type_assigns_unify_var_var(type_assign_set::in,
|
|
prog_var::in, prog_var::in,
|
|
type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
type_assigns_unify_var_var([], _, _, !TypeAssignSet).
|
|
type_assigns_unify_var_var([TypeAssign | TypeAssigns], X, Y, !TypeAssignSet) :-
|
|
type_assign_unify_var_var(TypeAssign, X, Y, !TypeAssignSet),
|
|
type_assigns_unify_var_var(TypeAssigns, X, Y, !TypeAssignSet).
|
|
|
|
% Typecheck the unification of two variables,
|
|
% and update the type assignment.
|
|
% TypeAssign0 is the type assignment we are updating,
|
|
% TypeAssignSet0 is an accumulator for the list of possible
|
|
% type assignments so far, and TypeAssignSet is TypeAssignSet plus
|
|
% any type assignment(s) resulting from TypeAssign0 and this unification.
|
|
%
|
|
:- pred type_assign_unify_var_var(type_assign::in, prog_var::in, prog_var::in,
|
|
type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
type_assign_unify_var_var(TypeAssign0, X, Y, !TypeAssignSet) :-
|
|
type_assign_get_var_types(TypeAssign0, VarTypes0),
|
|
( if search_var_type(VarTypes0, X, TypeX) then
|
|
search_insert_var_type(Y, TypeX, MaybeTypeY, VarTypes0, VarTypes),
|
|
(
|
|
MaybeTypeY = yes(TypeY),
|
|
% Both X and Y already have types - just unify their types.
|
|
( if
|
|
type_assign_unify_type(TypeX, TypeY, TypeAssign0, TypeAssign3)
|
|
then
|
|
!:TypeAssignSet = [TypeAssign3 | !.TypeAssignSet]
|
|
else
|
|
!:TypeAssignSet = !.TypeAssignSet
|
|
)
|
|
;
|
|
MaybeTypeY = no,
|
|
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
|
|
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
|
|
)
|
|
else
|
|
( if search_var_type(VarTypes0, Y, TypeY) then
|
|
% X is a fresh variable which hasn't been assigned a type yet.
|
|
add_var_type(X, TypeY, VarTypes0, VarTypes),
|
|
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
|
|
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
|
|
else
|
|
% Both X and Y are fresh variables - introduce a fresh type
|
|
% variable with kind `star' to represent their type.
|
|
type_assign_get_typevarset(TypeAssign0, TypeVarSet0),
|
|
varset.new_var(TypeVar, TypeVarSet0, TypeVarSet),
|
|
type_assign_set_typevarset(TypeVarSet, TypeAssign0, TypeAssign1),
|
|
Type = type_variable(TypeVar, kind_star),
|
|
add_var_type(X, Type, VarTypes0, VarTypes1),
|
|
( if X = Y then
|
|
VarTypes = VarTypes1
|
|
else
|
|
add_var_type(Y, Type, VarTypes1, VarTypes)
|
|
),
|
|
type_assign_set_var_types(VarTypes, TypeAssign1, TypeAssign),
|
|
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
|
|
)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% typecheck_var_functor_type(Var, ConsTypeAssignSet, !ArgsTypeAssignSet):
|
|
%
|
|
% For each possible cons type assignment in `ConsTypeAssignSet',
|
|
% for each possible constructor type,
|
|
% check that the type of `Var' matches this type.
|
|
% If it does, add the type binding to !ArgsTypeAssignSet.
|
|
%
|
|
:- pred typecheck_var_functor_types(prog_var::in, cons_type_assign_set::in,
|
|
args_type_assign_set::in, args_type_assign_set::out) is det.
|
|
|
|
typecheck_var_functor_types(_, [], !ArgsTypeAssignSet).
|
|
typecheck_var_functor_types(Var, [ConsTypeAssign | ConsTypeAssigns],
|
|
!ArgsTypeAssignSet) :-
|
|
typecheck_var_functor_type(Var, ConsTypeAssign, !ArgsTypeAssignSet),
|
|
typecheck_var_functor_types(Var, ConsTypeAssigns, !ArgsTypeAssignSet).
|
|
|
|
:- pred typecheck_var_functor_type(prog_var::in, cons_type_assign::in,
|
|
args_type_assign_set::in, args_type_assign_set::out) is det.
|
|
|
|
typecheck_var_functor_type(Var, ConsTypeAssign0, !ArgsTypeAssignSet) :-
|
|
ConsTypeAssign0 = cons_type_assign(TypeAssign0, ConsType, ConsArgTypes),
|
|
|
|
% Unify the type of Var with the type of the constructor.
|
|
type_assign_get_var_types(TypeAssign0, VarTypes0),
|
|
search_insert_var_type(Var, ConsType, MaybeTypeVar, VarTypes0, VarTypes),
|
|
(
|
|
MaybeTypeVar = yes(TypeVar),
|
|
% VarTypes wasn't updated, so don't need to update its containing
|
|
% type assign either.
|
|
( if
|
|
type_assign_unify_type(ConsType, TypeVar, TypeAssign0, TypeAssign)
|
|
then
|
|
% The constraints are empty here because none are added by
|
|
% unification with a functor.
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
ArgsTypeAssign =
|
|
args_type_assign(TypeAssign, ConsArgTypes, EmptyConstraints),
|
|
!:ArgsTypeAssignSet = [ArgsTypeAssign | !.ArgsTypeAssignSet]
|
|
else
|
|
true
|
|
)
|
|
;
|
|
MaybeTypeVar = no,
|
|
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
|
|
% The constraints are empty here because none are added by
|
|
% unification with a functor.
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
ArgsTypeAssign =
|
|
args_type_assign(TypeAssign, ConsArgTypes, EmptyConstraints),
|
|
!:ArgsTypeAssignSet = [ArgsTypeAssign | !.ArgsTypeAssignSet]
|
|
).
|
|
|
|
:- pred type_assign_check_functor_type_builtin(mer_type::in,
|
|
prog_var::in, type_assign::in,
|
|
type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
type_assign_check_functor_type_builtin(ConsType, Y, TypeAssign0,
|
|
!TypeAssignSet) :-
|
|
% Unify the type of Var with the type of the constructor.
|
|
type_assign_get_var_types(TypeAssign0, VarTypes0),
|
|
search_insert_var_type(Y, ConsType, MaybeTypeY, VarTypes0, VarTypes),
|
|
(
|
|
MaybeTypeY = yes(TypeY),
|
|
( if
|
|
type_assign_unify_type(ConsType, TypeY, TypeAssign0, TypeAssign)
|
|
then
|
|
% The constraints are empty here because none are added by
|
|
% unification with a functor.
|
|
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
|
|
else
|
|
true
|
|
)
|
|
;
|
|
MaybeTypeY = no,
|
|
% The constraints are empty here because none are added by
|
|
% unification with a functor.
|
|
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
|
|
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% typecheck_lambda_var_has_type(..., Var, ArgVars, !Info)
|
|
%
|
|
% Check that `Var' has type `pred(T1, T2, ...)' where T1, T2, ...
|
|
% are the types of the `ArgVars'.
|
|
%
|
|
:- pred typecheck_lambda_var_has_type(unify_context::in, prog_context::in,
|
|
purity::in, pred_or_func::in, lambda_eval_method::in,
|
|
prog_var::in, list(prog_var)::in,
|
|
type_assign_set::in, type_assign_set::out,
|
|
typecheck_info::in, typecheck_info::out) is det.
|
|
|
|
typecheck_lambda_var_has_type(UnifyContext, Context, Purity, PredOrFunc,
|
|
EvalMethod, Var, ArgVars, TypeAssignSet0, TypeAssignSet, !Info) :-
|
|
typecheck_lambda_var_has_type_2(TypeAssignSet0, Purity, PredOrFunc,
|
|
EvalMethod, Var, ArgVars, [], TypeAssignSet1),
|
|
( if
|
|
TypeAssignSet1 = [],
|
|
TypeAssignSet0 = [_ | _]
|
|
then
|
|
TypeAssignSet = TypeAssignSet0,
|
|
typecheck_info_get_error_clause_context(!.Info, ClauseContext),
|
|
Spec = report_error_lambda_var(!.Info, ClauseContext, UnifyContext,
|
|
Context, PredOrFunc, EvalMethod, Var, ArgVars, TypeAssignSet0),
|
|
typecheck_info_add_error(Spec, !Info)
|
|
else
|
|
TypeAssignSet = TypeAssignSet1
|
|
).
|
|
|
|
:- pred typecheck_lambda_var_has_type_2(type_assign_set::in, purity::in,
|
|
pred_or_func::in, lambda_eval_method::in, prog_var::in,
|
|
list(prog_var)::in, type_assign_set::in, type_assign_set::out) is det.
|
|
|
|
typecheck_lambda_var_has_type_2([], _, _, _, _, _, !TypeAssignSet).
|
|
typecheck_lambda_var_has_type_2([TypeAssign0 | TypeAssignSet0], Purity,
|
|
PredOrFunc, EvalMethod, Var, ArgVars, !TypeAssignSet) :-
|
|
type_assign_get_types_of_vars(ArgVars, ArgVarTypes,
|
|
TypeAssign0, TypeAssign1),
|
|
construct_higher_order_type(Purity, PredOrFunc, EvalMethod,
|
|
ArgVarTypes, LambdaType),
|
|
type_assign_var_has_type(TypeAssign1, Var, LambdaType, !TypeAssignSet),
|
|
typecheck_lambda_var_has_type_2(TypeAssignSet0,
|
|
Purity, PredOrFunc, EvalMethod, Var, ArgVars, !TypeAssignSet).
|
|
|
|
:- pred type_assign_get_types_of_vars(list(prog_var)::in, list(mer_type)::out,
|
|
type_assign::in, type_assign::out) is det.
|
|
|
|
type_assign_get_types_of_vars([], [], !TypeAssign).
|
|
type_assign_get_types_of_vars([Var | Vars], [Type | Types], !TypeAssign) :-
|
|
% Check whether the variable already has a type.
|
|
type_assign_get_var_types(!.TypeAssign, VarTypes0),
|
|
( if search_var_type(VarTypes0, Var, VarType) then
|
|
% If so, use that type.
|
|
Type = VarType
|
|
else
|
|
% Otherwise, introduce a fresh type variable with kind `star' to use
|
|
% as the type of that variable.
|
|
type_assign_get_typevarset(!.TypeAssign, TypeVarSet0),
|
|
varset.new_var(TypeVar, TypeVarSet0, TypeVarSet),
|
|
type_assign_set_typevarset(TypeVarSet, !TypeAssign),
|
|
Type = type_variable(TypeVar, kind_star),
|
|
add_var_type(Var, Type, VarTypes0, VarTypes1),
|
|
type_assign_set_var_types(VarTypes1, !TypeAssign)
|
|
),
|
|
% Recursively process the rest of the variables.
|
|
type_assign_get_types_of_vars(Vars, Types, !TypeAssign).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Unify (with occurs check) two types in a type assignment
|
|
% and update the type bindings.
|
|
%
|
|
:- pred type_assign_unify_type(mer_type::in, mer_type::in,
|
|
type_assign::in, type_assign::out) is semidet.
|
|
|
|
type_assign_unify_type(X, Y, TypeAssign0, TypeAssign) :-
|
|
type_assign_get_external_type_params(TypeAssign0, HeadTypeParams),
|
|
type_assign_get_type_bindings(TypeAssign0, TypeBindings0),
|
|
type_unify(X, Y, HeadTypeParams, TypeBindings0, TypeBindings),
|
|
type_assign_set_type_bindings(TypeBindings, TypeAssign0, TypeAssign).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% builtin_atomic_type(Const, TypeName):
|
|
%
|
|
% If Const is *or can be* a constant of a builtin atomic type,
|
|
% set TypeName to the name of that type, otherwise fail.
|
|
%
|
|
:- pred builtin_atomic_type(cons_id::in, string::out) is semidet.
|
|
|
|
builtin_atomic_type(int_const(_), "int").
|
|
builtin_atomic_type(uint_const(_), "uint").
|
|
builtin_atomic_type(int8_const(_), "int8").
|
|
builtin_atomic_type(uint8_const(_), "uint8").
|
|
builtin_atomic_type(int16_const(_), "int16").
|
|
builtin_atomic_type(uint16_const(_), "uint16").
|
|
builtin_atomic_type(int32_const(_), "int32").
|
|
builtin_atomic_type(uint32_const(_), "uint32").
|
|
builtin_atomic_type(int64_const(_), "int64").
|
|
builtin_atomic_type(uint64_const(_), "uint64").
|
|
builtin_atomic_type(float_const(_), "float").
|
|
builtin_atomic_type(char_const(_), "character").
|
|
builtin_atomic_type(string_const(_), "string").
|
|
builtin_atomic_type(cons(unqualified(String), 0, _), "character") :-
|
|
% We are before post-typecheck, so character constants have not yet been
|
|
% converted to char_consts.
|
|
%
|
|
% XXX The parser should have a separate term.functor representation
|
|
% for character constants, which should be converted to char_consts
|
|
% during the term to item translation.
|
|
string.char_to_string(_, String).
|
|
builtin_atomic_type(impl_defined_const(Name), Type) :-
|
|
(
|
|
( Name = "file"
|
|
; Name = "module"
|
|
; Name = "pred"
|
|
; Name = "grade"
|
|
),
|
|
Type = "string"
|
|
;
|
|
Name = "line",
|
|
Type = "int"
|
|
).
|
|
|
|
% builtin_pred_type(Info, ConsId, Arity, GoalId, PredConsInfoList):
|
|
%
|
|
% If ConsId/Arity is a constant of a pred type, instantiates
|
|
% the output parameters, otherwise fails.
|
|
%
|
|
% Instantiates PredConsInfoList to the set of cons_type_info structures
|
|
% for each predicate with name `ConsId' and arity greater than or equal to
|
|
% Arity. GoalId is used to identify any constraints introduced.
|
|
%
|
|
% For example, functor `map.search/1' has type `pred(K, V)'
|
|
% (hence PredTypeParams = [K, V]) and argument types [map(K, V)].
|
|
%
|
|
:- pred builtin_pred_type(typecheck_info::in, cons_id::in, int::in,
|
|
goal_id::in, list(cons_type_info)::out) is semidet.
|
|
|
|
builtin_pred_type(Info, ConsId, Arity, GoalId, ConsTypeInfos) :-
|
|
ConsId = cons(SymName, _, _),
|
|
typecheck_info_get_pred_table(Info, PredicateTable),
|
|
typecheck_info_get_calls_are_fully_qualified(Info, IsFullyQualified),
|
|
predicate_table_lookup_sym(PredicateTable, IsFullyQualified, SymName,
|
|
PredIds),
|
|
(
|
|
PredIds = [_ | _],
|
|
predicate_table_get_preds(PredicateTable, Preds),
|
|
accumulate_cons_type_infos_for_pred_ids(Info, Preds, GoalId,
|
|
PredIds, Arity, [], ConsTypeInfos)
|
|
;
|
|
PredIds = [],
|
|
ConsTypeInfos = []
|
|
).
|
|
|
|
:- pred accumulate_cons_type_infos_for_pred_ids(typecheck_info::in,
|
|
pred_table::in, goal_id::in, list(pred_id)::in, int::in,
|
|
list(cons_type_info)::in, list(cons_type_info)::out) is det.
|
|
|
|
accumulate_cons_type_infos_for_pred_ids(_, _, _, [], _, !ConsTypeInfos).
|
|
accumulate_cons_type_infos_for_pred_ids(Info, PredTable, GoalId,
|
|
[PredId | PredIds], Arity, !ConsTypeInfos) :-
|
|
accumulate_cons_type_infos_for_pred_id(Info, PredTable, GoalId,
|
|
PredId, Arity, !ConsTypeInfos),
|
|
accumulate_cons_type_infos_for_pred_ids(Info, PredTable, GoalId,
|
|
PredIds, Arity, !ConsTypeInfos).
|
|
|
|
:- pred accumulate_cons_type_infos_for_pred_id(typecheck_info::in,
|
|
pred_table::in, goal_id::in, pred_id::in, int::in,
|
|
list(cons_type_info)::in, list(cons_type_info)::out) is det.
|
|
|
|
accumulate_cons_type_infos_for_pred_id(Info, PredTable, GoalId,
|
|
PredId, FuncArity, !ConsTypeInfos) :-
|
|
typecheck_info_get_module_info(Info, ModuleInfo),
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
map.lookup(PredTable, PredId, PredInfo),
|
|
PredArity = pred_info_orig_arity(PredInfo),
|
|
IsPredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
pred_info_get_class_context(PredInfo, PredClassContext),
|
|
pred_info_get_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
|
|
CompleteArgTypes),
|
|
pred_info_get_purity(PredInfo, Purity),
|
|
( if
|
|
IsPredOrFunc = pf_predicate,
|
|
PredArity >= FuncArity,
|
|
% We don't support first-class polymorphism, so you can't take the
|
|
% address of an existentially quantified predicate.
|
|
PredExistQVars = []
|
|
then
|
|
list.det_split_list(FuncArity, CompleteArgTypes,
|
|
ArgTypes, PredTypeParams),
|
|
construct_higher_order_pred_type(Purity, lambda_normal,
|
|
PredTypeParams, PredType),
|
|
make_body_hlds_constraints(ClassTable, PredTypeVarSet,
|
|
GoalId, PredClassContext, PredConstraints),
|
|
ConsTypeInfo = cons_type_info(PredTypeVarSet, PredExistQVars,
|
|
PredType, ArgTypes, PredConstraints, source_pred(PredId)),
|
|
!:ConsTypeInfos = [ConsTypeInfo | !.ConsTypeInfos]
|
|
else if
|
|
IsPredOrFunc = pf_function,
|
|
PredAsFuncArity = PredArity - 1,
|
|
PredAsFuncArity >= FuncArity,
|
|
% We don't support first-class polymorphism, so you can't take
|
|
% the address of an existentially quantified function. You can however
|
|
% call such a function, so long as you pass *all* the parameters.
|
|
( PredExistQVars = []
|
|
; PredAsFuncArity = FuncArity
|
|
)
|
|
then
|
|
list.det_split_list(FuncArity, CompleteArgTypes,
|
|
FuncArgTypes, FuncTypeParams),
|
|
pred_args_to_func_args(FuncTypeParams,
|
|
FuncArgTypeParams, FuncReturnTypeParam),
|
|
(
|
|
FuncArgTypeParams = [],
|
|
FuncType = FuncReturnTypeParam
|
|
;
|
|
FuncArgTypeParams = [_ | _],
|
|
construct_higher_order_func_type(Purity, lambda_normal,
|
|
FuncArgTypeParams, FuncReturnTypeParam, FuncType)
|
|
),
|
|
make_body_hlds_constraints(ClassTable, PredTypeVarSet,
|
|
GoalId, PredClassContext, PredConstraints),
|
|
ConsTypeInfo = cons_type_info(PredTypeVarSet,
|
|
PredExistQVars, FuncType, FuncArgTypes, PredConstraints,
|
|
source_pred(PredId)),
|
|
!:ConsTypeInfos = [ConsTypeInfo | !.ConsTypeInfos]
|
|
else
|
|
true
|
|
).
|
|
|
|
% builtin_apply_type(Info, ConsId, Arity, ConsTypeInfos):
|
|
%
|
|
% Succeed if ConsId is the builtin apply/N or ''/N (N>=2),
|
|
% which is used to invoke higher-order functions.
|
|
% If so, bind ConsTypeInfos to a singleton list containing
|
|
% the appropriate type for apply/N of the specified Arity.
|
|
%
|
|
:- pred builtin_apply_type(typecheck_info::in, cons_id::in, int::in,
|
|
list(cons_type_info)::out) is semidet.
|
|
|
|
builtin_apply_type(_Info, ConsId, Arity, ConsTypeInfos) :-
|
|
ConsId = cons(unqualified(ApplyName), _, _),
|
|
% XXX FIXME handle impure apply/N more elegantly (e.g. nicer syntax)
|
|
(
|
|
ApplyName = "apply",
|
|
ApplyNameToUse = ApplyName,
|
|
Purity = purity_pure
|
|
;
|
|
ApplyName = "",
|
|
ApplyNameToUse = "apply",
|
|
Purity = purity_pure
|
|
;
|
|
ApplyName = "impure_apply",
|
|
ApplyNameToUse = ApplyName,
|
|
Purity = purity_impure
|
|
;
|
|
ApplyName = "semipure_apply",
|
|
ApplyNameToUse = ApplyName,
|
|
Purity = purity_semipure
|
|
),
|
|
Arity >= 1,
|
|
Arity1 = Arity - 1,
|
|
higher_order_func_type(Purity, Arity1, lambda_normal, TypeVarSet, FuncType,
|
|
ArgTypes, RetType),
|
|
ExistQVars = [],
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
ConsTypeInfos = [cons_type_info(TypeVarSet, ExistQVars, RetType,
|
|
[FuncType | ArgTypes], EmptyConstraints,
|
|
source_apply(ApplyNameToUse))].
|
|
|
|
% builtin_field_access_function_type(Info, GoalId, ConsId,
|
|
% Arity, ConsTypeInfos):
|
|
%
|
|
% Succeed if ConsId is the name of one the automatically
|
|
% generated field access functions (fieldname, '<fieldname> :=').
|
|
%
|
|
:- pred builtin_field_access_function_type(typecheck_info::in, goal_id::in,
|
|
cons_id::in, arity::in, list(maybe_cons_type_info)::out) is semidet.
|
|
|
|
builtin_field_access_function_type(Info, GoalId, ConsId, Arity,
|
|
MaybeConsTypeInfos) :-
|
|
% Taking the address of automatically generated field access functions
|
|
% is not allowed, so currying does have to be considered here.
|
|
ConsId = cons(Name, Arity, _),
|
|
typecheck_info_get_module_info(Info, ModuleInfo),
|
|
is_field_access_function_name(ModuleInfo, Name, Arity, AccessType,
|
|
FieldName),
|
|
|
|
module_info_get_ctor_field_table(ModuleInfo, CtorFieldTable),
|
|
map.search(CtorFieldTable, FieldName, FieldDefns),
|
|
|
|
list.filter_map(
|
|
make_field_access_function_cons_type_info(Info, GoalId, Name,
|
|
Arity, AccessType, FieldName),
|
|
FieldDefns, MaybeConsTypeInfos).
|
|
|
|
:- pred make_field_access_function_cons_type_info(typecheck_info::in,
|
|
goal_id::in, sym_name::in, arity::in, field_access_type::in,
|
|
sym_name::in, hlds_ctor_field_defn::in,
|
|
maybe_cons_type_info::out) is semidet.
|
|
|
|
make_field_access_function_cons_type_info(Info, GoalId, FuncName, Arity,
|
|
AccessType, FieldName, FieldDefn, ConsTypeInfo) :-
|
|
get_field_access_constructor(Info, GoalId, FuncName, Arity,
|
|
AccessType, FieldDefn, OrigExistTVars,
|
|
MaybeFunctorConsTypeInfo),
|
|
(
|
|
MaybeFunctorConsTypeInfo = ok(FunctorConsTypeInfo),
|
|
typecheck_info_get_module_info(Info, ModuleInfo),
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
convert_field_access_cons_type_info(ClassTable, AccessType,
|
|
FieldName, FieldDefn, FunctorConsTypeInfo,
|
|
OrigExistTVars, ConsTypeInfo)
|
|
;
|
|
MaybeFunctorConsTypeInfo = error(_),
|
|
ConsTypeInfo = MaybeFunctorConsTypeInfo
|
|
).
|
|
|
|
:- pred get_field_access_constructor(typecheck_info::in, goal_id::in,
|
|
sym_name::in, arity::in, field_access_type::in, hlds_ctor_field_defn::in,
|
|
existq_tvars::out, maybe_cons_type_info::out) is semidet.
|
|
|
|
get_field_access_constructor(Info, GoalId, FuncName, Arity, AccessType,
|
|
FieldDefn, OrigExistTVars, FunctorConsTypeInfo) :-
|
|
FieldDefn = hlds_ctor_field_defn(_, _, TypeCtor, ConsId, _),
|
|
TypeCtor = type_ctor(qualified(TypeModule, _), _),
|
|
|
|
% If the user has supplied a declaration, we use that instead
|
|
% of the automatically generated version, unless we are typechecking
|
|
% the clause introduced for the user-supplied declaration.
|
|
% The user-declared version will be picked up by builtin_pred_type.
|
|
|
|
typecheck_info_get_module_info(Info, ModuleInfo),
|
|
module_info_get_predicate_table(ModuleInfo, PredTable),
|
|
UnqualFuncName = unqualify_name(FuncName),
|
|
typecheck_info_get_is_field_access_function(Info, IsFieldAccessFunc),
|
|
(
|
|
IsFieldAccessFunc = no,
|
|
predicate_table_lookup_func_m_n_a(PredTable, is_fully_qualified,
|
|
TypeModule, UnqualFuncName, Arity, PredIds),
|
|
PredIds = []
|
|
;
|
|
IsFieldAccessFunc = yes(_)
|
|
),
|
|
module_info_get_cons_table(ModuleInfo, ConsTable),
|
|
lookup_cons_table_of_type_ctor(ConsTable, TypeCtor, ConsId, ConsDefn),
|
|
MaybeExistConstraints = ConsDefn ^ cons_maybe_exist,
|
|
(
|
|
MaybeExistConstraints = no_exist_constraints,
|
|
OrigExistTVars = []
|
|
;
|
|
MaybeExistConstraints = exist_constraints(ExistConstraints),
|
|
ExistConstraints = cons_exist_constraints(OrigExistTVars, _, _, _)
|
|
),
|
|
(
|
|
AccessType = get,
|
|
ConsAction = do_not_flip_constraints,
|
|
convert_cons_defn(Info, GoalId, ConsAction, ConsDefn,
|
|
FunctorConsTypeInfo)
|
|
;
|
|
AccessType = set,
|
|
ConsAction = flip_constraints_for_field_set,
|
|
convert_cons_defn(Info, GoalId, ConsAction, ConsDefn,
|
|
FunctorConsTypeInfo)
|
|
).
|
|
|
|
:- type maybe_cons_type_info
|
|
---> ok(cons_type_info)
|
|
; error(cons_error).
|
|
|
|
:- pred convert_field_access_cons_type_info(class_table::in,
|
|
field_access_type::in, sym_name::in, hlds_ctor_field_defn::in,
|
|
cons_type_info::in, existq_tvars::in, maybe_cons_type_info::out) is det.
|
|
|
|
convert_field_access_cons_type_info(ClassTable, AccessType, FieldName,
|
|
FieldDefn, FunctorConsTypeInfo, OrigExistTVars, ConsTypeInfo) :-
|
|
FunctorConsTypeInfo = cons_type_info(TVarSet0, ExistQVars,
|
|
FunctorType, ConsArgTypes, Constraints0, Source0),
|
|
(
|
|
Source0 = source_type(SourceType)
|
|
;
|
|
( Source0 = source_builtin_type(_)
|
|
; Source0 = source_get_field_access(_)
|
|
; Source0 = source_set_field_access(_)
|
|
; Source0 = source_apply(_)
|
|
; Source0 = source_pred(_)
|
|
),
|
|
unexpected($pred, "not type")
|
|
),
|
|
FieldDefn = hlds_ctor_field_defn(_, _, _, _, FieldNumber),
|
|
list.det_index1(ConsArgTypes, FieldNumber, FieldType),
|
|
(
|
|
AccessType = get,
|
|
Source = source_get_field_access(SourceType),
|
|
RetType = FieldType,
|
|
ArgTypes = [FunctorType],
|
|
ConsTypeInfo = ok(cons_type_info(TVarSet0, ExistQVars,
|
|
RetType, ArgTypes, Constraints0, Source))
|
|
;
|
|
AccessType = set,
|
|
Source = source_set_field_access(SourceType),
|
|
|
|
% When setting a polymorphic field, the type of the field in the result
|
|
% is not necessarily the same as in the input. If a type variable
|
|
% occurs only in the field being set, create a new type variable for it
|
|
% in the result type.
|
|
%
|
|
% This allows code such as
|
|
% :- type pair(T, U)
|
|
% ---> '-'(fst::T, snd::U).
|
|
%
|
|
% Pair0 = 1 - 'a',
|
|
% Pair = Pair0 ^ snd := 2.
|
|
|
|
type_vars(FieldType, TVarsInField),
|
|
% Most of the time, TVarsInField is [], so provide a fast path
|
|
% for this case.
|
|
(
|
|
TVarsInField = [],
|
|
RetType = FunctorType,
|
|
ArgTypes = [FunctorType, FieldType],
|
|
% None of the constraints are affected by the updated field,
|
|
% so the constraints are unchanged.
|
|
ConsTypeInfo = ok(cons_type_info(TVarSet0, ExistQVars,
|
|
RetType, ArgTypes, Constraints0, Source))
|
|
;
|
|
TVarsInField = [_ | _],
|
|
|
|
% XXX This demonstrates a problem - if a type variable occurs
|
|
% in the types of multiple fields, any predicates changing values
|
|
% of one of these fields cannot change their types. This especially
|
|
% a problem for existentially typed fields, because setting the
|
|
% field always changes the type.
|
|
%
|
|
% Haskell gets around this problem by allowing multiple fields
|
|
% to be set by the same expression. Haskell doesn't handle all
|
|
% cases -- it is not possible to get multiple existentially typed
|
|
% fields using record syntax and pass them to a function whose type
|
|
% requires that the fields are of the same type. It probably won't
|
|
% come up too often.
|
|
%
|
|
list.det_replace_nth(ConsArgTypes, FieldNumber, int_type,
|
|
ArgTypesWithoutField),
|
|
type_vars_list(ArgTypesWithoutField, TVarsInOtherArgs),
|
|
set.intersect(
|
|
set.list_to_set(TVarsInField),
|
|
set.intersect(
|
|
set.list_to_set(TVarsInOtherArgs),
|
|
set.list_to_set(OrigExistTVars)
|
|
),
|
|
ExistQVarsInFieldAndOthers),
|
|
( if set.is_empty(ExistQVarsInFieldAndOthers) then
|
|
% Rename apart type variables occurring only in the field
|
|
% to be replaced - the values of those type variables will be
|
|
% supplied by the replacement field value.
|
|
list.delete_elems(TVarsInField,
|
|
TVarsInOtherArgs, TVarsOnlyInField0),
|
|
list.sort_and_remove_dups(TVarsOnlyInField0, TVarsOnlyInField),
|
|
list.length(TVarsOnlyInField, NumNewTVars),
|
|
varset.new_vars(NumNewTVars, NewTVars, TVarSet0, TVarSet),
|
|
map.from_corresponding_lists(TVarsOnlyInField,
|
|
NewTVars, TVarRenaming),
|
|
apply_variable_renaming_to_type(TVarRenaming, FieldType,
|
|
RenamedFieldType),
|
|
apply_variable_renaming_to_type(TVarRenaming, FunctorType,
|
|
OutputFunctorType),
|
|
% Rename the class constraints, projecting the constraints
|
|
% onto the set of type variables occurring in the types of the
|
|
% arguments of the call to `'field :='/2'. Note that we have
|
|
% already flipped the constraints.
|
|
type_vars_list([FunctorType, FieldType], CallTVars0),
|
|
set.list_to_set(CallTVars0, CallTVars),
|
|
project_and_rename_constraints(ClassTable, TVarSet, CallTVars,
|
|
TVarRenaming, Constraints0, Constraints),
|
|
RetType = OutputFunctorType,
|
|
ArgTypes = [FunctorType, RenamedFieldType],
|
|
ConsTypeInfo = ok(cons_type_info(TVarSet, ExistQVars,
|
|
RetType, ArgTypes, Constraints, Source))
|
|
else
|
|
% This field cannot be set. Pass out some information so that
|
|
% we can give a better error message. Errors involving changing
|
|
% the types of universally quantified type variables will be
|
|
% caught by typecheck_functor_arg_types.
|
|
set.to_sorted_list(ExistQVarsInFieldAndOthers,
|
|
ExistQVarsInFieldAndOthers1),
|
|
ConsTypeInfo = error(invalid_field_update(FieldName,
|
|
FieldDefn, TVarSet0, ExistQVarsInFieldAndOthers1))
|
|
)
|
|
)
|
|
).
|
|
|
|
% Add new universal constraints for constraints containing variables that
|
|
% have been renamed. These new constraints are the ones that will need
|
|
% to be supplied by the caller. The other constraints will be supplied
|
|
% from non-updated fields.
|
|
%
|
|
:- pred project_and_rename_constraints(class_table::in, tvarset::in,
|
|
set(tvar)::in, tvar_renaming::in,
|
|
hlds_constraints::in, hlds_constraints::out) is det.
|
|
|
|
project_and_rename_constraints(ClassTable, TVarSet, CallTVars, TVarRenaming,
|
|
!Constraints) :-
|
|
!.Constraints = hlds_constraints(Unproven0, Assumed,
|
|
Redundant0, Ancestors),
|
|
|
|
% Project the constraints down onto the list of tvars in the call.
|
|
list.filter(project_constraint(CallTVars), Unproven0, NewUnproven0),
|
|
list.filter_map(rename_constraint(TVarRenaming), NewUnproven0,
|
|
NewUnproven),
|
|
update_redundant_constraints(ClassTable, TVarSet, NewUnproven,
|
|
Redundant0, Redundant),
|
|
list.append(NewUnproven, Unproven0, Unproven),
|
|
!:Constraints = hlds_constraints(Unproven, Assumed, Redundant, Ancestors).
|
|
|
|
:- pred project_constraint(set(tvar)::in, hlds_constraint::in) is semidet.
|
|
|
|
project_constraint(CallTVars, Constraint) :-
|
|
Constraint = hlds_constraint(_Ids, _ClassName, TypesToCheck),
|
|
type_vars_list(TypesToCheck, TVarsToCheck0),
|
|
set.list_to_set(TVarsToCheck0, TVarsToCheck),
|
|
set.intersect(TVarsToCheck, CallTVars, RelevantTVars),
|
|
set.is_non_empty(RelevantTVars).
|
|
|
|
:- pred rename_constraint(tvar_renaming::in, hlds_constraint::in,
|
|
hlds_constraint::out) is semidet.
|
|
|
|
rename_constraint(TVarRenaming, Constraint0, Constraint) :-
|
|
Constraint0 = hlds_constraint(Ids, ClassName, ArgTypes0),
|
|
some [Var] (
|
|
type_list_contains_var(ArgTypes0, Var),
|
|
map.contains(TVarRenaming, Var)
|
|
),
|
|
apply_variable_renaming_to_type_list(TVarRenaming, ArgTypes0, ArgTypes),
|
|
Constraint = hlds_constraint(Ids, ClassName, ArgTypes).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Note: changes here may require changes to
|
|
% post_typecheck.resolve_unify_functor,
|
|
% intermod.module_qualify_unify_rhs,
|
|
% recompilation.usage.find_matching_constructors
|
|
% and recompilation.check.check_functor_ambiguities.
|
|
%
|
|
:- pred typecheck_info_get_ctor_list(typecheck_info::in, cons_id::in, int::in,
|
|
goal_id::in, list(cons_type_info)::out, list(cons_error)::out) is det.
|
|
|
|
typecheck_info_get_ctor_list(Info, Functor, Arity, GoalId, ConsInfos,
|
|
ConsErrors) :-
|
|
typecheck_info_get_is_field_access_function(Info, IsFieldAccessFunc),
|
|
( if
|
|
% If we are typechecking the clause added for a field access function
|
|
% for which the user has supplied type or mode declarations, the goal
|
|
% should only contain an application of the field access function,
|
|
% not constructor applications or function calls. The clauses in
|
|
% `.opt' files will already have been expanded into unifications.
|
|
IsFieldAccessFunc = yes(PredStatus),
|
|
PredStatus \= pred_status(status_opt_imported)
|
|
then
|
|
( if
|
|
builtin_field_access_function_type(Info, GoalId,
|
|
Functor, Arity, FieldAccessConsInfos)
|
|
then
|
|
split_cons_errors(FieldAccessConsInfos, ConsInfos, ConsErrors)
|
|
else
|
|
ConsInfos = [],
|
|
ConsErrors = []
|
|
)
|
|
else
|
|
typecheck_info_get_ctor_list_2(Info, Functor, Arity, GoalId,
|
|
ConsInfos, ConsErrors)
|
|
).
|
|
|
|
:- pred typecheck_info_get_ctor_list_2(typecheck_info::in, cons_id::in,
|
|
int::in, goal_id::in, list(cons_type_info)::out, list(cons_error)::out)
|
|
is det.
|
|
|
|
typecheck_info_get_ctor_list_2(Info, Functor, Arity, GoalId, ConsInfos,
|
|
DataConsErrors) :-
|
|
empty_hlds_constraints(EmptyConstraints),
|
|
|
|
% Check if `Functor/Arity' has been defined as a constructor in some
|
|
% discriminated union type(s). This gives us a list of possible
|
|
% cons_type_infos.
|
|
typecheck_info_get_cons_table(Info, ConsTable),
|
|
( if
|
|
Functor = cons(_, _, _),
|
|
search_cons_table(ConsTable, Functor, HLDS_ConsDefns)
|
|
then
|
|
convert_cons_defn_list(Info, GoalId, do_not_flip_constraints,
|
|
HLDS_ConsDefns, PlainMaybeConsInfos)
|
|
else
|
|
PlainMaybeConsInfos = []
|
|
),
|
|
|
|
% For "existentially typed" functors, whether the functor is actually
|
|
% existentially typed depends on whether it is used as a constructor
|
|
% or as a deconstructor. As a constructor, it is universally typed,
|
|
% but as a deconstructor, it is existentially typed. But type checking
|
|
% and polymorphism need to know whether it is universally or existentially
|
|
% quantified _before_ mode analysis has inferred the mode of the
|
|
% unification. Therefore, we use a special syntax for construction
|
|
% unifications with existentially quantified functors: instead of
|
|
% just using the functor name (e.g. "Y = foo(X)", the programmer must use
|
|
% the special functor name "new foo" (e.g. "Y = 'new foo'(X)").
|
|
%
|
|
% Here we check for occurrences of functor names starting with "new ".
|
|
% For these, we look up the original functor in the constructor symbol
|
|
% table, and for any occurrences of that functor we flip the quantifiers on
|
|
% the type definition (i.e. convert the existential quantifiers and
|
|
% constraints into universal ones).
|
|
( if
|
|
Functor = cons(Name, Arity, FunctorTypeCtor),
|
|
remove_new_prefix(Name, OrigName),
|
|
OrigFunctor = cons(OrigName, Arity, FunctorTypeCtor),
|
|
search_cons_table(ConsTable, OrigFunctor, HLDS_ExistQConsDefns)
|
|
then
|
|
convert_cons_defn_list(Info, GoalId, flip_constraints_for_new,
|
|
HLDS_ExistQConsDefns, UnivQuantifiedMaybeConsInfos)
|
|
else
|
|
UnivQuantifiedMaybeConsInfos = []
|
|
),
|
|
|
|
% Check if Functor is a field access function for which the user
|
|
% has not supplied a declaration.
|
|
( if
|
|
builtin_field_access_function_type(Info, GoalId, Functor,
|
|
Arity, FieldAccessMaybeConsInfosPrime)
|
|
then
|
|
FieldAccessMaybeConsInfos = FieldAccessMaybeConsInfosPrime
|
|
else
|
|
FieldAccessMaybeConsInfos = []
|
|
),
|
|
|
|
DataMaybeConsInfos = PlainMaybeConsInfos ++ UnivQuantifiedMaybeConsInfos
|
|
++ FieldAccessMaybeConsInfos,
|
|
split_cons_errors(DataMaybeConsInfos, DataConsInfos, DataConsErrors),
|
|
|
|
% Check if Functor is a constant of one of the builtin atomic types
|
|
% (string, float, int, character). If so, insert the resulting
|
|
% cons_type_info at the start of the list.
|
|
( if
|
|
Arity = 0,
|
|
builtin_atomic_type(Functor, BuiltInTypeName)
|
|
then
|
|
TypeCtor = type_ctor(unqualified(BuiltInTypeName), 0),
|
|
construct_type(TypeCtor, [], ConsType),
|
|
varset.init(ConsTypeVarSet),
|
|
ConsInfo = cons_type_info(ConsTypeVarSet, [], ConsType, [],
|
|
EmptyConstraints, source_builtin_type(BuiltInTypeName)),
|
|
BuiltinConsInfos = [ConsInfo]
|
|
else
|
|
BuiltinConsInfos = []
|
|
),
|
|
|
|
% Check if Functor is a tuple constructor.
|
|
( if
|
|
( Functor = cons(unqualified("{}"), TupleArity, _)
|
|
; Functor = tuple_cons(TupleArity)
|
|
)
|
|
then
|
|
% Make some fresh type variables for the argument types. These have
|
|
% kind `star' since there are values (namely the arguments of the
|
|
% tuple constructor) which have these types.
|
|
|
|
varset.init(TupleConsTypeVarSet0),
|
|
varset.new_vars(TupleArity, TupleArgTVars,
|
|
TupleConsTypeVarSet0, TupleConsTypeVarSet),
|
|
prog_type.var_list_to_type_list(map.init, TupleArgTVars,
|
|
TupleArgTypes),
|
|
|
|
TupleTypeCtor = type_ctor(unqualified("{}"), TupleArity),
|
|
construct_type(TupleTypeCtor, TupleArgTypes, TupleConsType),
|
|
|
|
% Tuples can't have existentially typed arguments.
|
|
TupleExistQVars = [],
|
|
TupleConsInfo = cons_type_info(TupleConsTypeVarSet, TupleExistQVars,
|
|
TupleConsType, TupleArgTypes, EmptyConstraints,
|
|
source_builtin_type("tuple")),
|
|
TupleConsInfos = [TupleConsInfo]
|
|
else
|
|
TupleConsInfos = []
|
|
),
|
|
|
|
% Check if Functor is the name of a predicate which takes at least
|
|
% Arity arguments. If so, insert the resulting cons_type_info
|
|
% at the start of the list.
|
|
( if
|
|
builtin_pred_type(Info, Functor, Arity, GoalId, PredConsInfosPrime)
|
|
then
|
|
PredConsInfos = PredConsInfosPrime
|
|
else
|
|
PredConsInfos = []
|
|
),
|
|
|
|
% Check for higher-order function calls.
|
|
( if
|
|
builtin_apply_type(Info, Functor, Arity, ApplyConsInfosPrime)
|
|
then
|
|
ApplyConsInfos = ApplyConsInfosPrime
|
|
else
|
|
ApplyConsInfos = []
|
|
),
|
|
|
|
OtherConsInfos = BuiltinConsInfos ++ TupleConsInfos
|
|
++ PredConsInfos ++ ApplyConsInfos,
|
|
ConsInfos = DataConsInfos ++ OtherConsInfos.
|
|
|
|
% Filter out the errors (they aren't actually reported as errors
|
|
% unless there was no other matching constructor).
|
|
%
|
|
:- pred split_cons_errors(list(maybe_cons_type_info)::in,
|
|
list(cons_type_info)::out, list(cons_error)::out) is det.
|
|
|
|
split_cons_errors([], [], []).
|
|
split_cons_errors([MaybeConsInfo | MaybeConsInfos], Infos, Errors) :-
|
|
split_cons_errors(MaybeConsInfos, InfosTail, ErrorsTail),
|
|
(
|
|
MaybeConsInfo = ok(ConsInfo),
|
|
Infos = [ConsInfo | InfosTail],
|
|
Errors = ErrorsTail
|
|
;
|
|
MaybeConsInfo = error(ConsError),
|
|
Infos = InfosTail,
|
|
Errors = [ConsError | ErrorsTail]
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type cons_constraints_action
|
|
---> flip_constraints_for_new
|
|
; flip_constraints_for_field_set
|
|
; do_not_flip_constraints.
|
|
|
|
:- pred convert_cons_defn_list(typecheck_info::in, goal_id::in,
|
|
cons_constraints_action::in, list(hlds_cons_defn)::in,
|
|
list(maybe_cons_type_info)::out) is det.
|
|
|
|
convert_cons_defn_list(_Info, _GoalId, _Action, [], []).
|
|
convert_cons_defn_list(Info, GoalId, Action, [X | Xs], [Y | Ys]) :-
|
|
convert_cons_defn(Info, GoalId, Action, X, Y),
|
|
convert_cons_defn_list(Info, GoalId, Action, Xs, Ys).
|
|
|
|
:- pred convert_cons_defn(typecheck_info, goal_id,
|
|
cons_constraints_action, hlds_cons_defn, maybe_cons_type_info).
|
|
:- mode convert_cons_defn(in, in, in(bound(do_not_flip_constraints)), in, out)
|
|
is det.
|
|
:- mode convert_cons_defn(in, in, in, in, out) is det.
|
|
|
|
convert_cons_defn(Info, GoalId, Action, HLDS_ConsDefn, ConsTypeInfo) :-
|
|
% XXX We should investigate whether the job done by this predicate
|
|
% on demand and therefore possibly lots of times for the same type,
|
|
% would be better done just once, either by invoking it (at least with
|
|
% Action = do_not_flip_constraints) before type checking even starts and
|
|
% recording the result, or by putting the result into the HLDS_ConsDefn
|
|
% or some related data structure.
|
|
|
|
HLDS_ConsDefn = hlds_cons_defn(TypeCtor, ConsTypeVarSet, ConsTypeParams,
|
|
ConsTypeKinds, MaybeExistConstraints, Args, _),
|
|
ArgTypes = list.map(func(C) = C ^ arg_type, Args),
|
|
typecheck_info_get_type_table(Info, TypeTable),
|
|
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
|
|
hlds_data.get_type_defn_body(TypeDefn, Body),
|
|
|
|
% If this type has `:- pragma foreign_type' declarations, we can only use
|
|
% its constructors in predicates which have foreign clauses and in the
|
|
% unification and comparison predicates for the type (otherwise the code
|
|
% wouldn't compile when using a back-end which caused another version
|
|
% of the type to be selected). The constructors may also appear in the
|
|
% automatically generated unification and comparison predicates.
|
|
%
|
|
% XXX This check isn't quite right -- we really need to check for
|
|
% each procedure that there is a foreign_proc declaration for all
|
|
% languages for which this type has a foreign_type declaration, but
|
|
% this will do for now. Such a check may be difficult because by
|
|
% this point we have thrown away the clauses which we are not using
|
|
% in the current compilation.
|
|
%
|
|
% The `.opt' files don't contain the foreign clauses from the source
|
|
% file that are not used when compiling in the current grade, so we
|
|
% allow foreign type constructors in `opt_imported' predicates even
|
|
% if there are no foreign clauses. Errors will be caught when creating
|
|
% the `.opt' file.
|
|
|
|
typecheck_info_get_pred_id(Info, PredId),
|
|
typecheck_info_get_module_info(Info, ModuleInfo),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_status(PredInfo, PredStatus),
|
|
( if
|
|
Body ^ du_type_is_foreign_type = yes(_),
|
|
not pred_info_get_goal_type(PredInfo, goal_type_clause_and_foreign),
|
|
not is_unify_index_or_compare_pred(PredInfo),
|
|
PredStatus \= pred_status(status_opt_imported)
|
|
then
|
|
ConsTypeInfo = error(foreign_type_constructor(TypeCtor, TypeDefn))
|
|
else if
|
|
% Do not allow constructors for abstract_imported types unless
|
|
% the current predicate is opt_imported.
|
|
hlds_data.get_type_defn_status(TypeDefn, TypeStatus),
|
|
TypeStatus = type_status(status_abstract_imported),
|
|
not is_unify_index_or_compare_pred(PredInfo),
|
|
PredStatus \= pred_status(status_opt_imported)
|
|
then
|
|
ConsTypeInfo = error(abstract_imported_type)
|
|
else if
|
|
Action = flip_constraints_for_new,
|
|
MaybeExistConstraints = no_exist_constraints
|
|
then
|
|
% Do not allow 'new' constructors except on existential types.
|
|
ConsTypeInfo = error(new_on_non_existential_type(TypeCtor))
|
|
else
|
|
prog_type.var_list_to_type_list(ConsTypeKinds, ConsTypeParams,
|
|
ConsTypeArgs),
|
|
construct_type(TypeCtor, ConsTypeArgs, ConsType),
|
|
UnivProgConstraints = [],
|
|
(
|
|
MaybeExistConstraints = no_exist_constraints,
|
|
ExistQVars0 = [],
|
|
ExistProgConstraints = []
|
|
;
|
|
MaybeExistConstraints = exist_constraints(ExistConstraints),
|
|
ExistConstraints = cons_exist_constraints(ExistQVars0,
|
|
ExistProgConstraints, _, _)
|
|
),
|
|
(
|
|
Action = do_not_flip_constraints,
|
|
ProgConstraints = constraints(UnivProgConstraints,
|
|
ExistProgConstraints),
|
|
ExistQVars = ExistQVars0
|
|
;
|
|
Action = flip_constraints_for_new,
|
|
% Make the existential constraints into universal ones, and discard
|
|
% the existentially quantified variables (since they are now
|
|
% universally quantified).
|
|
ProgConstraints = constraints(ExistProgConstraints,
|
|
UnivProgConstraints),
|
|
ExistQVars = []
|
|
;
|
|
Action = flip_constraints_for_field_set,
|
|
% The constraints are existential for the deconstruction, and
|
|
% universal for the construction. Even though all of the unproven
|
|
% constraints here can be trivially reduced by the assumed ones,
|
|
% we still need to process them so that the appropriate tables
|
|
% get updated.
|
|
ProgConstraints = constraints(ExistProgConstraints,
|
|
ExistProgConstraints),
|
|
ExistQVars = ExistQVars0
|
|
),
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
make_body_hlds_constraints(ClassTable, ConsTypeVarSet,
|
|
GoalId, ProgConstraints, Constraints),
|
|
ConsTypeInfo = ok(cons_type_info(ConsTypeVarSet, ExistQVars,
|
|
ConsType, ArgTypes, Constraints, source_type(TypeCtor)))
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module check_hlds.typecheck.
|
|
%---------------------------------------------------------------------------%
|