mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-17 06:47:17 +00:00
ee0bcf5a8a
compiler/mercury_compile_front_end.m:
Resolving the overloading of predicates and functions, which are
logically part of type checking, are done during the purity pass.
Therefore even if the user specifies --typecheck-only, execute the
purity checking pass, if the absence of type errors allows us to do so
safely.
To allow us to do this without code duplication, test for the presence
of type errors first, and for --typecheck-errors second.
Factor out some other common code.
compiler/notes/compiler_design.html:
Fix bit rot in the documentation of the modules involved in
post-typecheck tests.
compiler/resolve_unify_functor.m:
When generating error messages for type errors, record the error
as a type error, even though the code that discovers it is executed
during the purity pass.
668 lines
28 KiB
Mathematica
668 lines
28 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 2015 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.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This module does two tasks that are logically part of type analysis
|
|
% but must be done after type inference is complete:
|
|
%
|
|
% - it resolves function overloading; and
|
|
% - it expands field access functions.
|
|
%
|
|
% Most other similar tasks are done in post_typecheck.m or purity.m.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds.resolve_unify_functor.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.vartypes.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module list.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type is_plain_unify
|
|
---> is_not_plain_unify
|
|
; is_plain_unify
|
|
; is_unknown_ref(error_spec).
|
|
|
|
% Work out whether a var-functor unification is actually a function call.
|
|
% If so, replace the unification goal with a call.
|
|
%
|
|
:- pred resolve_unify_functor(module_info::in, prog_var::in, cons_id::in,
|
|
list(prog_var)::in, unify_mode::in, unification::in, unify_context::in,
|
|
hlds_goal_info::in, pred_info::in, pred_info::out,
|
|
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
|
|
hlds_goal::out, is_plain_unify::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.make_goal.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.goal_path.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.prog_util.
|
|
:- import_module parse_tree.set_of_var.
|
|
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module string.
|
|
:- import_module term_io.
|
|
:- import_module varset.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
resolve_unify_functor(ModuleInfo, X0, ConsId0, ArgVars0, Mode0,
|
|
Unification0, UnifyContext, GoalInfo0, !PredInfo, !VarSet, !VarTypes,
|
|
Goal, IsPlainUnify) :-
|
|
lookup_var_type(!.VarTypes, X0, TypeOfX),
|
|
list.length(ArgVars0, Arity),
|
|
( if
|
|
% Is the function symbol apply/N or ''/N, representing a higher-order
|
|
% function call? Or the impure/semipure equivalents impure_apply/N
|
|
% and semipure_apply/N?
|
|
% (XXX FIXME We should use nicer syntax for impure apply/N.)
|
|
ConsId0 = cons(unqualified(ApplyName), _, _),
|
|
( ApplyName = "apply", Purity = purity_pure
|
|
; ApplyName = "", Purity = purity_pure
|
|
; ApplyName = "impure_apply", Purity = purity_impure
|
|
; ApplyName = "semipure_apply", Purity = purity_semipure
|
|
),
|
|
Arity >= 1,
|
|
ArgVars0 = [FuncVar | FuncArgVars]
|
|
then
|
|
% Convert the higher-order function call (apply/N) into a higher-order
|
|
% predicate call (i.e., replace `X = apply(F, A, B, C)'
|
|
% with `call(F, A, B, C, X)')
|
|
ArgVars = FuncArgVars ++ [X0],
|
|
Modes = [],
|
|
Det = detism_erroneous,
|
|
adjust_func_arity(pf_function, Arity, FullArity),
|
|
HOCall = generic_call(
|
|
higher_order(FuncVar, Purity, pf_function, FullArity),
|
|
ArgVars, Modes, arg_reg_types_unset, Det),
|
|
Goal = hlds_goal(HOCall, GoalInfo0),
|
|
IsPlainUnify = is_not_plain_unify
|
|
else if
|
|
% Is the function symbol a user-defined function, rather than
|
|
% a functor which represents a data constructor?
|
|
|
|
% Find the set of candidate predicates which have the
|
|
% specified name and arity (and module, if module-qualified)
|
|
ConsId0 = cons(PredName, _, _),
|
|
|
|
pred_info_get_markers(!.PredInfo, Markers),
|
|
module_info_get_predicate_table(ModuleInfo, PredTable),
|
|
% This search will usually fail, so do it first.
|
|
predicate_table_lookup_func_sym_arity(PredTable,
|
|
calls_are_fully_qualified(Markers), PredName, Arity, PredIds),
|
|
PredIds = [_ | _],
|
|
|
|
% We don't do this for compiler-generated predicates; they are assumed
|
|
% to have been generated with all functions already expanded. If we did
|
|
% this check for compiler-generated predicates, it would cause the
|
|
% wrong behaviour in the case where there is a user-defined function
|
|
% whose type is exactly the same as the type of a constructor.
|
|
% (Normally that would cause a type ambiguity error, but
|
|
% compiler-generated predicates are not type-checked.)
|
|
not is_unify_or_compare_pred(!.PredInfo),
|
|
|
|
% We don't do this for the clause introduced by the compiler for a
|
|
% field access function -- that needs to be expanded into
|
|
% unifications below.
|
|
not pred_info_is_field_access_function(ModuleInfo, !.PredInfo),
|
|
|
|
% Check if any of the candidate functions have argument/return types
|
|
% which subsume the actual argument/return types of this function call,
|
|
% and which have universal constraints consistent with what we expect.
|
|
pred_info_get_typevarset(!.PredInfo, TVarSet),
|
|
pred_info_get_exist_quant_tvars(!.PredInfo, ExistQTVars),
|
|
pred_info_get_external_type_params(!.PredInfo, ExternalTypeParams),
|
|
lookup_var_types(!.VarTypes, ArgVars0, ArgTypes0),
|
|
ArgTypes = ArgTypes0 ++ [TypeOfX],
|
|
pred_info_get_constraint_map(!.PredInfo, ConstraintMap),
|
|
GoalId = goal_info_get_goal_id(GoalInfo0),
|
|
ConstraintSearch =
|
|
search_hlds_constraint_list(ConstraintMap, unproven, GoalId),
|
|
Context = goal_info_get_context(GoalInfo0),
|
|
find_matching_pred_id(ModuleInfo, PredIds, TVarSet, ExistQTVars,
|
|
ArgTypes, ExternalTypeParams, yes(ConstraintSearch), Context,
|
|
PredId, QualifiedFuncName)
|
|
then
|
|
% Convert function calls in unifications into plain calls:
|
|
% replace `X = f(A, B, C)' with `f(A, B, C, X)'.
|
|
|
|
ProcId = invalid_proc_id,
|
|
ArgVars = ArgVars0 ++ [X0],
|
|
FuncCallUnifyContext = call_unify_context(X0,
|
|
rhs_functor(ConsId0, is_not_exist_constr, ArgVars0), UnifyContext),
|
|
FuncCall = plain_call(PredId, ProcId, ArgVars, not_builtin,
|
|
yes(FuncCallUnifyContext), QualifiedFuncName),
|
|
Goal = hlds_goal(FuncCall, GoalInfo0),
|
|
IsPlainUnify = is_not_plain_unify
|
|
else if
|
|
% Is the function symbol a higher-order predicate or function constant?
|
|
ConsId0 = cons(Name, _, _),
|
|
type_is_higher_order_details(TypeOfX, _Purity, PredOrFunc,
|
|
EvalMethod, HOArgTypes),
|
|
|
|
% We don't do this for the clause introduced by the compiler
|
|
% for a field access function -- that needs to be expanded
|
|
% into unifications below.
|
|
not pred_info_is_field_access_function(ModuleInfo, !.PredInfo),
|
|
|
|
% Find the pred_id of the constant.
|
|
lookup_var_types(!.VarTypes, ArgVars0, ArgTypes0),
|
|
AllArgTypes = ArgTypes0 ++ HOArgTypes,
|
|
pred_info_get_typevarset(!.PredInfo, TVarSet),
|
|
pred_info_get_exist_quant_tvars(!.PredInfo, ExistQVars),
|
|
pred_info_get_external_type_params(!.PredInfo, ExternalTypeParams),
|
|
pred_info_get_markers(!.PredInfo, Markers),
|
|
Context = goal_info_get_context(GoalInfo0),
|
|
get_pred_id_by_types(calls_are_fully_qualified(Markers), Name,
|
|
PredOrFunc, TVarSet, ExistQVars, AllArgTypes, ExternalTypeParams,
|
|
ModuleInfo, Context, PredId)
|
|
then
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
ProcIds = pred_info_procids(PredInfo),
|
|
(
|
|
ProcIds = [ProcId0],
|
|
MaybeProcId = yes(ProcId0)
|
|
;
|
|
ProcIds = [_, _ | _],
|
|
% We don't know which mode to pick. Defer it until mode checking.
|
|
MaybeProcId = yes(invalid_proc_id)
|
|
;
|
|
ProcIds = [],
|
|
MaybeProcId = no
|
|
),
|
|
(
|
|
MaybeProcId = yes(ProcId),
|
|
ShroudedPredProcId = shroud_pred_proc_id(proc(PredId, ProcId)),
|
|
ConsId = closure_cons(ShroudedPredProcId, EvalMethod),
|
|
GoalExpr = unify(X0,
|
|
rhs_functor(ConsId, is_not_exist_constr, ArgVars0),
|
|
Mode0, Unification0, UnifyContext),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0),
|
|
IsPlainUnify = is_not_plain_unify
|
|
;
|
|
MaybeProcId = no,
|
|
Goal = true_goal,
|
|
Pieces = [words("Error: reference to"),
|
|
words("undeclared function or predicate"),
|
|
sym_name_and_arity(Name / Arity), suffix("."), nl],
|
|
Msg = simple_msg(Context, [always(Pieces)]),
|
|
Spec = error_spec(severity_error, phase_type_check, [Msg]),
|
|
IsPlainUnify = is_unknown_ref(Spec)
|
|
)
|
|
else if
|
|
% Is it a call to an automatically generated field access function.
|
|
% This test must come after the tests for function calls and
|
|
% higher-order terms above. We do it that way because it is easier
|
|
% to check that the types match for functions calls and higher-order
|
|
% terms.
|
|
ConsId0 = cons(Name, Arity, _),
|
|
is_field_access_function_name(ModuleInfo, Name, Arity,
|
|
AccessType, FieldName),
|
|
|
|
% We don't do this for compiler-generated predicates --
|
|
% they will never contain calls to field access functions.
|
|
not is_unify_or_compare_pred(!.PredInfo),
|
|
|
|
% If there is a constructor for which the argument types match,
|
|
% this unification couldn't be a call to a field access function,
|
|
% otherwise there would have been an error reported for unresolved
|
|
% overloading.
|
|
pred_info_get_typevarset(!.PredInfo, TVarSet),
|
|
lookup_var_types(!.VarTypes, ArgVars0, ArgTypes0),
|
|
not find_matching_constructor(ModuleInfo, TVarSet, ConsId0,
|
|
TypeOfX, ArgTypes0)
|
|
then
|
|
finish_field_access_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet,
|
|
AccessType, FieldName, UnifyContext, X0, ArgVars0, GoalInfo0,
|
|
Goal),
|
|
IsPlainUnify = is_not_plain_unify
|
|
else
|
|
% Module qualify ordinary construction/deconstruction unifications.
|
|
type_to_ctor_det(TypeOfX, TypeCtorOfX),
|
|
( if ConsId0 = cons(SymName0, Arity, _OldTypeCtor) then
|
|
( if TypeOfX = tuple_type(_, _) then
|
|
ConsId = tuple_cons(Arity)
|
|
else if TypeOfX = builtin_type(builtin_type_char) then
|
|
(
|
|
SymName0 = unqualified(Name0),
|
|
( if encode_escaped_char(Char, Name0) then
|
|
ConsId = char_const(Char)
|
|
else
|
|
unexpected($module, $pred, "encode_escaped_char")
|
|
)
|
|
;
|
|
SymName0 = qualified(_, _),
|
|
unexpected($module, $pred, "qualified char const")
|
|
)
|
|
else
|
|
Name = unqualify_name(SymName0),
|
|
TypeCtorOfX = type_ctor(TypeCtorSymName, _),
|
|
(
|
|
TypeCtorSymName = qualified(TypeCtorModule, _),
|
|
SymName = qualified(TypeCtorModule, Name),
|
|
ConsId = cons(SymName, Arity, TypeCtorOfX)
|
|
;
|
|
TypeCtorSymName = unqualified(_),
|
|
unexpected($module, $pred, "unqualified type_ctor")
|
|
)
|
|
)
|
|
else
|
|
ConsId = ConsId0
|
|
),
|
|
RHS = rhs_functor(ConsId, is_not_exist_constr, ArgVars0),
|
|
GoalExpr = unify(X0, RHS, Mode0, Unification0, UnifyContext),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0),
|
|
IsPlainUnify = is_plain_unify
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Succeed if there is a constructor which matches the given cons_id,
|
|
% type and argument types.
|
|
%
|
|
:- pred find_matching_constructor(module_info::in, tvarset::in,
|
|
cons_id::in, mer_type::in, list(mer_type)::in) is semidet.
|
|
|
|
find_matching_constructor(ModuleInfo, TVarSet, ConsId, Type, ArgTypes) :-
|
|
type_to_ctor(Type, TypeCtor),
|
|
module_info_get_cons_table(ModuleInfo, ConsTable),
|
|
search_cons_table_of_type_ctor(ConsTable, TypeCtor, ConsId, ConsDefn),
|
|
|
|
% Overloading resolution ignores the class constraints.
|
|
ConsDefn = hlds_cons_defn(_, _, _, _, ConsExistQVars, _, ConsArgs, _),
|
|
|
|
module_info_get_type_table(ModuleInfo, TypeTable),
|
|
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
|
|
hlds_data.get_type_defn_tvarset(TypeDefn, TypeTVarSet),
|
|
hlds_data.get_type_defn_kind_map(TypeDefn, TypeKindMap),
|
|
|
|
ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgs),
|
|
% XXX is this correct?
|
|
ExistQVars = [],
|
|
ExternalTypeParams = [],
|
|
arg_type_list_subsumes(TVarSet, ExistQVars, ArgTypes, ExternalTypeParams,
|
|
TypeTVarSet, TypeKindMap, ConsExistQVars, ConsArgTypes).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Convert a field access function call into the equivalent unifications
|
|
% so that later passes do not have to handle them as a special case.
|
|
% The error messages from mode analysis and determinism analysis
|
|
% shouldn't be too much worse than if the goals were special cases.
|
|
%
|
|
:- pred finish_field_access_function(module_info::in,
|
|
pred_info::in, pred_info::out, vartypes::in, vartypes::out,
|
|
prog_varset::in, prog_varset::out, field_access_type::in, sym_name::in,
|
|
unify_context::in, prog_var::in, list(prog_var)::in,
|
|
hlds_goal_info::in, hlds_goal::out) is det.
|
|
|
|
finish_field_access_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet,
|
|
AccessType, FieldName, UnifyContext, Var, Args, GoalInfo,
|
|
hlds_goal(GoalExpr, GoalInfo)) :-
|
|
(
|
|
AccessType = get,
|
|
field_extraction_function_args(Args, TermVar),
|
|
translate_get_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet,
|
|
FieldName, UnifyContext, Var, TermVar, GoalInfo, GoalExpr)
|
|
;
|
|
AccessType = set,
|
|
field_update_function_args(Args, TermInputVar, FieldVar),
|
|
translate_set_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet,
|
|
FieldName, UnifyContext, FieldVar, TermInputVar, Var,
|
|
GoalInfo, GoalExpr)
|
|
).
|
|
|
|
:- pred translate_get_function(module_info::in, pred_info::in, pred_info::out,
|
|
vartypes::in, vartypes::out, prog_varset::in, prog_varset::out,
|
|
sym_name::in, unify_context::in, prog_var::in, prog_var::in,
|
|
hlds_goal_info::in, hlds_goal_expr::out) is det.
|
|
|
|
translate_get_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, FieldName,
|
|
UnifyContext, FieldVar, TermInputVar, OldGoalInfo, GoalExpr) :-
|
|
lookup_var_type(!.VarTypes, TermInputVar, TermType),
|
|
get_constructor_containing_field(ModuleInfo, TermType, FieldName,
|
|
ConsId, FieldNumber),
|
|
|
|
GoalId = goal_info_get_goal_id(OldGoalInfo),
|
|
get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, GoalId, ConsId,
|
|
TermType, ArgTypes0, ExistQVars, !PredInfo),
|
|
|
|
% If the type of the field we are extracting contains existentially
|
|
% quantified type variables then we need to rename any other occurrences
|
|
% of those type variables in the arguments of the constructor so that
|
|
% they match those in the type of the field. (We don't need to do this
|
|
% for field updates because if any existentially quantified type variables
|
|
% occur in field to set and other fields then the field update
|
|
% should have been disallowed by typecheck.m because the result
|
|
% can't be well-typed).
|
|
(
|
|
ExistQVars = [_ | _],
|
|
lookup_var_type(!.VarTypes, FieldVar, FieldType),
|
|
list.det_index1(ArgTypes0, FieldNumber, FieldArgType),
|
|
type_subsumes_det(FieldArgType, FieldType, FieldSubst),
|
|
apply_rec_subst_to_type_list(FieldSubst, ArgTypes0, ArgTypes)
|
|
;
|
|
ExistQVars = [],
|
|
ArgTypes = ArgTypes0
|
|
),
|
|
|
|
split_list_at_index(FieldNumber, ArgTypes, TypesBeforeField,
|
|
_, TypesAfterField),
|
|
|
|
make_new_vars(TypesBeforeField, VarsBeforeField, !VarTypes, !VarSet),
|
|
make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet),
|
|
|
|
ArgVars = VarsBeforeField ++ [FieldVar | VarsAfterField],
|
|
|
|
RestrictNonLocals = goal_info_get_nonlocals(OldGoalInfo),
|
|
create_pure_atomic_unification_with_nonlocals(TermInputVar,
|
|
rhs_functor(ConsId, is_not_exist_constr, ArgVars),
|
|
OldGoalInfo, RestrictNonLocals, [FieldVar, TermInputVar],
|
|
UnifyContext, FunctorGoal),
|
|
FunctorGoal = hlds_goal(GoalExpr, _).
|
|
|
|
:- pred translate_set_function(module_info::in, pred_info::in, pred_info::out,
|
|
vartypes::in, vartypes::out, prog_varset::in, prog_varset::out,
|
|
sym_name::in, unify_context::in, prog_var::in, prog_var::in, prog_var::in,
|
|
hlds_goal_info::in, hlds_goal_expr::out) is det.
|
|
|
|
translate_set_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, FieldName,
|
|
UnifyContext, FieldVar, TermInputVar, TermOutputVar, OldGoalInfo,
|
|
Goal) :-
|
|
lookup_var_type(!.VarTypes, TermInputVar, TermType),
|
|
get_constructor_containing_field(ModuleInfo, TermType, FieldName,
|
|
ConsId0, FieldNumber),
|
|
|
|
GoalId = goal_info_get_goal_id(OldGoalInfo),
|
|
get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, GoalId, ConsId0,
|
|
TermType, ArgTypes, ExistQVars, !PredInfo),
|
|
|
|
split_list_at_index(FieldNumber, ArgTypes,
|
|
TypesBeforeField, TermFieldType, TypesAfterField),
|
|
|
|
make_new_vars(TypesBeforeField, VarsBeforeField, !VarTypes, !VarSet),
|
|
make_new_var(TermFieldType, SingletonFieldVar, !VarTypes, !VarSet),
|
|
make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet),
|
|
|
|
% Build a goal to deconstruct the input.
|
|
DeconstructArgs = VarsBeforeField ++ [SingletonFieldVar | VarsAfterField],
|
|
OldNonLocals = goal_info_get_nonlocals(OldGoalInfo),
|
|
NonLocalArgs = VarsBeforeField ++ VarsAfterField,
|
|
set_of_var.insert_list(NonLocalArgs, OldNonLocals,
|
|
DeconstructRestrictNonLocals),
|
|
|
|
create_pure_atomic_unification_with_nonlocals(TermInputVar,
|
|
rhs_functor(ConsId0, is_not_exist_constr, DeconstructArgs),
|
|
OldGoalInfo, DeconstructRestrictNonLocals,
|
|
[TermInputVar | DeconstructArgs], UnifyContext, DeconstructGoal),
|
|
|
|
% Build a goal to construct the output.
|
|
ConstructArgs = VarsBeforeField ++ [FieldVar | VarsAfterField],
|
|
set_of_var.insert_list(NonLocalArgs, OldNonLocals,
|
|
ConstructRestrictNonLocals),
|
|
|
|
% If the cons_id is existentially quantified, add a `new' prefix
|
|
% so that polymorphism.m adds the appropriate type_infos.
|
|
(
|
|
ExistQVars = [],
|
|
ConsId = ConsId0
|
|
;
|
|
ExistQVars = [_ | _],
|
|
( if ConsId0 = cons(ConsName0, ConsArity, TypeCtor) then
|
|
add_new_prefix(ConsName0, ConsName),
|
|
ConsId = cons(ConsName, ConsArity, TypeCtor)
|
|
else
|
|
unexpected($module, $pred, "invalid cons_id")
|
|
)
|
|
),
|
|
|
|
create_pure_atomic_unification_with_nonlocals(TermOutputVar,
|
|
rhs_functor(ConsId, is_not_exist_constr, ConstructArgs), OldGoalInfo,
|
|
ConstructRestrictNonLocals, [TermOutputVar | ConstructArgs],
|
|
UnifyContext, ConstructGoal),
|
|
|
|
ConjExpr = conj(plain_conj, [DeconstructGoal, ConstructGoal]),
|
|
Conj = hlds_goal(ConjExpr, OldGoalInfo),
|
|
|
|
% Make mode analysis treat the translated access function
|
|
% as an atomic goal.
|
|
Goal = scope(barrier(removable), Conj).
|
|
|
|
:- pred get_cons_id_arg_types_adding_existq_tvars(module_info::in,
|
|
goal_id::in, cons_id::in, mer_type::in, list(mer_type)::out,
|
|
list(tvar)::out, pred_info::in, pred_info::out) is det.
|
|
|
|
get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, GoalId, ConsId,
|
|
TermType, ActualArgTypes, ActualExistQVars, !PredInfo) :-
|
|
% Split the list of argument types at the named field.
|
|
type_to_ctor_det(TermType, TypeCtor),
|
|
get_cons_defn_det(ModuleInfo, TypeCtor, ConsId, ConsDefn),
|
|
ConsDefn = hlds_cons_defn(_, _, TypeParams, _, ConsExistQVars,
|
|
ConsConstraints, ConsArgs, _),
|
|
ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgs),
|
|
|
|
(
|
|
ConsExistQVars = [],
|
|
ActualArgTypes0 = ConsArgTypes,
|
|
ActualExistQVars = []
|
|
;
|
|
ConsExistQVars = [_ | _],
|
|
% Rename apart the existentially quantified type variables.
|
|
list.length(ConsExistQVars, NumExistQVars),
|
|
pred_info_get_typevarset(!.PredInfo, TVarSet0),
|
|
varset.new_vars(NumExistQVars, ParentExistQVars, TVarSet0, TVarSet),
|
|
pred_info_set_typevarset(TVarSet, !PredInfo),
|
|
map.from_corresponding_lists(ConsExistQVars, ParentExistQVars,
|
|
ConsToParentRenaming),
|
|
apply_variable_renaming_to_type_list(ConsToParentRenaming,
|
|
ConsArgTypes, ParentArgTypes),
|
|
apply_variable_renaming_to_prog_constraint_list(ConsToParentRenaming,
|
|
ConsConstraints, ParentConstraints),
|
|
|
|
% Constrained existentially quantified tvars will have already been
|
|
% created during typechecking, so we need to ensure that the new ones
|
|
% we allocate here are bound to those created earlier, so that
|
|
% the varmaps remain meaningful.
|
|
|
|
pred_info_get_constraint_map(!.PredInfo, ConstraintMap),
|
|
list.length(ConsConstraints, NumConstraints),
|
|
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
|
|
NumConstraints, ActualConstraints),
|
|
constraint_list_subsumes_det(ParentConstraints, ActualConstraints,
|
|
ExistTSubst),
|
|
apply_rec_subst_to_type_list(ExistTSubst, ParentArgTypes,
|
|
ActualArgTypes0),
|
|
|
|
% The kinds will be ignored when the types are converted back to tvars.
|
|
map.init(KindMap),
|
|
apply_rec_subst_to_tvar_list(KindMap, ExistTSubst, ParentExistQVars,
|
|
ActualExistQVarTypes),
|
|
( if
|
|
type_list_to_var_list(ActualExistQVarTypes, ActualExistQVars0)
|
|
then
|
|
ActualExistQVars = ActualExistQVars0
|
|
else
|
|
unexpected($module, $pred, "existq_tvar bound to non-var")
|
|
)
|
|
),
|
|
type_to_ctor_and_args_det(TermType, _, TypeArgs),
|
|
map.from_corresponding_lists(TypeParams, TypeArgs, UnivTSubst),
|
|
apply_subst_to_type_list(UnivTSubst, ActualArgTypes0, ActualArgTypes).
|
|
|
|
:- pred constraint_list_subsumes_det(list(prog_constraint)::in,
|
|
list(prog_constraint)::in, tsubst::out) is det.
|
|
|
|
constraint_list_subsumes_det(ConstraintsA, ConstraintsB, Subst) :-
|
|
constraint_list_get_tvars(ConstraintsB, TVarsB),
|
|
map.init(Subst0),
|
|
( if
|
|
unify_constraint_list(ConstraintsA, ConstraintsB, TVarsB,
|
|
Subst0, Subst1)
|
|
then
|
|
Subst = Subst1
|
|
else
|
|
unexpected($module, $pred, "failed")
|
|
).
|
|
|
|
:- pred unify_constraint_list(list(prog_constraint)::in,
|
|
list(prog_constraint)::in, list(tvar)::in, tsubst::in, tsubst::out)
|
|
is semidet.
|
|
|
|
unify_constraint_list([], [], _, !Subst).
|
|
unify_constraint_list([A | As], [B | Bs], TVars, !Subst) :-
|
|
A = constraint(_ClassNameA, ArgTypesA),
|
|
B = constraint(_ClassNameB, ArgTypesB),
|
|
type_unify_list(ArgTypesA, ArgTypesB, TVars, !Subst),
|
|
unify_constraint_list(As, Bs, TVars, !Subst).
|
|
|
|
:- pred split_list_at_index(int::in, list(T)::in, list(T)::out, T::out,
|
|
list(T)::out) is det.
|
|
|
|
split_list_at_index(Index, List, Before, At, After) :-
|
|
( if
|
|
list.split_list(Index - 1, List, BeforePrime, AtAndAfter),
|
|
AtAndAfter = [AtPrime | AfterPrime]
|
|
then
|
|
Before = BeforePrime,
|
|
At = AtPrime,
|
|
After = AfterPrime
|
|
else
|
|
unexpected($module, $pred, "split_list_at_index")
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Work out which constructor of the type has an argument with the
|
|
% given field name.
|
|
%
|
|
:- pred get_constructor_containing_field(module_info::in, mer_type::in,
|
|
sym_name::in, cons_id::out, int::out) is det.
|
|
|
|
get_constructor_containing_field(ModuleInfo, TermType, FieldSymName,
|
|
ConsId, FieldNumber) :-
|
|
type_to_ctor_det(TermType, TermTypeCtor),
|
|
module_info_get_type_table(ModuleInfo, TypeTable),
|
|
lookup_type_ctor_defn(TypeTable, TermTypeCtor, TermTypeDefn),
|
|
hlds_data.get_type_defn_body(TermTypeDefn, TermTypeBody),
|
|
(
|
|
TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _, _),
|
|
FieldName = unqualify_name(FieldSymName),
|
|
get_constructor_containing_field_loop(TermTypeCtor, Ctors, FieldName,
|
|
ConsId, FieldNumber)
|
|
;
|
|
( TermTypeBody = hlds_eqv_type(_)
|
|
; TermTypeBody = hlds_foreign_type(_)
|
|
; TermTypeBody = hlds_solver_type(_, _)
|
|
; TermTypeBody = hlds_abstract_type(_)
|
|
),
|
|
unexpected($module, $pred, "not du type")
|
|
).
|
|
|
|
:- pred get_constructor_containing_field_loop(type_ctor::in,
|
|
list(constructor)::in, string::in, cons_id::out, int::out) is det.
|
|
|
|
get_constructor_containing_field_loop(_, [], _, _, _) :-
|
|
unexpected($module, $pred, "can't find field").
|
|
get_constructor_containing_field_loop(TypeCtor, [Ctor | Ctors],
|
|
UnqualFieldName, ConsId, FieldNumber) :-
|
|
Ctor = ctor(_, _, SymName, CtorArgs, Arity, _Ctxt),
|
|
( if
|
|
search_for_named_field(CtorArgs, UnqualFieldName, 1, FieldNumberPrime)
|
|
then
|
|
ConsId = cons(SymName, Arity, TypeCtor),
|
|
FieldNumber = FieldNumberPrime
|
|
else
|
|
get_constructor_containing_field_loop(TypeCtor, Ctors,
|
|
UnqualFieldName, ConsId, FieldNumber)
|
|
).
|
|
|
|
:- pred search_for_named_field(list(constructor_arg)::in,
|
|
string::in, int::in, int::out) is semidet.
|
|
|
|
search_for_named_field([CtorArg | CtorArgs], UnqualFieldName,
|
|
CurFieldNumber, NamedFieldNumber) :-
|
|
( if
|
|
CtorArg ^ arg_field_name = yes(ctor_field_name(ArgFieldName, _)),
|
|
UnqualFieldName = unqualify_name(ArgFieldName)
|
|
then
|
|
NamedFieldNumber = CurFieldNumber
|
|
else
|
|
search_for_named_field(CtorArgs, UnqualFieldName,
|
|
CurFieldNumber + 1, NamedFieldNumber)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred create_pure_atomic_unification_with_nonlocals(prog_var::in,
|
|
unify_rhs::in, hlds_goal_info::in, set_of_progvar::in, list(prog_var)::in,
|
|
unify_context::in, hlds_goal::out) is det.
|
|
|
|
create_pure_atomic_unification_with_nonlocals(Var, RHS, OldGoalInfo,
|
|
RestrictNonLocals, VarsList, UnifyContext, Goal) :-
|
|
Context = goal_info_get_context(OldGoalInfo),
|
|
GoalId = goal_info_get_goal_id(OldGoalInfo),
|
|
UnifyContext = unify_context(UnifyMainContext, UnifySubContext),
|
|
create_pure_atomic_complicated_unification(Var, RHS,
|
|
Context, UnifyMainContext, UnifySubContext, Goal0),
|
|
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
|
|
|
|
% Compute the nonlocals of the goal.
|
|
set_of_var.list_to_set(VarsList, NonLocals1),
|
|
set_of_var.intersect(RestrictNonLocals, NonLocals1, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1),
|
|
|
|
% Use the goal id from the original goal, so that the constraint_ids
|
|
% will be as expected. (See the XXX comment near the definition of
|
|
% constraint_id in hlds_data.m for more info.)
|
|
goal_info_set_goal_id(GoalId, GoalInfo1, GoalInfo),
|
|
Goal = hlds_goal(GoalExpr0, GoalInfo).
|
|
|
|
:- pred make_new_vars(list(mer_type)::in, list(prog_var)::out,
|
|
vartypes::in, vartypes::out, prog_varset::in, prog_varset::out) is det.
|
|
|
|
make_new_vars(Types, Vars, !VarTypes, !VarSet) :-
|
|
list.length(Types, NumVars),
|
|
varset.new_vars(NumVars, Vars, !VarSet),
|
|
vartypes_add_corresponding_lists(Vars, Types, !VarTypes).
|
|
|
|
:- pred make_new_var(mer_type::in, prog_var::out, vartypes::in, vartypes::out,
|
|
prog_varset::in, prog_varset::out) is det.
|
|
|
|
make_new_var(Type, Var, !VarTypes, !VarSet) :-
|
|
varset.new_var(Var, !VarSet),
|
|
add_var_type(Var, Type, !VarTypes).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module check_hlds.resolve_unify_functor.
|
|
%---------------------------------------------------------------------------%
|