mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-17 18:33:58 +00:00
307b1dc148
compiler/error_spec.m:
This new module contains the part of the old error_util.m that defines
the error_spec type, and some functions that can help construct pieces
of error_specs. Most modules of the compiler that deal with errors
will need to import only this part of the old error_util.m.
This change also renames the format_component type to format_piece,
which matches our long-standing naming convention for variables containing
(lists of) values of this type.
compiler/write_error_spec.m:
This new module contains the part of the old error_util.m that
writes out error specs, and converts them to strings.
This diff marks as obsolete the versions of predicates that
write out error specs to the current output stream, without
*explicitly* specifying the intended stream.
compiler/error_sort.m:
This new module contains the part of the old error_util.m that
sorts lists of error specs and error msgs.
compiler/error_type_util.m:
This new module contains the part of the old error_util.m that
convert types to format_pieces that generate readable output.
compiler/parse_tree.m:
compiler/notes/compiler_design.html:
Include and document the new modules.
compiler/error_util.m:
The code remaining in the original error_util.m consists of
general utility predicates and functions that don't fit into
any of the modules above.
Delete an unneeded pair of I/O states from the argument list
of a predicate.
compiler/file_util.m:
Move the unable_to_open_file predicate here from error_util.m,
since it belongs here. Mark another predicate that writes
to the current output stream as obsolete.
compiler/hlds_error_util.m:
Mark two predicates that wrote out error_spec to the current output
stream as obsolete, and add versions that take an explicit output stream.
compiler/Mercury.options:
Compile the modules that call the newly obsoleted predicates
with --no-warn-obsolete, for the time being.
compiler/*.m:
Conform to the changes above, mostly by updating import_module
declarations, and renaming format_component to format_piece.
683 lines
29 KiB
Mathematica
683 lines
29 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 parse_tree.
|
|
:- import_module parse_tree.error_spec.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.var_table.
|
|
|
|
:- 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, hlds_goal::out, is_plain_unify::out,
|
|
list(error_spec)::out,
|
|
var_table::in, var_table::out, pred_info::in, pred_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module hlds.hlds_class.
|
|
:- import_module hlds.hlds_cons.
|
|
:- 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 int.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module one_or_more.
|
|
:- import_module require.
|
|
:- import_module term_io.
|
|
:- import_module varset.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
resolve_unify_functor(ModuleInfo, X0, ConsId0, ArgVars0, Mode0,
|
|
Unification0, UnifyContext, GoalInfo0, Goal, IsPlainUnify, Specs,
|
|
!VarTable, !PredInfo) :-
|
|
lookup_var_type(!.VarTable, 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,
|
|
user_arity_pred_form_arity(pf_function,
|
|
user_arity(Arity), PredFormArity),
|
|
Generic = higher_order(FuncVar, Purity, pf_function, PredFormArity),
|
|
HOCall = generic_call(Generic, ArgVars, Modes,
|
|
arg_reg_types_unset, Det),
|
|
Goal = hlds_goal(HOCall, GoalInfo0),
|
|
IsPlainUnify = is_not_plain_unify,
|
|
Specs = []
|
|
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),
|
|
IsFullyQualified = calls_are_fully_qualified(Markers),
|
|
module_info_get_predicate_table(ModuleInfo, PredTable),
|
|
UserArity = user_arity(Arity),
|
|
% This search will usually fail, so do it first.
|
|
predicate_table_lookup_func_sym_arity(PredTable, IsFullyQualified,
|
|
PredName, UserArity, 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_index_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(!.VarTable, 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, SpecsPrime)
|
|
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,
|
|
Specs = SpecsPrime
|
|
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(!.VarTable, 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, SpecsPrime)
|
|
then
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
ProcIds = pred_info_all_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,
|
|
SNA = sym_name_arity(Name, Arity),
|
|
Pieces = [words("Error: reference to"),
|
|
words("undeclared function or predicate"),
|
|
qual_sym_name_arity(SNA), suffix("."), nl],
|
|
Spec = simplest_spec($pred, severity_error, phase_type_check,
|
|
Context, Pieces),
|
|
IsPlainUnify = is_unknown_ref(Spec)
|
|
),
|
|
Specs = SpecsPrime
|
|
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_index_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(!.VarTable, ArgVars0, ArgTypes0),
|
|
not find_matching_constructor(ModuleInfo, TVarSet, ConsId0,
|
|
TypeOfX, ArgTypes0)
|
|
then
|
|
finish_field_access_function(ModuleInfo, AccessType, FieldName,
|
|
UnifyContext, X0, ArgVars0, GoalInfo0, Goal, !VarTable, !PredInfo),
|
|
IsPlainUnify = is_not_plain_unify,
|
|
Specs = []
|
|
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($pred, "encode_escaped_char")
|
|
)
|
|
;
|
|
SymName0 = qualified(_, _),
|
|
unexpected($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($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,
|
|
Specs = []
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% 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(_, _, _, _, MaybeExistConstraints, 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),
|
|
|
|
(
|
|
MaybeExistConstraints = no_exist_constraints,
|
|
ConsExistQVars = []
|
|
;
|
|
MaybeExistConstraints = exist_constraints(
|
|
cons_exist_constraints(ConsExistQVars, _, _, _))
|
|
),
|
|
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, field_access_type::in,
|
|
sym_name::in, unify_context::in, prog_var::in, list(prog_var)::in,
|
|
hlds_goal_info::in, hlds_goal::out,
|
|
var_table::in, var_table::out, pred_info::in, pred_info::out) is det.
|
|
|
|
finish_field_access_function(ModuleInfo, AccessType, FieldName, UnifyContext,
|
|
Var, Args, GoalInfo, Goal, !VarTable, !PredInfo) :-
|
|
(
|
|
AccessType = get,
|
|
field_extraction_function_args(Args, TermVar),
|
|
translate_get_function(ModuleInfo, FieldName, UnifyContext,
|
|
Var, TermVar, GoalInfo, GoalExpr, !VarTable, !PredInfo)
|
|
;
|
|
AccessType = set,
|
|
field_update_function_args(Args, TermInputVar, FieldVar),
|
|
translate_set_function(ModuleInfo, FieldName, UnifyContext,
|
|
FieldVar, TermInputVar, Var, GoalInfo, GoalExpr,
|
|
!VarTable, !PredInfo)
|
|
),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo).
|
|
|
|
:- pred translate_get_function(module_info::in, sym_name::in,
|
|
unify_context::in, prog_var::in, prog_var::in,
|
|
hlds_goal_info::in, hlds_goal_expr::out,
|
|
var_table::in, var_table::out, pred_info::in, pred_info::out) is det.
|
|
|
|
translate_get_function(ModuleInfo, FieldName, UnifyContext,
|
|
FieldVar, TermInputVar, OldGoalInfo, GoalExpr, !VarTable, !PredInfo) :-
|
|
lookup_var_type(!.VarTable, 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(!.VarTable, 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(ModuleInfo, TypesBeforeField, VarsBeforeField, !VarTable),
|
|
make_new_vars(ModuleInfo, TypesAfterField, VarsAfterField, !VarTable),
|
|
|
|
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,
|
|
sym_name::in, unify_context::in, prog_var::in, prog_var::in, prog_var::in,
|
|
hlds_goal_info::in, hlds_goal_expr::out,
|
|
var_table::in, var_table::out, pred_info::in, pred_info::out) is det.
|
|
|
|
translate_set_function(ModuleInfo, FieldName, UnifyContext,
|
|
FieldVar, TermInputVar, TermOutputVar, OldGoalInfo, Goal,
|
|
!VarTable, !PredInfo) :-
|
|
lookup_var_type(!.VarTable, 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(ModuleInfo, TypesBeforeField, VarsBeforeField, !VarTable),
|
|
make_new_var(ModuleInfo, TermFieldType, SingletonFieldVar, !VarTable),
|
|
make_new_vars(ModuleInfo, TypesAfterField, VarsAfterField, !VarTable),
|
|
|
|
% 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($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, _, MaybeExistConstraints,
|
|
ConsArgs, _),
|
|
ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgs),
|
|
|
|
(
|
|
MaybeExistConstraints = no_exist_constraints,
|
|
ActualArgTypes0 = ConsArgTypes,
|
|
ActualExistQVars = []
|
|
;
|
|
MaybeExistConstraints = exist_constraints(ExistConstraints),
|
|
ExistConstraints = cons_exist_constraints(ConsExistQVars,
|
|
ConsConstraints, _UnconstrainedExistQVars, _ConstrainedExistQVars),
|
|
% 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($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($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($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(type_body_du(Ctors, _, _, _, _)),
|
|
FieldName = unqualify_name(FieldSymName),
|
|
get_constructor_containing_field_loop(TermTypeCtor,
|
|
one_or_more_to_list(Ctors), FieldName, ConsId, FieldNumber)
|
|
;
|
|
( TermTypeBody = hlds_eqv_type(_)
|
|
; TermTypeBody = hlds_foreign_type(_)
|
|
; TermTypeBody = hlds_solver_type(_)
|
|
; TermTypeBody = hlds_abstract_type(_)
|
|
),
|
|
unexpected($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($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(module_info::in, list(mer_type)::in, list(prog_var)::out,
|
|
var_table::in, var_table::out) is det.
|
|
|
|
make_new_vars(ModuleInfo, Types, Vars, !VarTable) :-
|
|
list.map_foldl(make_new_var(ModuleInfo), Types, Vars, !VarTable).
|
|
|
|
:- pred make_new_var(module_info::in, mer_type::in, prog_var::out,
|
|
var_table::in, var_table::out) is det.
|
|
|
|
make_new_var(ModuleInfo, Type, Var, !VarTable) :-
|
|
IsDummy = is_type_a_dummy(ModuleInfo, Type),
|
|
Entry = vte("", Type, IsDummy),
|
|
add_var_entry(Entry, Var, !VarTable).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module check_hlds.resolve_unify_functor.
|
|
%---------------------------------------------------------------------------%
|