mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-15 09:23:44 +00:00
Code Issues Projects Releases Wiki Activity
Files
8ece998041d040a4aabb24afe00a0e35bf369473
mercury/compiler/polymorphism_goal.m
Zoltan Somogyi 44d1f0db9c Give some predicates shorter names. 
compiler/prog_type_subst.m:
compiler/type_util.m:
    Apply s/apply_variable_renaming_to_/apply_renaming_to_/ and
    s/_to_x_list/_to_xs/ to the names of predicate.

    Conform to the change in hlds_class.m below.

compiler/hlds_class.m:
    This module used to define types named (a) hlds_constraint, and
    (b) hlds_constraints, and the latter was NOT a list of items
    of type hlds_constraint. Rename the latter to hlds_constraint_db
    to free up the name apply_renaming_to_constraints to apply
    to list(hlds_constraint). However, the rename also makes code
    operating on hlds_constraint_dbs easier to understand. Before
    this diff, several modules used variables named Constraints
    to refer to a list(hlds_constraint) in some places and to
    what is now a hlds_constraint_db in other places, which is confusing;
    the latter are now named ConstraintDb.

compiler/type_assign.m:
    Conform to the changes above.

    Add an XXX about some existing variable names that *look* right
    but turn out to be subtly misleading.

compiler/add_pragma_type_spec.m:
compiler/add_type.m:
compiler/check_typeclass.m:
compiler/comp_unit_interface.m:
compiler/cse_detection.m:
compiler/ctgc.util.m:
compiler/decide_type_repn.m:
compiler/deforest.m:
compiler/equiv_type.m:
compiler/equiv_type_hlds.m:
compiler/higher_order.higher_order_global_info.m:
compiler/higher_order.make_specialized_preds.m:
compiler/higher_order.specialize_calls.m:
compiler/hlds_rtti.m:
compiler/inlining.m:
compiler/modecheck_coerce.m:
compiler/old_type_constraints.m:
compiler/polymorphism_clause.m:
compiler/polymorphism_goal.m:
compiler/polymorphism_type_class_info.m:
compiler/prog_type_unify.m:
compiler/qual_info.m:
compiler/recompilation.version.m:
compiler/resolve_unify_functor.m:
compiler/typecheck.m:
compiler/typecheck_clauses.m:
compiler/typecheck_cons_infos.m:
compiler/typecheck_debug.m:
compiler/typecheck_error_type_assign.m:
compiler/typecheck_errors.m:
compiler/typecheck_unify_var_functor.m:
compiler/typecheck_util.m:
compiler/typeclasses.m:
compiler/unify_proc.m:
compiler/var_table.m:
compiler/vartypes.m:
    Conform to the changes above.
2025-10-21 18:21:35 +11:00

1309 lines
59 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1995-2012 The University of Melbourne.
% Copyright (C) 2014-2015, 2022-2025 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: polymorphism_clause.m.
% Main authors: fjh and zs.
%
% This module handles the part of the polymorphism transformation
% that involves transforming the bodies of clauses. That transformation
% is described by the comment at the top of polymorphism.m.
%---------------------------------------------------------------------------%
:- module check_hlds.polymorphism_goal.
:- interface.
:- import_module check_hlds.polymorphism_info.
:- import_module hlds.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_rtti.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- pred polymorphism_process_goal(hlds_goal::in, hlds_goal::out,
poly_info::in, poly_info::out) is det.
% Add the type_info variables for a complicated unification to
% the appropriate fields in the unification and the goal_info.
%
% Exported for modecheck_unify.m.
%
:- pred unification_typeinfos_rtti_varmaps(mer_type::in, rtti_varmaps::in,
unification::in, unification::out, hlds_goal_info::in, hlds_goal_info::out)
is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module check_hlds.polymorphism_lambda.
:- import_module check_hlds.polymorphism_type_class_info.
:- import_module check_hlds.polymorphism_type_info.
:- import_module hlds.const_struct.
:- import_module hlds.from_ground_term_util.
:- import_module hlds.goal_util.
:- import_module hlds.goal_vars.
:- import_module hlds.hlds_class.
:- import_module hlds.hlds_markers.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module hlds.quantification.
:- import_module hlds.type_util.
:- import_module libs.
:- import_module libs.globals.
:- import_module libs.optimization_options.
:- import_module mdbcomp.
:- import_module mdbcomp.goal_path.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.maybe_error.
:- import_module parse_tree.prog_data_foreign.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_scan.
:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_type_test.
:- import_module parse_tree.prog_type_unify.
:- import_module parse_tree.set_of_var.
:- import_module parse_tree.var_table.
:- import_module assoc_list.
:- import_module bool.
:- import_module int.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module string.
:- import_module term_context.
:- import_module varset.
%---------------------------------------------------------------------------%
polymorphism_process_goal(Goal0, Goal, !Info) :-
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
(
GoalExpr0 = unify(LHSVar, RHS, Mode, Unification, UnifyContext),
polymorphism_process_unify(LHSVar, RHS, Mode, Unification,
UnifyContext, GoalInfo0, Goal, !Info)
;
GoalExpr0 = plain_call(PredId, _, ArgVars0, _, _, _),
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
ExtraVars, ExtraGoals, !Info),
ArgVars = ExtraVars ++ ArgVars0,
CallExpr = GoalExpr0 ^ call_args := ArgVars,
Call = hlds_goal(CallExpr, GoalInfo),
GoalList = ExtraGoals ++ [Call],
conj_list_to_goal(GoalList, GoalInfo0, Goal)
;
GoalExpr0 = call_foreign_proc(_, PredId, _, _, _, _, _),
poly_info_get_module_info(!.Info, ModuleInfo),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
PredModule = pred_info_module(PredInfo),
PredName = pred_info_name(PredInfo),
pred_info_get_orig_arity(PredInfo, pred_form_arity(PredFormArityInt)),
( if no_type_info_builtin(PredModule, PredName, PredFormArityInt) then
Goal = Goal0
else
polymorphism_process_foreign_proc(PredInfo, GoalExpr0, GoalInfo0,
Goal, !Info)
)
;
% We don't need to add type_infos for higher order calls, since the
% type_infos are added when the closures are constructed, not when
% they are called.
GoalExpr0 = generic_call(_, _, _, _, _),
Goal = Goal0
;
% The rest of the cases just process goals recursively.
(
GoalExpr0 = conj(ConjType, Goals0),
(
ConjType = plain_conj,
polymorphism_process_plain_conj(Goals0, Goals, !Info)
;
ConjType = parallel_conj,
get_cache_maps_snapshot("parconj", InitialSnapshot, !Info),
polymorphism_process_par_conj(Goals0, Goals, InitialSnapshot,
!Info)
% Unlike with disjunctions, we do not have to reset to
% InitialSnapshot.
%
% The reason why we take InitialSnapshot is to prevent
% each conjunct from depending on e.g. type_info vars
% generated by earlier conjuncts. However, the code
% following the parallel conjunction as a whole
% *may* rely on the changes to the varmaps made by the
% last conjunct. (In fact, it could rely on the changes
% made by any conjunct, but we throw away the changes
% made by all conjuncts except the last.
),
GoalExpr = conj(ConjType, Goals)
;
GoalExpr0 = disj(Goals0),
get_cache_maps_snapshot("disj", InitialSnapshot, !Info),
polymorphism_process_disj(Goals0, Goals, InitialSnapshot, !Info),
set_cache_maps_snapshot("after disj", InitialSnapshot, !Info),
GoalExpr = disj(Goals)
;
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
get_cache_maps_snapshot("ite", InitialSnapshot, !Info),
polymorphism_process_goal(Cond0, Cond, !Info),
% If we allowed a type_info created inside Cond to be reused
% in Then, then we are adding an output variable to Cond.
% If Cond scope had no outputs to begin with, this would change
% its determinism.
set_cache_maps_snapshot("before then", InitialSnapshot, !Info),
polymorphism_process_goal(Then0, Then, !Info),
set_cache_maps_snapshot("before else", InitialSnapshot, !Info),
polymorphism_process_goal(Else0, Else, !Info),
set_cache_maps_snapshot("after ite", InitialSnapshot, !Info),
GoalExpr = if_then_else(Vars, Cond, Then, Else)
;
GoalExpr0 = negation(SubGoal0),
get_cache_maps_snapshot("neg", InitialSnapshot, !Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
set_cache_maps_snapshot("after neg", InitialSnapshot, !Info),
GoalExpr = negation(SubGoal)
;
GoalExpr0 = switch(Var, CanFail, Cases0),
get_cache_maps_snapshot("switch", InitialSnapshot, !Info),
polymorphism_process_cases(Cases0, Cases, InitialSnapshot, !Info),
set_cache_maps_snapshot("after switch", InitialSnapshot, !Info),
GoalExpr = switch(Var, CanFail, Cases)
;
GoalExpr0 = scope(Reason0, SubGoal0),
(
Reason0 = from_ground_term(TermVar, Kind),
(
Kind = from_ground_term_initial,
polymorphism_process_from_ground_term_initial(TermVar,
GoalInfo0, SubGoal0, GoalExpr, !Info)
;
( Kind = from_ground_term_construct
; Kind = from_ground_term_deconstruct
; Kind = from_ground_term_other
),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
GoalExpr = scope(Reason0, SubGoal)
)
;
Reason0 = promise_solutions(_, _),
% polymorphism_process_goal may cause SubGoal to bind
% variables (such as PolyConst variables) that SubGoal0 does
% not bind. If we allowed such variables to be reused outside
% the scope, that would change the set of variables that the
% promise would have to cover. We cannot expect and do not want
% user level programmers making promises about variables added
% by the compiler.
get_cache_maps_snapshot("promise_solns", InitialSnapshot,
!Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
set_cache_maps_snapshot("after promise_solns", InitialSnapshot,
!Info),
GoalExpr = scope(Reason0, SubGoal)
;
( Reason0 = disable_warnings(_, _)
; Reason0 = promise_purity(_)
; Reason0 = require_detism(_)
; Reason0 = require_complete_switch(_)
; Reason0 = require_switch_arms_detism(_, _)
; Reason0 = commit(_)
; Reason0 = barrier(_)
; Reason0 = loop_control(_, _, _)
),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
GoalExpr = scope(Reason0, SubGoal)
;
Reason0 = exist_quant(_, _),
% If we allowed a type_info created inside SubGoal to be reused
% outside GoalExpr, then we are adding an output variable to
% the scope. If the scope had no outputs to begin with, this
% would change the determinism of the scope.
%
% However, using a type_info from before the scope in SubGoal
% is perfectly ok.
get_cache_maps_snapshot("exists", InitialSnapshot, !Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
set_cache_maps_snapshot("after exists", InitialSnapshot,
!Info),
GoalExpr = scope(Reason0, SubGoal)
;
Reason0 = trace_goal(_, _, _, _, _),
% Trace goal scopes will be deleted after semantic analysis
% if their compile-time condition turns out to be false.
% If we let later code use type_infos introduced inside the
% scope, the deletion of the scope would leave those variables
% undefined.
%
% We *could* evaluate the compile-time condition here to know
% whether the deletion will happen or not, but doing so would
% require breaching the separation between compiler passes.
get_cache_maps_snapshot("trace", InitialSnapshot, !Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
set_cache_maps_snapshot("after trace", InitialSnapshot, !Info),
GoalExpr = scope(Reason0, SubGoal)
)
),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
GoalExpr0 = shorthand(ShortHand0),
(
ShortHand0 = atomic_goal(GoalType, Outer, Inner, Vars,
MainGoal0, OrElseGoals0, OrElseInners),
get_cache_maps_snapshot("atomic", InitialSnapshot, !Info),
polymorphism_process_goal(MainGoal0, MainGoal, !Info),
polymorphism_process_disj(OrElseGoals0, OrElseGoals,
InitialSnapshot, !Info),
set_cache_maps_snapshot("after atomic", InitialSnapshot, !Info),
ShortHand = atomic_goal(GoalType, Outer, Inner, Vars,
MainGoal, OrElseGoals, OrElseInners)
;
ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0),
% We don't let the code inside and outside the try goal share
% type_info variables for the same reason as with lambda
% expressions; because those pieces of code will end up
% in different procedures. However, for try goals, this is true
% even for the first and second conjuncts.
get_cache_maps_snapshot("try", InitialSnapshot, !Info),
( if
SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo),
SubGoalExpr0 = conj(plain_conj, Conjuncts0),
Conjuncts0 = [ConjunctA0, ConjunctB0]
then
empty_cache_maps(!Info),
polymorphism_process_goal(ConjunctA0, ConjunctA, !Info),
empty_cache_maps(!Info),
polymorphism_process_goal(ConjunctB0, ConjunctB, !Info),
Conjuncts = [ConjunctA, ConjunctB],
SubGoalExpr = conj(plain_conj, Conjuncts),
SubGoal = hlds_goal(SubGoalExpr, SubGoalInfo)
else
unexpected($pred, "malformed try goal")
),
set_cache_maps_snapshot("after try", InitialSnapshot, !Info),
ShortHand = try_goal(MaybeIO, ResultVar, SubGoal)
;
ShortHand0 = bi_implication(_, _),
unexpected($pred, "bi_implication")
),
GoalExpr = shorthand(ShortHand),
Goal = hlds_goal(GoalExpr, GoalInfo0)
).
%---------------------------------------------------------------------------%
%
% Process unifications.
%
:- pred polymorphism_process_unify(prog_var::in, unify_rhs::in,
unify_mode::in, unification::in, unify_context::in, hlds_goal_info::in,
hlds_goal::out, poly_info::in, poly_info::out) is det.
polymorphism_process_unify(LHSVar, RHS0, Mode, Unification0, UnifyContext,
GoalInfo0, Goal, !Info) :-
(
RHS0 = rhs_var(_RHSVar),
% Var-var unifications (simple_test, assign, or complicated_unify)
% are basically left unchanged. Complicated unifications will
% eventually get converted into calls, but that is done later on,
% by simplify.m, not now. At this point we just need to figure out
% which type_info/typeclass_info variables the unification might need,
% and insert them in the nonlocals. We have to do that for all var-var
% unifications, because at this point we haven't done mode analysis so
% we don't know which ones will become complicated_unifies.
% Note that we also store the type_info/typeclass_info variables
% in a field in the unification, which quantification.m uses when
% requantifying things.
poly_info_get_var_table(!.Info, VarTable),
lookup_var_type(VarTable, LHSVar, Type),
unification_typeinfos(Type, Unification0, Unification,
GoalInfo0, GoalInfo, _Changed, !Info),
Goal = hlds_goal(unify(LHSVar, RHS0, Mode, Unification, UnifyContext),
GoalInfo)
;
RHS0 = rhs_functor(ConsId, _, Args),
polymorphism_process_unify_functor(LHSVar, ConsId, Args, Mode,
Unification0, UnifyContext, GoalInfo0, Goal, _Changed, !Info)
;
RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc,
LambdaNonLocals0, ArgVarsModes, Det, LambdaGoal0),
% For lambda expressions, we must recursively traverse the lambda goal.
% Any type_info variables needed by the lambda goal are created in the
% lambda goal (not imported from the outside), and any type_info
% variables created by the lambda goal are not available outside.
% This is because, after lambda expansion, the code inside and outside
% the lambda goal will end up in different procedures.
get_cache_maps_snapshot("lambda", InitialSnapshot, !Info),
empty_cache_maps(!Info),
polymorphism_process_goal(LambdaGoal0, LambdaGoal1, !Info),
set_cache_maps_snapshot("after lambda", InitialSnapshot, !Info),
assoc_list.keys(ArgVarsModes, ArgVars),
% Currently we don't allow lambda goals to be existentially typed.
ExistQVars = [],
requantify_lambda_goal(LambdaNonLocals0, ArgVars,
ExistQVars, LambdaGoal1, LambdaGoal,
LambdaTiTciVars, PossibleNonLocalTiTciVars, !Info),
LambdaNonLocals1 =
set_of_var.to_sorted_list(LambdaTiTciVars) ++
set_of_var.to_sorted_list(PossibleNonLocalTiTciVars) ++
LambdaNonLocals0,
list.sort_and_remove_dups(LambdaNonLocals1, LambdaNonLocals),
RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc,
LambdaNonLocals, ArgVarsModes, Det, LambdaGoal),
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
set_of_var.union(PossibleNonLocalTiTciVars, NonLocals0, NonLocals),
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
% Complicated (in-in) argument unifications are impossible for lambda
% expressions, so we don't need to worry about adding the type_infos
% that would be required for such unifications.
GoalExpr = unify(LHSVar, RHS, Mode, Unification0, UnifyContext),
Goal = hlds_goal(GoalExpr, GoalInfo)
).
%---------------------%
:- pred unification_typeinfos(mer_type::in,
unification::in, unification::out, hlds_goal_info::in, hlds_goal_info::out,
bool::out, poly_info::in, poly_info::out) is det.
unification_typeinfos(Type, !Unification, !GoalInfo, Changed, !Info) :-
% Compute the type_info/type_class_info variables that would be used
% if this unification ends up being a complicated_unify.
type_vars_in_type(Type, TypeVars),
(
TypeVars = [],
Changed = no
;
TypeVars = [_ | _],
list.map_foldl(poly_get_type_info_locn, TypeVars, TypeInfoLocns,
!Info),
add_unification_typeinfos(TypeInfoLocns, !Unification, !GoalInfo),
Changed = yes
).
unification_typeinfos_rtti_varmaps(Type, RttiVarMaps,
!Unification, !GoalInfo) :-
% This variant is for use by modecheck_unify.m. During mode checking,
% all the type_infos should appear in the type_info_varmap.
% Compute the type_info/type_class_info variables that would be used
% if this unification ends up being a complicated_unify.
type_vars_in_type(Type, TypeVars),
list.map(rtti_lookup_type_info_locn(RttiVarMaps), TypeVars, TypeInfoLocns),
add_unification_typeinfos(TypeInfoLocns, !Unification, !GoalInfo).
:- pred add_unification_typeinfos(list(type_info_locn)::in,
unification::in, unification::out,
hlds_goal_info::in, hlds_goal_info::out) is det.
add_unification_typeinfos(TypeInfoLocns, !Unification, !GoalInfo) :-
list.map(type_info_locn_var, TypeInfoLocns, TypeInfoVars0),
list.remove_dups(TypeInfoVars0, TypeInfoVars),
% Insert the TypeInfoVars into the nonlocals field of the goal_info
% for the unification goal.
NonLocals0 = goal_info_get_nonlocals(!.GoalInfo),
set_of_var.insert_list(TypeInfoVars, NonLocals0, NonLocals),
goal_info_set_nonlocals(NonLocals, !GoalInfo),
% Also save those type_info vars into a field in the complicated_unify,
% so that quantification.m can recompute variable scopes properly.
% This field is also used by modecheck_unify.m -- for complicated
% unifications, it checks that all these variables are ground.
(
!.Unification = complicated_unify(Modes, CanFail, _),
!:Unification = complicated_unify(Modes, CanFail, TypeInfoVars)
;
% This can happen if an earlier stage of compilation has already
% determined that this unification is particular kind of unification.
% In that case, the type_info vars won't be needed.
( !.Unification = construct(_, _, _, _, _, _, _)
; !.Unification = deconstruct(_, _, _, _, _, _)
; !.Unification = assign(_, _)
; !.Unification = simple_test(_, _)
)
).
%---------------------%
:- pred polymorphism_process_unify_functor(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, bool::out,
poly_info::in, poly_info::out) is det.
polymorphism_process_unify_functor(X0, ConsId0, ArgVars0, Mode0, Unification0,
UnifyContext, GoalInfo0, Goal, Changed, !Info) :-
poly_info_get_module_info(!.Info, ModuleInfo0),
poly_info_get_var_table(!.Info, VarTable0),
lookup_var_type(VarTable0, X0, TypeOfX),
list.length(ArgVars0, Arity),
% We replace any unifications with higher order pred constants
% by lambda expressions. For example, we replace
%
% X = list.append(Y) % Y::in, X::out
%
% with
%
% X = (
% pred(A1::in, A2::out) is ... :- list.append(Y, A1, A2)
% )
%
% We do this because it makes two things easier. First, mode analysis
% needs to check that the lambda goal doesn't bind any nonlocal variables
% (e.g. `Y' in above example). This would require a bit of moderately
% tricky special case code if we didn't expand them here. Second, this pass
% (polymorphism.m) is a lot easier if we don't have to handle higher order
% constants. If it turns out that the predicate was nonpolymorphic,
% lambda.m will turn the lambda expression back into a higher order
% constant again.
%
% Note that this transformation is also done by modecheck_unify.m, in case
% we are rerunning mode analysis after lambda.m has already been run;
% any changes to the code here will also need to be duplicated there.
( if
% Check if variable has a higher order type.
ConsId0 = closure_cons(ShroudedPredProcId),
proc(PredId, ProcId0) = unshroud_pred_proc_id(ShroudedPredProcId),
type_is_higher_order_details(TypeOfX, Purity, _PredOrFunc,
CalleeArgTypes)
then
% An `invalid_proc_id' means the predicate is multi-moded. We can't
% pick the right mode yet. Perform the rest of the transformation with
% any mode (the first) but mark the goal with a feature so that mode
% checking knows to fix it up later.
( if ProcId0 = invalid_proc_id then
module_info_pred_info(ModuleInfo0, PredId, PredInfo),
ProcIds = pred_info_all_procids(PredInfo),
(
ProcIds = [ProcId | _],
goal_info_add_feature(feature_lambda_undetermined_mode,
GoalInfo0, GoalInfo1)
;
ProcIds = [],
unexpected($pred, "no modes")
)
else
ProcId = ProcId0,
GoalInfo1 = GoalInfo0
),
% Convert the higher order pred term to a lambda goal.
Context = goal_info_get_context(GoalInfo0),
convert_pred_to_lambda_goal(ModuleInfo0, Purity, X0, PredId, ProcId,
ArgVars0, CalleeArgTypes, UnifyContext,
GoalInfo1, Context, MaybeRHS0, VarTable0, VarTable),
poly_info_set_var_table(VarTable, !Info),
(
MaybeRHS0 = ok1(RHS0),
% Process the unification in its new form.
polymorphism_process_unify(X0, RHS0, Mode0, Unification0,
UnifyContext, GoalInfo1, Goal, !Info)
;
MaybeRHS0 = error1(Specs),
poly_info_get_errors(!.Info, Specs0),
poly_info_set_errors(Specs ++ Specs0, !Info),
% It doesn't matter what Goal we return, since it won't be used.
RHS = rhs_functor(some_int_const(int_const(42)),
is_not_exist_constr, []),
polymorphism_process_unify(X0, RHS, Mode0, Unification0,
UnifyContext, GoalInfo1, Goal, !Info)
),
Changed = yes
else if
% Is this a construction or deconstruction of an existentially
% typed data type?
%
% Check whether the functor had a "new " prefix.
% If so, assume it is a construction, and strip off the prefix.
% Otherwise, assume it is a deconstruction.
ConsId0 = du_data_ctor(DuCtor0),
DuCtor0 = du_ctor(Functor0, Arity, ConsTypeCtor),
( if remove_new_prefix(Functor0, OrigFunctor) then
DuCtor = du_ctor(OrigFunctor, Arity, ConsTypeCtor),
ConsId = du_data_ctor(DuCtor),
IsExistConstr = is_exist_constr
else
ConsId = ConsId0,
DuCtor = DuCtor0,
IsExistConstr = is_not_exist_constr
),
% Check whether the functor (with the "new " prefix removed)
% is an existentially typed functor.
type_util.get_existq_cons_defn(ModuleInfo0, TypeOfX,
DuCtor, ConsDefn)
then
% Add extra arguments to the unification for the
% type_info and/or type_class_info variables.
lookup_var_types(VarTable0, ArgVars0, ActualArgTypes),
polymorphism_process_existq_unify_functor(ConsDefn,
IsExistConstr, ActualArgTypes, TypeOfX, GoalInfo0,
ExtraVars, ExtraGoals, !Info),
ArgVars = ExtraVars ++ ArgVars0,
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
set_of_var.insert_list(ExtraVars, NonLocals0, NonLocals),
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1),
% Some of the argument unifications may be complicated unifications,
% which may need type_infos.
unification_typeinfos(TypeOfX, Unification0, Unification,
GoalInfo1, GoalInfo, _Changed, !Info),
UnifyExpr = unify(X0, rhs_functor(ConsId, IsExistConstr, ArgVars),
Mode0, Unification, UnifyContext),
Unify = hlds_goal(UnifyExpr, GoalInfo),
GoalList = ExtraGoals ++ [Unify],
conj_list_to_goal(GoalList, GoalInfo0, Goal),
Changed = yes
else
% We leave construction/deconstruction unifications alone.
% Some of the argument unifications may be complicated unifications,
% which may need type_infos.
% XXX Return original Goal0 if Changed = no.
unification_typeinfos(TypeOfX, Unification0, Unification,
GoalInfo0, GoalInfo, Changed, !Info),
RHS = rhs_functor(ConsId0, is_not_exist_constr, ArgVars0),
GoalExpr = unify(X0, RHS, Mode0, Unification, UnifyContext),
Goal = hlds_goal(GoalExpr, GoalInfo)
).
%---------------------%
% Compute the extra arguments that we need to add to a unification with
% an existentially quantified data constructor.
%
:- pred polymorphism_process_existq_unify_functor(ctor_defn::in,
is_exist_constr::in, list(mer_type)::in, mer_type::in,
hlds_goal_info::in, list(prog_var)::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
polymorphism_process_existq_unify_functor(CtorDefn, IsExistConstr,
ActualArgTypes, ActualRetType, GoalInfo,
ExtraVars, ExtraGoals, !Info) :-
CtorDefn = ctor_defn(CtorTypeVarSet, CtorKindMap,
CtorMaybeExistConstraints, CtorArgTypes, CtorRetType),
% Rename apart the type variables in the constructor definition.
poly_info_get_typevarset(!.Info, TypeVarSet0),
tvarset_merge_renaming(TypeVarSet0, CtorTypeVarSet, TypeVarSet,
CtorToParentRenaming),
(
CtorMaybeExistConstraints = exist_constraints(CtorExistConstraints),
% XXX Could we use _Ctor{Unc,C}onstrainedExistQVars to avoid
% some of the work below?
CtorExistConstraints = cons_exist_constraints(CtorExistQVars,
CtorExistentialConstraints,
_CtorUnconstrainedExistQVars, _CtorConstrainedExistQVars),
apply_renaming_to_tvars(CtorToParentRenaming,
CtorExistQVars, ParentExistQVars),
apply_renaming_to_prog_constraints(CtorToParentRenaming,
CtorExistentialConstraints, ParentExistentialConstraints),
list.length(ParentExistentialConstraints, NumExistentialConstraints),
% Compute the set of _unconstrained_ existentially quantified type
% variables, and then apply the type bindings to those type variables
% to figure out what types they are bound to.
constraint_list_get_tvars(ParentExistentialConstraints,
ParentExistConstrainedTVars),
list.delete_elems(ParentExistQVars, ParentExistConstrainedTVars,
ParentUnconstrainedExistQVars),
apply_rec_subst_to_tvars(ParentKindMap, ParentToActualTypeSubst,
ParentUnconstrainedExistQVars, ActualExistentialTypes)
;
CtorMaybeExistConstraints = no_exist_constraints,
NumExistentialConstraints = 0,
ActualExistentialTypes = []
),
apply_renaming_to_tvar_kind_map(CtorToParentRenaming,
CtorKindMap, ParentKindMap),
apply_renaming_to_types(CtorToParentRenaming,
CtorArgTypes, ParentArgTypes),
apply_renaming_to_type(CtorToParentRenaming, CtorRetType, ParentRetType),
poly_info_set_typevarset(TypeVarSet, !Info),
% Compute the type bindings resulting from the functor's actual argument
% and return types. These are the ones that might bind the ExistQVars.
type_list_subsumes_det([ParentRetType | ParentArgTypes],
[ActualRetType | ActualArgTypes], ParentToActualTypeSubst),
% Create type_class_info variables for the type class constraints.
poly_info_get_constraint_map(!.Info, ConstraintMap),
GoalId = goal_info_get_goal_id(GoalInfo),
Context = goal_info_get_context(GoalInfo),
(
IsExistConstr = is_exist_constr,
% Assume it is a construction.
lookup_hlds_constraint_list(ConstraintMap, unproven, GoalId,
NumExistentialConstraints, ActualExistentialConstraints),
make_typeclass_info_vars(ActualExistentialConstraints, [], Context,
ExtraTypeClassVarsMCAs, ExtraTypeClassGoals, !Info),
assoc_list.keys(ExtraTypeClassVarsMCAs, ExtraTypeClassVars)
;
IsExistConstr = is_not_exist_constr,
% Assume it is a deconstruction.
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
NumExistentialConstraints, ActualExistentialConstraints),
make_existq_typeclass_info_vars(ActualExistentialConstraints, Context,
ExtraTypeClassVars, ExtraTypeClassGoals, !Info)
),
% Create type_info variables for the _unconstrained_ existentially
% quantified type variables.
polymorphism_do_make_type_info_vars(ActualExistentialTypes, Context,
ExtraTypeInfoVarsMCAs, ExtraTypeInfoGoals, !Info),
assoc_list.keys(ExtraTypeInfoVarsMCAs, ExtraTypeInfoVars),
% The type_class_info variables go AFTER the type_info variables
% (for consistency with the order for argument passing,
% and because the RTTI support in the runtime system relies on it)
ExtraGoals = ExtraTypeInfoGoals ++ ExtraTypeClassGoals,
ExtraVars = ExtraTypeInfoVars ++ ExtraTypeClassVars.
%---------------------%
% If the lambda goal we are processing is polymorphically typed, we may
% need to fix up the quantification (nonlocal variables) so that it
% includes the type_info variables and typeclass_info variables for
% any polymorphically typed variables in the nonlocals set or in the
% arguments (either the lambda vars or the implicit curried argument
% variables). We return this set of LambdaTiTciVars. Including typeinfos
% for arguments which are not in the nonlocals set of the lambda goal,
% i.e. unused arguments, is necessary only if typeinfo_liveness is set,
% but we do it always, since we don't have the options available here,
% and the since cost is pretty minimal.
%
% We also need to include in the nonlocals set of the lambda expression
% any type_info and/or typeclass_info variables we have added to the
% goal inside the lambda. In rare cases such as tests/valid/gh98.m,
% a typeclass_info that we inserted into the goal inside the lambda
% is defined outside the lambda *without* being in LambdaTiTciVars.
% We therefore return all type_info/typeclass_info variables that occur
% in the transformed lambda goal in AllTiTciGoalVars, for our caller
% to likewise include in the nonlocals set of the lambda goal.
%
:- pred requantify_lambda_goal(list(prog_var)::in,
list(prog_var)::in, existq_tvars::in, hlds_goal::in, hlds_goal::out,
set_of_progvar::out, set_of_progvar::out,
poly_info::in, poly_info::out) is det.
requantify_lambda_goal(LambdaNonLocals0, ArgVars, ExistQVars, !Goal,
LambdaTiTciVars, AllTiTciGoalVars, !Info) :-
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
( if rtti_varmaps_no_tvars(RttiVarMaps0) then
set_of_var.init(LambdaTiTciVars),
set_of_var.init(AllTiTciGoalVars)
else
poly_info_get_var_table(!.Info, VarTable0),
!.Goal = hlds_goal(_, GoalInfo0),
NonLocals = goal_info_get_nonlocals(GoalInfo0),
set_of_var.insert_list(LambdaNonLocals0, NonLocals, BothNonLocals),
set_of_var.insert_list(ArgVars, BothNonLocals, NonLocalsWithArgVars),
goal_util.extra_nonlocal_typeinfos_typeclass_infos(RttiVarMaps0,
VarTable0, ExistQVars, NonLocalsWithArgVars, LambdaTiTciVars),
vars_in_goal(!.Goal, GoalVars),
IsTiOrTci =
( pred(Var::in) is semidet :-
lookup_var_type(VarTable0, Var, VarType),
( VarType = type_info_type
; VarType = typeclass_info_type
)
),
set_of_var.filter(IsTiOrTci, GoalVars, AllTiTciGoalVars),
% Our caller will include AllTiTciGoalVars in the nonlocals set
% of the rhs_lambda_goal, since some of them may actually come
% from code outside the lambda. However, since some (or even all)
% of the variables in this set may actually be local, we insist
% on the *whole* procedure body, not just the code of this lambda,
% being requantified once its polymorphism transformation has been
% completed. (This works both for variables in AllTiTciGoalVars
% that were added by polymorphism, and those which were there before.)
%
% Note that all the variables added by the polymorphism transformation
% of !Goal that may be nonlocal are type_infos and typeclass_infos.
% The polymorphism transformation can also add integer variables
% for use in e.g. getting a type_info out of a particular slot
% of a typeclass_info, but we set the set of cached int vars
% in the poly_info to empty at the start of transformation of !Goal,
% and throw away the updated caches at its end, so any integer vars
% created by the transformation inside !:Goal will be local to !:Goal.
poly_info_set_must_requantify(!Info),
set_of_var.union(NonLocalsWithArgVars, AllTiTciGoalVars,
PossibleOutsideVars),
implicitly_quantify_goal_general(ord_nl_maybe_lambda,
PossibleOutsideVars, _Warnings, !Goal,
VarTable0, VarTable, RttiVarMaps0, RttiVarMaps),
poly_info_set_var_table_rtti(VarTable, RttiVarMaps, !Info)
).
%---------------------------------------------------------------------------%
%
% Process plain calls.
%
% XXX document me
%
% XXX the following code ought to be rewritten to handle
% existential/universal type_infos and type_class_infos
% in a more consistent manner.
%
:- pred polymorphism_process_call(pred_id::in, list(prog_var)::in,
hlds_goal_info::in, hlds_goal_info::out,
list(prog_var)::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
ExtraVars, ExtraGoals, !Info) :-
poly_info_get_var_table(!.Info, VarTable),
poly_info_get_typevarset(!.Info, TypeVarSet0),
poly_info_get_module_info(!.Info, ModuleInfo),
% The order of the added variables is important, and must match the
% order specified at the top of this file.
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_get_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
PredArgTypes),
pred_info_get_tvar_kind_map(PredInfo, PredKindMap),
pred_info_get_class_context(PredInfo, PredClassContext),
% VarTable, TypeVarSet* etc come from the caller.
% PredTypeVarSet, PredArgTypes, PredExistQVars, etc come
% directly from the callee.
% ParentArgTypes, ParentExistQVars etc come from a version
% of the callee that has been renamed apart from the caller.
%
% The difference between e.g. PredArgTypes and ParentArgTypes is the
% application of PredToParentTypeRenaming, which maps the type variables
% in the callee to new type variables in the caller. Adding the new type
% variables to TypeVarSet0 yields TypeVarSet.
( if varset.is_empty(PredTypeVarSet) then
% Optimize a common case.
map.init(PredToParentTypeRenaming),
TypeVarSet = TypeVarSet0,
ParentArgTypes = PredArgTypes,
ParentKindMap = PredKindMap,
ParentTVars = [],
ParentExistQVars = []
else
% This merge might be a performance bottleneck?
tvarset_merge_renaming(TypeVarSet0, PredTypeVarSet, TypeVarSet,
PredToParentTypeRenaming),
apply_renaming_to_types(PredToParentTypeRenaming,
PredArgTypes, ParentArgTypes),
type_vars_in_types(ParentArgTypes, ParentTVars),
apply_renaming_to_tvar_kind_map(PredToParentTypeRenaming,
PredKindMap, ParentKindMap),
apply_renaming_to_tvars(PredToParentTypeRenaming,
PredExistQVars, ParentExistQVars)
),
PredModule = pred_info_module(PredInfo),
PredName = pred_info_name(PredInfo),
pred_info_get_orig_arity(PredInfo, pred_form_arity(PredFormArityInt)),
( if
(
% Optimize for the common case of nonpolymorphic call
% with no constraints.
ParentTVars = [],
PredClassContext = univ_exist_constraints([], [])
;
% Some builtins don't need or want the type_info.
no_type_info_builtin(PredModule, PredName, PredFormArityInt)
)
then
GoalInfo = GoalInfo0,
ExtraGoals = [],
ExtraVars = []
else
poly_info_set_typevarset(TypeVarSet, !Info),
% Compute which "parent" type variables are constrained
% by the type class constraints.
apply_renaming_to_univ_exist_constraints(PredToParentTypeRenaming,
PredClassContext, ParentClassContext),
ParentClassContext = univ_exist_constraints(ParentUnivConstraints,
ParentExistConstraints),
constraint_list_get_tvars(ParentUnivConstraints,
ParentUnivConstrainedTVars),
constraint_list_get_tvars(ParentExistConstraints,
ParentExistConstrainedTVars),
% Calculate the set of unconstrained type vars. Split these into
% existential and universal type vars.
list.remove_dups(ParentTVars, ParentUnconstrainedTVars0),
list.delete_elems(ParentUnconstrainedTVars0,
ParentUnivConstrainedTVars, ParentUnconstrainedTVars1),
list.delete_elems(ParentUnconstrainedTVars1,
ParentExistConstrainedTVars, ParentUnconstrainedTVars),
list.delete_elems(ParentUnconstrainedTVars, ParentExistQVars,
ParentUnconstrainedUnivTVars),
list.delete_elems(ParentUnconstrainedTVars,
ParentUnconstrainedUnivTVars, ParentUnconstrainedExistTVars),
% Calculate the "parent to actual" binding.
lookup_var_types(VarTable, ArgVars0, ActualArgTypes),
type_list_subsumes_det(ParentArgTypes, ActualArgTypes,
ParentToActualTypeSubst),
% Make the universally quantified typeclass_infos for the call.
poly_info_get_constraint_map(!.Info, ConstraintMap),
GoalId = goal_info_get_goal_id(GoalInfo0),
list.length(ParentUnivConstraints, NumUnivConstraints),
lookup_hlds_constraint_list(ConstraintMap, unproven, GoalId,
NumUnivConstraints, ActualUnivConstraints),
apply_rec_subst_to_tvars(ParentKindMap, ParentToActualTypeSubst,
ParentExistQVars, ActualExistQVarTypes),
( if
prog_type.type_list_to_var_list(ActualExistQVarTypes,
ActualExistQVars0)
then
ActualExistQVars = ActualExistQVars0
else
unexpected($pred, "existq_tvar bound")
),
Context = goal_info_get_context(GoalInfo0),
make_typeclass_info_vars(ActualUnivConstraints, ActualExistQVars,
Context, ExtraUnivClassVarsMCAs, ExtraUnivClassGoals, !Info),
assoc_list.keys(ExtraUnivClassVarsMCAs, ExtraUnivClassVars),
% Make variables to hold any existentially quantified typeclass_infos
% in the call, insert them into the typeclass_info map.
list.length(ParentExistConstraints, NumExistConstraints),
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
NumExistConstraints, ActualExistConstraints),
make_existq_typeclass_info_vars(ActualExistConstraints, Context,
ExtraExistClassVars, ExtraExistClassGoals, !Info),
% Make variables to hold typeinfos for unconstrained universal type
% vars.
apply_rec_subst_to_tvars(ParentKindMap, ParentToActualTypeSubst,
ParentUnconstrainedUnivTVars, ActualUnconstrainedUnivTypes),
polymorphism_do_make_type_info_vars(ActualUnconstrainedUnivTypes,
Context, ExtraUnivTypeInfoVarsMCAs,
ExtraUnivTypeInfoGoals, !Info),
assoc_list.keys(ExtraUnivTypeInfoVarsMCAs,
ExtraUnivTypeInfoVars),
% Make variables to hold typeinfos for unconstrained existential type
% vars.
apply_rec_subst_to_tvars(ParentKindMap, ParentToActualTypeSubst,
ParentUnconstrainedExistTVars, ActualUnconstrainedExistTypes),
polymorphism_do_make_type_info_vars(ActualUnconstrainedExistTypes,
Context, ExtraExistTypeInfoVarsMCAs,
ExtraExistTypeInfoGoals, !Info),
assoc_list.keys(ExtraExistTypeInfoVarsMCAs,
ExtraExistTypeInfoVars),
% Add up the extra vars and goals.
ExtraGoals = ExtraUnivClassGoals ++ ExtraExistClassGoals
++ ExtraUnivTypeInfoGoals ++ ExtraExistTypeInfoGoals,
ExtraVars = ExtraUnivTypeInfoVars ++ ExtraExistTypeInfoVars
++ ExtraUnivClassVars ++ ExtraExistClassVars,
% Update the nonlocals.
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
set_of_var.insert_list(ExtraVars, NonLocals0, NonLocals),
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo)
).
%---------------------%
% Add the type_info variables for a new call goal. This predicate assumes
% that process_module has already been run so the called pred has already
% been processed.
%
% XXX This predicate does not yet handle calls whose arguments include
% existentially quantified types or type class constraints.
%
% XXX This predicate is unused.
%
:- pred polymorphism_process_new_call(pred_info::in, proc_info::in,
pred_id::in, proc_id::in, list(prog_var)::in, builtin_state::in,
maybe(call_unify_context)::in, sym_name::in, hlds_goal_info::in,
hlds_goal::out, poly_info::in, poly_info::out) is det.
:- pragma consider_used(pred(polymorphism_process_new_call/12)).
polymorphism_process_new_call(CalleePredInfo, CalleeProcInfo, PredId, ProcId,
CallArgs0, BuiltinState, MaybeCallUnifyContext, SymName,
GoalInfo0, Goal, !Info) :-
poly_info_get_typevarset(!.Info, TVarSet0),
poly_info_get_var_table(!.Info, VarTable0),
lookup_var_types(VarTable0, CallArgs0, ActualArgTypes0),
pred_info_get_arg_types(CalleePredInfo, PredTVarSet, _PredExistQVars,
PredArgTypes),
proc_info_get_headvars(CalleeProcInfo, CalleeHeadVars),
proc_info_get_rtti_varmaps(CalleeProcInfo, CalleeRttiVarMaps),
% Work out how many type_info args we need to prepend.
NCallArgs0 = list.length(ActualArgTypes0),
NPredArgs = list.length(PredArgTypes),
NExtraArgs = NPredArgs - NCallArgs0,
( if
list.drop(NExtraArgs, PredArgTypes, OrigPredArgTypes0),
list.take(NExtraArgs, CalleeHeadVars, CalleeExtraHeadVars0)
then
OrigPredArgTypes = OrigPredArgTypes0,
CalleeExtraHeadVars = CalleeExtraHeadVars0
else
unexpected($pred, "extra args not found")
),
% Work out the bindings of type variables in the call.
tvarset_merge_renaming(TVarSet0, PredTVarSet, TVarSet,
PredToParentRenaming),
apply_renaming_to_types(PredToParentRenaming,
OrigPredArgTypes, OrigParentArgTypes),
type_list_subsumes_det(OrigParentArgTypes, ActualArgTypes0,
ParentToActualTSubst),
poly_info_set_typevarset(TVarSet, !Info),
% Look up the type variables that the type_infos in the caller are for,
% and apply the type bindings to calculate the types that the caller
% should pass type_infos for.
GetTypeInfoTypes =
( pred(ProgVar::in, TypeInfoType::out) is det :-
rtti_varmaps_var_info(CalleeRttiVarMaps, ProgVar, VarInfo),
(
VarInfo = type_info_var(TypeInfoType)
;
VarInfo = typeclass_info_var(_),
unexpected($pred,
"unsupported: constraints on initialisation preds")
;
VarInfo = non_rtti_var,
unexpected($pred,
"missing rtti_var_info for initialisation pred")
)
),
list.map(GetTypeInfoTypes, CalleeExtraHeadVars, PredTypeInfoTypes),
apply_renaming_to_types(PredToParentRenaming,
PredTypeInfoTypes, ParentTypeInfoTypes),
apply_rec_subst_to_types(ParentToActualTSubst,
ParentTypeInfoTypes, ActualTypeInfoTypes),
% Construct goals to make the required type_infos.
Ctxt = term_context.dummy_context,
polymorphism_do_make_type_info_vars(ActualTypeInfoTypes, Ctxt,
ExtraArgsConstArgs, ExtraGoals, !Info),
assoc_list.keys(ExtraArgsConstArgs, ExtraArgs),
CallArgs = ExtraArgs ++ CallArgs0,
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
NonLocals1 = set_of_var.list_to_set(ExtraArgs),
set_of_var.union(NonLocals0, NonLocals1, NonLocals),
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
CallGoalExpr = plain_call(PredId, ProcId, CallArgs, BuiltinState,
MaybeCallUnifyContext, SymName),
CallGoal = hlds_goal(CallGoalExpr, GoalInfo),
conj_list_to_goal(ExtraGoals ++ [CallGoal], GoalInfo, Goal).
%---------------------------------------------------------------------------%
%
% Process foreign proc calls.
%
:- pred polymorphism_process_foreign_proc(pred_info::in,
hlds_goal_expr::in(bound(call_foreign_proc(ground,ground,ground,ground,
ground,ground,ground))), hlds_goal_info::in, hlds_goal::out,
poly_info::in, poly_info::out) is det.
polymorphism_process_foreign_proc(PredInfo, GoalExpr0, GoalInfo0,
Goal, !Info) :-
% Insert the type_info vars into the argname map, so that the foreign_proc
% can refer to the type_info variable for type T as `TypeInfo_for_T'.
GoalExpr0 = call_foreign_proc(Attributes, PredId, ProcId,
Args0, ProcExtraArgs, MaybeTraceRuntimeCond, Impl),
ArgVars0 = list.map(foreign_arg_var, Args0),
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
ExtraVars, ExtraGoals, !Info),
polymorphism_process_foreign_proc_args(PredInfo, Impl,
ExtraVars, ExtraArgs),
Args = ExtraArgs ++ Args0,
% Plug it all back together.
CallExpr = call_foreign_proc(Attributes, PredId, ProcId,
Args, ProcExtraArgs, MaybeTraceRuntimeCond, Impl),
Call = hlds_goal(CallExpr, GoalInfo),
GoalList = ExtraGoals ++ [Call],
conj_list_to_goal(GoalList, GoalInfo0, Goal).
:- pred polymorphism_process_foreign_proc_args(pred_info::in,
pragma_foreign_proc_impl::in, list(prog_var)::in, list(foreign_arg)::out)
is det.
polymorphism_process_foreign_proc_args(PredInfo, Impl, Vars, Args) :-
pred_info_get_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
PredArgTypes),
% Find out which variables are constrained (so that we don't add
% type_infos for them).
pred_info_get_class_context(PredInfo,
univ_exist_constraints(UnivCs, ExistCs)),
UnivVars0 = list.map(get_constrained_vars, UnivCs),
list.condense(UnivVars0, UnivConstrainedVars),
ExistVars0 = list.map(get_constrained_vars, ExistCs),
list.condense(ExistVars0, ExistConstrainedVars),
type_vars_in_types(PredArgTypes, PredTypeVars0),
list.remove_dups(PredTypeVars0, PredTypeVars1),
list.delete_elems(PredTypeVars1, UnivConstrainedVars, PredTypeVars2),
list.delete_elems(PredTypeVars2, ExistConstrainedVars, PredTypeVars),
% The argument order is described at the top of polymorphism.m.
in_mode(In),
out_mode(Out),
list.map(foreign_proc_add_typeclass_info(Out, Impl, PredTypeVarSet),
ExistCs, ExistTypeClassArgInfos),
list.map(foreign_proc_add_typeclass_info(In, Impl, PredTypeVarSet),
UnivCs, UnivTypeClassArgInfos),
TypeClassArgInfos = UnivTypeClassArgInfos ++ ExistTypeClassArgInfos,
list.filter(list.contains(ExistQVars), PredTypeVars,
ExistUnconstrainedVars, UnivUnconstrainedVars),
list.map_foldl(foreign_proc_add_typeinfo("Out", Out, Impl, PredTypeVarSet),
ExistUnconstrainedVars, ExistTypeArgInfos, 1, _),
list.map_foldl(foreign_proc_add_typeinfo("In", In, Impl, PredTypeVarSet),
UnivUnconstrainedVars, UnivTypeArgInfos, 1, _),
TypeInfoArgInfos = UnivTypeArgInfos ++ ExistTypeArgInfos,
ArgInfos = TypeInfoArgInfos ++ TypeClassArgInfos,
% Insert type_info/typeclass_info types for all the inserted
% type_info/typeclass_info vars into the argument type list.
TypeInfoTypes = list.map((func(_) = type_info_type), PredTypeVars),
TypeClassInfoType = typeclass_info_type,
list.length(UnivCs, NumUnivCs),
list.length(ExistCs, NumExistCs),
list.duplicate(NumUnivCs + NumExistCs, TypeClassInfoType,
TypeClassInfoTypes),
OrigArgTypes = TypeInfoTypes ++ TypeClassInfoTypes,
make_foreign_args(Vars, ArgInfos, OrigArgTypes, Args).
:- func get_constrained_vars(prog_constraint) = list(tvar).
get_constrained_vars(Constraint) = CVars :-
Constraint = constraint(_, CTypes),
type_vars_in_types(CTypes, CVars).
:- pred foreign_proc_add_typeclass_info(mer_mode::in,
pragma_foreign_proc_impl::in, tvarset::in, prog_constraint::in,
foreign_arg_name_mode_box::out) is det.
foreign_proc_add_typeclass_info(Mode, Impl, TypeVarSet, Constraint,
MaybeArgNameBox) :-
Constraint = constraint(SymName, Types),
Name = sym_name_to_string_sep(SymName, "__"),
type_vars_in_types(Types, TypeVars),
TypeVarNames = list.map(underscore_and_tvar_name(TypeVarSet), TypeVars),
string.append_list(["TypeClassInfo_for_", Name | TypeVarNames],
ConstraintVarName),
% If the variable name corresponding to the typeclass_info isn't mentioned
% in the C code fragment, don't pass the variable to the C code at all.
( if foreign_proc_uses_variable(Impl, ConstraintVarName) then
MaybeArgName = yes(foreign_arg_name_mode(ConstraintVarName, Mode))
else
MaybeArgName = no
),
MaybeArgNameBox =
foreign_arg_name_mode_box(MaybeArgName, bp_native_if_possible).
:- pred foreign_proc_add_typeinfo(string::in, mer_mode::in,
pragma_foreign_proc_impl::in, tvarset::in,
tvar::in, foreign_arg_name_mode_box::out, int::in, int::out) is det.
foreign_proc_add_typeinfo(InOut, Mode, Impl, TypeVarSet, TVar, MaybeArgNameBox,
!N) :-
( if varset.search_name(TypeVarSet, TVar, TypeVarName) then
OldCVarName = "TypeInfo_for_" ++ TypeVarName,
NewCVarName = "TypeInfo_" ++ InOut ++ "_" ++ string.int_to_string(!.N),
% If the variable name corresponding to the type_info isn't mentioned
% in the C code fragment, don't pass the variable to the C code at all.
( if
( foreign_proc_uses_variable(Impl, OldCVarName)
; foreign_proc_uses_variable(Impl, NewCVarName)
)
then
MaybeArgName = yes(foreign_arg_name_mode(OldCVarName, Mode))
else
MaybeArgName = no
)
else
MaybeArgName = no
),
MaybeArgNameBox =
foreign_arg_name_mode_box(MaybeArgName, bp_native_if_possible),
!:N = !.N + 1.
%---------------------------------------------------------------------------%
%
% Process scopes.
%
:- pred polymorphism_process_from_ground_term_initial(prog_var::in,
hlds_goal_info::in, hlds_goal::in, hlds_goal_expr::out,
poly_info::in, poly_info::out) is det.
polymorphism_process_from_ground_term_initial(TermVar, GoalInfo0, SubGoal0,
GoalExpr, !Info) :-
SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo0),
( if SubGoalExpr0 = conj(plain_conj, SubGoals0Prime) then
SubGoals0 = SubGoals0Prime
else
unexpected($pred, "from_ground_term_initial goal is not plain conj")
),
polymorphism_process_fgti_goals(SubGoals0,
[], ConstructOrderMarkedSubGoals,
fgt_invariants_kept, InvariantsStatus, !Info),
(
InvariantsStatus = fgt_invariants_kept,
Reason = from_ground_term(TermVar, from_ground_term_initial),
GoalExpr = scope(Reason, SubGoal0)
;
InvariantsStatus = fgt_invariants_broken,
poly_info_get_module_info(!.Info, ModuleInfo),
module_info_get_globals(ModuleInfo, Globals),
globals.get_opt_tuple(Globals, OptTuple),
Threshold = OptTuple ^ ot_from_ground_term_threshold,
introduce_partial_fgt_scopes(Threshold, deconstruct_top_down,
GoalInfo0, SubGoalInfo0, ConstructOrderMarkedSubGoals, SubGoal),
% Delete the scope wrapper around SubGoal0.
SubGoal = hlds_goal(GoalExpr, _)
).
:- pred polymorphism_process_fgti_goals(list(hlds_goal)::in,
list(fgt_marked_goal)::in, list(fgt_marked_goal)::out,
fgt_invariants_status::in, fgt_invariants_status::out,
poly_info::in, poly_info::out) is det.
polymorphism_process_fgti_goals([], !ConstructOrderMarkedGoals,
!InvariantsStatus, !Info).
polymorphism_process_fgti_goals([Goal0 | Goals0], !ConstructOrderMarkedGoals,
!InvariantsStatus, !Info) :-
% This is used only if polymorphism_fgt_sanity_tests is enabled.
OldInfo = !.Info,
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
( if
GoalExpr0 = unify(LHSVarPrime, RHS, ModePrime, UnificationPrime,
UnifyContextPrime),
RHS = rhs_functor(ConsIdPrime, _, RHSVarsPrime)
then
LHSVar = LHSVarPrime,
Mode = ModePrime,
Unification = UnificationPrime,
UnifyContext = UnifyContextPrime,
ConsId = ConsIdPrime,
RHSVars = RHSVarsPrime
else
unexpected($pred,
"from_ground_term_initial conjunct is not functor unify")
),
polymorphism_process_unify_functor(LHSVar, ConsId, RHSVars, Mode,
Unification, UnifyContext, GoalInfo0, Goal, Changed, !Info),
(
Changed = no,
trace [compiletime(flag("polymorphism_fgt_sanity_tests"))] (
poly_info_get_var_table(OldInfo, VarTableBefore),
MaxVarBefore = var_table_count(VarTableBefore),
poly_info_get_num_reuses(OldInfo, NumReusesBefore),
poly_info_get_var_table(!.Info, VarTableAfter),
MaxVarAfter = var_table_count(VarTableAfter),
poly_info_get_num_reuses(!.Info, NumReusesAfter),
expect(unify(MaxVarBefore, MaxVarAfter), $pred,
"MaxVarBefore != MaxVarAfter"),
expect(unify(NumReusesBefore, NumReusesAfter), $pred,
"NumReusesBefore != NumReusesAfter"),
expect(unify(Goal0, Goal), $pred,
"Goal0 != Goal")
),
MarkedGoal = fgt_kept_goal(Goal0, LHSVar, RHSVars)
;
Changed = yes,
MarkedGoal = fgt_broken_goal(Goal, LHSVar, RHSVars),
!:InvariantsStatus = fgt_invariants_broken
),
!:ConstructOrderMarkedGoals = [MarkedGoal | !.ConstructOrderMarkedGoals],
polymorphism_process_fgti_goals(Goals0, !ConstructOrderMarkedGoals,
!InvariantsStatus, !Info).
:- func underscore_and_tvar_name(tvarset, tvar) = string.
underscore_and_tvar_name(TypeVarSet, TVar) = TVarName :-
varset.lookup_name(TypeVarSet, TVar, TVarName0),
TVarName = "_" ++ TVarName0.
%---------------------------------------------------------------------------%
%
% Process compound goals.
%
:- pred polymorphism_process_plain_conj(list(hlds_goal)::in,
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
polymorphism_process_plain_conj([], [], !Info).
polymorphism_process_plain_conj([Goal0 | Goals0], [Goal | Goals], !Info) :-
polymorphism_process_goal(Goal0, Goal, !Info),
polymorphism_process_plain_conj(Goals0, Goals, !Info).
:- pred polymorphism_process_par_conj(list(hlds_goal)::in,
list(hlds_goal)::out, cache_maps::in, poly_info::in, poly_info::out)
is det.
polymorphism_process_par_conj([], [], _, !Info).
polymorphism_process_par_conj([Goal0 | Goals0], [Goal | Goals],
InitialSnapshot, !Info) :-
% Any variable that a later parallel conjunct reuses from an earlier
% parallel conjunct (a) will definitely require synchronization, whose
% cost will be greater than the cost of building a typeinfo from scratch,
% and (b) may drastically reduce the available parallelism, if the earlier
% conjunct produces the variable late but the later conjunct requires it
% early.
set_cache_maps_snapshot("par conjunct", InitialSnapshot, !Info),
polymorphism_process_goal(Goal0, Goal, !Info),
polymorphism_process_par_conj(Goals0, Goals, InitialSnapshot, !Info).
:- pred polymorphism_process_disj(list(hlds_goal)::in, list(hlds_goal)::out,
cache_maps::in, poly_info::in, poly_info::out) is det.
polymorphism_process_disj([], [], _, !Info).
polymorphism_process_disj([Goal0 | Goals0], [Goal | Goals], InitialSnapshot,
!Info) :-
set_cache_maps_snapshot("disjunct", InitialSnapshot, !Info),
polymorphism_process_goal(Goal0, Goal, !Info),
polymorphism_process_disj(Goals0, Goals, InitialSnapshot, !Info).
:- pred polymorphism_process_cases(list(case)::in, list(case)::out,
cache_maps::in, poly_info::in, poly_info::out) is det.
polymorphism_process_cases([], [], _, !Info).
polymorphism_process_cases([Case0 | Cases0], [Case | Cases], InitialSnapshot,
!Info) :-
Case0 = case(MainConsId, OtherConsIds, Goal0),
set_cache_maps_snapshot("case", InitialSnapshot, !Info),
polymorphism_process_goal(Goal0, Goal, !Info),
Case = case(MainConsId, OtherConsIds, Goal),
polymorphism_process_cases(Cases0, Cases, InitialSnapshot, !Info).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- end_module check_hlds.polymorphism_goal.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink