[m-rev.] Solver support for abstract equivalence solver types
Ralph Becket
rafe at cs.mu.OZ.AU
Wed Dec 1 17:05:14 AEDT 2004
Zoltan Somogyi, Friday, 19 November 2004:
>
> Otherwise the diff is fine.
Unfortunately it wasn't: it's taken me nearly two weeks to hunt down
these bugs!
Here's the LOG and relative diff:
Estimated hours taken: 140
Branches: main
Extend the solver types implementation to handle abstract equivalence solver
types.
Fix the automatic initialisation of solver type variables to work for atomic
goals.
compiler/goal_util.m:
Add a version of goal_util__generate_unsafe_cast with two
extra inst parameters (needed because solver types
typically have inst any rather than ground).
compiler/make_hlds.m:
Fixed a bug whereby the declarations for special preds for imported
types were being module qualified using the name of the *importing*
module. This turns out to be correct for unification and comparison
predicates because they are duplicated in every module that needs
them, but not for solver type initialisation predicates.
compiler/modes.m:
Export modes__construct_initialisation_call which is now
also called from unify_proc.m.
Fix a misleading compiler error message.
Rearrange some comments for accuracy.
Scheduling of conjunctions now handles the mode_info flag
may_initialise_solver_vars slightly differently to support the
initialisation of free solver vars in atomic goals not appearing
in conjunctions.
construct_initialisation_call(s) and prepend_initialisation_call now
change the mode_info (and thus does not need the module_info).
construct_initialisation_call and build_call are now much more
careful about setting up goal_infos, vartypes and instmap_deltas
correctly.
compiler/modecheck_call.m:
Ensure that modecheck_end_of_call properly restores the
mode_info may_initialise_solver_vars flag before returning.
compiler/modecheck_unify.m:
Arrange for one of the solver vars to be initialised in free/free
unifications if mode_info_may_initialise_solver_vars is set.
XXX Var/functor unification still needs fixing.
compiler/mode_info.m:
Added mode_info_get_may_initialise_solver_vars.
mode_infos are now initialised to have the may_initialise_solver_vars
flag set to yes in order to allow the initialisation of solver type
goals not appearing in conjunctions. Conjunctions temporarily set
this flag to no to try scheduling without inserting initialisation
calls.
compiler/polymorphism.m:
Add new exported pred, process_new_call. This predicate takes
the details about a call to be inserted somewhere after the
usual polymorphism pass has been run and extends the call with
the goals and extra arguments to construct and pass any
required type_infos.
compiler/type_util.m:
A type that is equivalent to a solver type is now also considered
a solver type.
compiler/unify_proc.m:
The compiler generated initialisation predicate for an abstract
equivalence solver type first calls the initialisation predicate
for the RHS of the type equivalence, then casts the result back
into the type on the LHS of the type equivalence.
diff -u compiler/make_hlds.m compiler/make_hlds.m
--- compiler/make_hlds.m 17 Nov 2004 06:14:45 -0000
+++ compiler/make_hlds.m 19 Nov 2004 04:12:27 -0000
@@ -4248,9 +4248,16 @@
module_info_name(!.Module, ModuleName),
special_pred_interface(SpecialPredId, Type, ArgTypes, ArgModes, Det),
Name = special_pred_name(SpecialPredId, TypeCtor),
- TypeCtor = TypeSymName - _TypeArity,
- sym_name_get_module_name(TypeSymName, ModuleName, TypeModuleName),
- PredName = qualified(TypeModuleName, Name),
+ (
+ SpecialPredId = initialise
+ ->
+ TypeCtor = TypeSymName - _TypeArity,
+ sym_name_get_module_name(TypeSymName, ModuleName,
+ TypeModuleName),
+ PredName = qualified(TypeModuleName, Name)
+ ;
+ PredName = unqualified(Name)
+ ),
special_pred_name_arity(SpecialPredId, _, Arity),
clauses_info_init(Arity, ClausesInfo0),
adjust_special_pred_status(SpecialPredId, Status0, Status),
diff -u compiler/modes.m compiler/modes.m
--- compiler/modes.m 17 Nov 2004 06:39:38 -0000
+++ compiler/modes.m 1 Dec 2004 05:20:05 -0000
@@ -325,9 +325,9 @@
% Construct a call to initialise a free solver type variable.
%
-:- pred construct_initialisation_call(module_info::in, prog_var::in,
- (type)::in, (inst)::in, prog_context::in,
- maybe(call_unify_context)::in, hlds_goal::out) is det.
+:- pred construct_initialisation_call(prog_var::in, (type)::in, (inst)::in,
+ prog_context::in, maybe(call_unify_context)::in,
+ hlds_goal::out, mode_info::in, mode_info::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -344,6 +344,7 @@
:- import_module check_hlds__mode_util.
:- import_module check_hlds__modecheck_call.
:- import_module check_hlds__modecheck_unify.
+:- import_module check_hlds__polymorphism.
:- import_module check_hlds__purity.
:- import_module check_hlds__type_util.
:- import_module check_hlds__typecheck.
@@ -947,8 +948,8 @@
type_util__type_is_solver_type(ModuleInfo,
Type)
->
- prepend_initialisation_call(ModuleInfo, Var,
- Type, VarInst, !Goal)
+ prepend_initialisation_call(Var, Type,
+ VarInst, !Goal, !ModeInfo)
;
% If we're inferring the mode, then don't
% report an error, just set changed to yes
@@ -991,16 +992,16 @@
%-----------------------------------------------------------------------------%
-:- pred prepend_initialisation_call(module_info::in,
- prog_var::in, (type)::in, (inst)::in,
- hlds_goal::in, hlds_goal::out) is det.
+:- pred prepend_initialisation_call(prog_var::in, (type)::in, (inst)::in,
+ hlds_goal::in, hlds_goal::out, mode_info::in, mode_info::out)
+ is det.
-prepend_initialisation_call(ModuleInfo, Var, VarType, InitialInst,
- Goal0, Goal) :-
+prepend_initialisation_call(Var, VarType, InitialInst, Goal0, Goal,
+ !ModeInfo) :-
Goal0 = _GoalExpr0 - GoalInfo0,
hlds_goal__goal_info_get_context(GoalInfo0, Context),
- construct_initialisation_call(ModuleInfo, Var, VarType, InitialInst,
- Context, no /* CallUnifyContext */, InitVarGoal),
+ construct_initialisation_call(Var, VarType, InitialInst, Context,
+ no /* CallUnifyContext */, InitVarGoal, !ModeInfo),
goal_to_conj_list(Goal0, ConjList0),
conj_list_to_goal([InitVarGoal | ConjList0], GoalInfo0, Goal).
@@ -1473,12 +1474,9 @@
mode_info_get_errors(!.ModeInfo, OldErrors),
mode_info_set_errors([], !ModeInfo),
- % Try to schedule goals without inserting any solver
- % initialisation calls (the flag `may_initialise_solver_vars'
- % is initialised to `no' by mode_info_init and reset to `no'
- % after a call has been scheduled using initialisation and
- % after modecheck_conj_list_4).
- %
+ mode_info_get_may_initialise_solver_vars(MayInitEntryValue,
+ !.ModeInfo),
+
mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
delay_info__enter_conj(DelayInfo0, DelayInfo1),
mode_info_set_delay_info(DelayInfo1, !ModeInfo),
@@ -1486,6 +1484,12 @@
mode_info_get_live_vars(!.ModeInfo, LiveVars1),
mode_info_add_goals_live_vars(Goals0, !ModeInfo),
+ % Try to schedule goals without inserting any solver
+ % initialisation calls by setting the mode_info flag
+ % may_initialise_solver_vars to no.
+ %
+ mode_info_set_may_initialise_solver_vars(no, !ModeInfo),
+
modecheck_conj_list_2(Goals0, Goals1,
[], RevImpurityErrors0, !ModeInfo, !IO),
@@ -1537,7 +1541,10 @@
mode_info_error(Vars,
mode_error_conj(DelayedGoals, conj_floundered),
!ModeInfo)
- ).
+ ),
+ % Restore the value of the may_initialise_solver_vars flag.
+ %
+ mode_info_set_may_initialise_solver_vars(MayInitEntryValue, !ModeInfo).
mode_info_add_goals_live_vars([], !ModeInfo).
mode_info_add_goals_live_vars([Goal | Goals], !ModeInfo) :-
@@ -1748,8 +1755,8 @@
%
CandidateInitVarList =
set__to_sorted_list(CandidateInitVars),
- construct_initialisation_calls(!.ModeInfo,
- CandidateInitVarList, InitGoals),
+ construct_initialisation_calls(CandidateInitVarList,
+ InitGoals, !ModeInfo),
Goals1 = InitGoals ++ Goals0,
mode_info_get_delay_info(!.ModeInfo, DelayInfo0),
@@ -1774,21 +1781,20 @@
).
-:- pred construct_initialisation_calls(mode_info::in, list(prog_var)::in,
- list(hlds_goal)::out) is det.
+:- pred construct_initialisation_calls(list(prog_var)::in,
+ list(hlds_goal)::out, mode_info::in, mode_info::out) is det.
-construct_initialisation_calls(_, [], []).
+construct_initialisation_calls([], [], !ModeInfo).
-construct_initialisation_calls(ModeInfo, [Var | Vars], [Goal | Goals]) :-
- mode_info_get_var_types(ModeInfo, VarTypes),
+construct_initialisation_calls([Var | Vars], [Goal | Goals], !ModeInfo) :-
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
map__lookup(VarTypes, Var, VarType),
InitialInst = free,
Context = term__context_init,
MaybeCallUnifyContext = no,
- mode_info_get_module_info(ModeInfo, ModuleInfo),
- construct_initialisation_call(ModuleInfo, Var, VarType, InitialInst,
- Context, MaybeCallUnifyContext, Goal),
- construct_initialisation_calls(ModeInfo, Vars, Goals).
+ construct_initialisation_call(Var, VarType, InitialInst, Context,
+ MaybeCallUnifyContext, Goal, !ModeInfo),
+ construct_initialisation_calls(Vars, Goals, !ModeInfo).
% XXX will this catch synonyms for `free'?
@@ -2030,8 +2036,6 @@
delay_info__enter_conj(DelayInfo0, DelayInfo1),
mode_info_set_delay_info(DelayInfo1, !ModeInfo),
-% mode_info_add_goals_live_vars(Goals0, !ModeInfo),
-
mode_info_set_may_initialise_solver_vars(yes, !ModeInfo),
modecheck_conj_list_2(Goals0, Goals1,
!ImpurityErrors, !ModeInfo, !IO),
@@ -2555,9 +2559,10 @@
% `ground') then this is an implied mode that we
% don't yet know how to handle.
%
- % If the variable's type is a solver type then
- % we need to insert a call to the solver type's
- % initialisation predicate.
+ % If the variable's type is a solver type then we need to
+ % insert a call to the solver type's initialisation predicate.
+ % (To avoid unnecessary complications, we avoid doing this if
+ % there are any mode errors recorded at this point.)
mode_info_get_context(!.ModeInfo, Context),
mode_info_get_mode_context(!.ModeInfo, ModeContext),
@@ -2566,15 +2571,17 @@
CallUnifyContext = yes(call_unify_context(Var, var(Var),
UnifyContext)),
(
+ mode_info_get_errors(!.ModeInfo, ModeErrors),
+ ModeErrors = [],
mode_info_may_initialise_solver_vars(!.ModeInfo),
type_util__type_is_solver_type(ModuleInfo0, VarType)
->
% Create code to initialize the variable to
% inst `any', by calling the solver type's
% initialisation predicate.
- insert_extra_initialisation_call(ModuleInfo0, Var,
- VarType, InitialInst, Context,
- CallUnifyContext, !ExtraGoals)
+ insert_extra_initialisation_call(Var, VarType,
+ InitialInst, Context, CallUnifyContext,
+ !ExtraGoals, !ModeInfo)
;
% If the type is a type variable,
% or isn't a solver type then give up.
@@ -2616,58 +2623,80 @@
).
-:- pred insert_extra_initialisation_call(module_info::in, prog_var::in,
- (type)::in, (inst)::in,
+:- pred insert_extra_initialisation_call(prog_var::in, (type)::in, (inst)::in,
prog_context::in, maybe(call_unify_context)::in,
- extra_goals::in, extra_goals::out) is det.
+ extra_goals::in, extra_goals::out,
+ mode_info::in, mode_info::out) is det.
-insert_extra_initialisation_call(ModuleInfo, Var, VarType, InitialInst,
- Context, CallUnifyContext, !ExtraGoals) :-
+insert_extra_initialisation_call(Var, VarType, Inst, Context, CallUnifyContext,
+ !ExtraGoals, !ModeInfo) :-
- construct_initialisation_call(ModuleInfo, Var, VarType, InitialInst,
- Context, CallUnifyContext, InitVarGoal),
+ construct_initialisation_call(Var, VarType, Inst, Context,
+ CallUnifyContext, InitVarGoal, !ModeInfo),
NewExtraGoal = extra_goals([InitVarGoal], []),
append_extra_goals(!.ExtraGoals, NewExtraGoal, !:ExtraGoals).
-construct_initialisation_call(ModuleInfo, Var, VarType, InitialInst, Context,
- MaybeCallUnifyContext, InitVarGoal) :-
+construct_initialisation_call(Var, VarType, Inst, Context,
+ MaybeCallUnifyContext, InitVarGoal, !ModeInfo) :-
(
type_to_ctor_and_args(VarType, TypeCtor, _TypeArgs),
PredName = special_pred__special_pred_name(initialise,
TypeCtor),
- hlds_module__module_info_name(ModuleInfo, ThisModule),
- modes__build_call(ThisModule, PredName, [Var],
- Context, MaybeCallUnifyContext, ModuleInfo,
- GoalExpr - GoalInfo0)
- ->
- set__singleton_set(NonLocals, Var),
- goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1),
- InstmapDeltaAL = [Var - InitialInst],
+ (
+ TypeCtor = qualified(ModuleName, _TypeName) - _Arity
+ ;
+ TypeCtor = unqualified(_TypeName) - _Arity,
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+ hlds_module__module_info_name(ModuleInfo, ModuleName)
+ ),
+ NonLocals = set__make_singleton_set(Var),
+ InstmapDeltaAL = [Var - Inst],
instmap_delta_from_assoc_list(InstmapDeltaAL, InstmapDelta),
- goal_info_set_instmap_delta(GoalInfo1, InstmapDelta, GoalInfo),
+ build_call(ModuleName, PredName, [Var], NonLocals,
+ InstmapDelta, Context, MaybeCallUnifyContext,
+ GoalExpr - GoalInfo, !ModeInfo)
+ ->
InitVarGoal = GoalExpr - GoalInfo
;
error("modes.construct_initialisation_call")
).
-:- pred modes__build_call(module_name::in, string::in, list(prog_var)::in,
- prog_context::in, maybe(call_unify_context)::in, module_info::in,
- hlds_goal::out) is semidet.
-
-modes__build_call(Module, Name, ArgVars, Context,
- CallUnifyContext, ModuleInfo, Goal) :-
- module_info_get_predicate_table(ModuleInfo, PredicateTable),
+:- pred build_call(module_name::in, string::in, list(prog_var)::in,
+ set(prog_var)::in, instmap_delta::in, prog_context::in,
+ maybe(call_unify_context)::in, hlds_goal::out,
+ mode_info::in, mode_info::out) is semidet.
+
+build_call(ModuleName, PredName, ArgVars, NonLocals, InstmapDelta, Context,
+ CallUnifyContext, Goal, !ModeInfo) :-
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ module_info_get_predicate_table(ModuleInfo0, PredicateTable),
list__length(ArgVars, Arity),
predicate_table_search_pred_m_n_a(PredicateTable, is_fully_qualified,
- Module, Name, Arity, [PredId]),
- hlds_pred__proc_id_to_int(ModeId, 0), % first mode
- Call = call(PredId, ModeId, ArgVars, not_builtin, CallUnifyContext,
- qualified(Module, Name)),
+ ModuleName, PredName, Arity, [PredId]),
+ ProcNo = 0, % first mode
+ hlds_pred__proc_id_to_int(ProcId, ProcNo),
+ module_info_pred_proc_info(ModuleInfo0, PredId, ProcId, PredInfo0,
+ ProcInfo0),
+ mode_info_get_varset(!.ModeInfo, VarSet0),
+ mode_info_get_var_types(!.ModeInfo, VarTypes0),
+ polymorphism__create_poly_info_for_call(ModuleInfo0, PredInfo0,
+ ProcInfo0, VarSet0, VarTypes0, PolyInfo0),
goal_info_init(GoalInfo0),
- goal_info_set_context(GoalInfo0, Context, GoalInfo),
- Goal = Call - GoalInfo.
+ goal_info_set_context(GoalInfo0, Context, GoalInfo1),
+ goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo2),
+ goal_info_set_instmap_delta(GoalInfo2, InstmapDelta, GoalInfo),
+ polymorphism__process_new_call(PredId, ProcId, ArgVars, not_builtin,
+ CallUnifyContext, qualified(ModuleName, PredName),
+ GoalInfo, Goal, PolyInfo0, PolyInfo),
+ polymorphism__poly_info_extract(PolyInfo, PredInfo0, _PredInfo,
+ ProcInfo0, ProcInfo, ModuleInfo),
+ proc_info_varset(ProcInfo, VarSet),
+ proc_info_vartypes(ProcInfo, VarTypes),
+ mode_info_set_varset(VarSet, !ModeInfo),
+ mode_info_set_var_types(VarTypes, !ModeInfo),
+ mode_info_set_module_info(ModuleInfo, !ModeInfo).
%-----------------------------------------------------------------------------%
only in patch2:
--- compiler/polymorphism.m 20 Jul 2004 04:41:04 -0000 1.254
+++ compiler/polymorphism.m 30 Nov 2004 05:47:09 -0000
@@ -197,6 +197,15 @@
map(tvar, type_info_locn)::in, unification::in, unification::out,
hlds_goal_info::in, hlds_goal_info::out) is det.
+% Add the type_info variables for a new call goal. This predicate assumes
+% that polymorphism__process_module has already been run so the called pred
+% has already been processed.
+
+:- pred polymorphism__process_new_call(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.
+
% Given a list of types, create a list of variables to hold the type_info
% for those types, and create a list of goals to initialize those type_info
% variables to the appropriate type_info structures for the types.
@@ -237,6 +246,12 @@
:- pred create_poly_info(module_info::in, pred_info::in,
proc_info::in, poly_info::out) is det.
+ % Extract some fields from a pred_info and proc_info and use them to
+ % create a poly_info, for use by the polymorphism transformation for
+ % transforming a new call goal.
+:- pred create_poly_info_for_call(module_info::in, pred_info::in,
+ proc_info::in, prog_varset::in, vartypes::in, poly_info::out) is det.
+
% Update the fields in a pred_info and proc_info with
% the values in a poly_info.
:- pred poly_info_extract(poly_info::in, pred_info::in, pred_info::out,
@@ -995,16 +1010,16 @@
GoalExpr = generic_call(_, _, _, _),
Goal = GoalExpr - GoalInfo.
-polymorphism__process_goal_expr(Goal0, GoalInfo0, Goal, !Info) :-
- PredId = Goal0 ^ call_pred_id,
- ArgVars0 = Goal0 ^ call_args,
+polymorphism__process_goal_expr(GoalExpr, GoalInfo0, Goal, !Info) :-
+ GoalExpr = call(PredId, ProcId, ArgVars0, BuiltinState,
+ MaybeCallUnifyContext, SymName),
polymorphism__process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
ExtraVars, ExtraGoals, !Info),
ArgVars = ExtraVars ++ ArgVars0,
- CallExpr = Goal0 ^ call_args := ArgVars,
- Call = CallExpr - GoalInfo,
- list__append(ExtraGoals, [Call], GoalList),
- conj_list_to_goal(GoalList, GoalInfo0, Goal).
+ CallExpr = call(PredId, ProcId, ArgVars, BuiltinState,
+ MaybeCallUnifyContext, SymName),
+ CallGoal = CallExpr - GoalInfo,
+ conj_list_to_goal(ExtraGoals ++ [CallGoal], GoalInfo, Goal).
polymorphism__process_goal_expr(Goal0, GoalInfo0, Goal, !Info) :-
Goal0 = foreign_proc(_, PredId, _, _, _, _),
@@ -1864,6 +1879,107 @@
goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo)
).
+%-----------------------------------------------------------------------------%
+
+polymorphism__process_new_call(PredId, ProcId, CallArgs0, BuiltinState,
+ MaybeCallUnifyContext, SymName, GoalInfo0, Goal, !Info) :-
+ poly_info_get_var_types(!.Info, CallVarTypes),
+ poly_info_get_typevarset(!.Info, CallTypeVarSet0),
+ poly_info_get_pred_info(!.Info, PredInfo),
+ pred_info_arg_types(PredInfo, PredArgTypes),
+
+ % Work out the types of the provided call args.
+ %
+ CallArgTypes0 = map__apply_to_list(CallArgs0, CallVarTypes),
+
+ % Work out how many type_info args we need to prepend.
+ %
+ NCallArgs0 = length(CallArgTypes0),
+ NPredArgs = length(PredArgTypes),
+ NExtraArgs = NPredArgs - NCallArgs0,
+
+ % Construct a fresh type var for each extra type_info
+ % we need to prepend.
+ %
+ % That is, for every such type_info we construct a new
+ % type variable ExtraTypeTypeVar which we will bind to a
+ % term private_builtin.type_info(ExtraArgTypeParam),
+ % where ExtraArgTypeParam is also a new type variable.
+ %
+ varset__new_vars(CallTypeVarSet0, NExtraArgs, ExtraArgTypeVars,
+ CallTypeVarSet1),
+ list__map2_foldl(bind_type_var_to_type_info_wrapper,
+ ExtraArgTypeVars, ExtraArgTypes0, ExtraArgTypeParams0,
+ CallTypeVarSet1, _CallTypeVarSet),
+
+ % Prepend the list of types to the call arg types and unify
+ % the resulting list with the pred arg types. This should
+ % result in the earlier fresh ExtraArgTypeParams being unified
+ % with the types for which we need to construct type_infos.
+ %
+ CallArgTypes = ExtraArgTypes0 ++ CallArgTypes0,
+ unify_corresponding_types(PredArgTypes, CallArgTypes,
+ map__init, Substitution),
+ ExtraArgTypeParams = term__apply_rec_substitution_to_list(
+ ExtraArgTypeParams0, Substitution),
+
+ % And finally construct the type_info goals and args we
+ % need to prepend to complete the call.
+ %
+ Ctxt = term__context_init,
+ make_type_info_vars(ExtraArgTypeParams, Ctxt, ExtraArgs, ExtraGoals,
+ !Info),
+ CallArgs = ExtraArgs ++ CallArgs0,
+ goal_info_get_nonlocals(GoalInfo0, NonLocals0),
+ NonLocals1 = set__list_to_set(ExtraArgs),
+ NonLocals = set__union(NonLocals0, NonLocals1),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+ CallGoalExpr = call(PredId, ProcId, CallArgs, BuiltinState,
+ MaybeCallUnifyContext, SymName),
+ CallGoal = CallGoalExpr - GoalInfo,
+ conj_list_to_goal(ExtraGoals ++ [CallGoal], GoalInfo, Goal).
+
+
+ % bind_type_var_to_type_info_wrapper(X, Type, Param, VarSet0, VarSet)
+ % constructs a new type var Param and binds X to the Type form of
+ % `private_builtin.type_info(Param)'.
+ %
+:- pred bind_type_var_to_type_info_wrapper(tvar::in, (type)::out, (type)::out,
+ tvarset::in, tvarset::out) is det.
+
+bind_type_var_to_type_info_wrapper(X, Type, Param, TVarSet0, TVarSet) :-
+ varset__new_var(TVarSet0, Y, TVarSet1),
+ Param = variable(Y),
+ Ctxt = term__context_init,
+ Type = functor(atom("."),
+ [ functor(atom("private_builtin"), [], Ctxt),
+ functor(atom("type_info"), [Param], Ctxt) ],
+ Ctxt),
+ varset__bind_var(TVarSet1, X, Type, TVarSet).
+
+
+:- pred unify_corresponding_types(list(type)::in, list(type)::in,
+ tsubst::in, tsubst::out) is det.
+
+unify_corresponding_types([], [], !Subst).
+unify_corresponding_types([], [_ | _], !Subst) :-
+ error("polymorphism__unify_corresponding_types: " ++
+ "differing list lengths").
+unify_corresponding_types([_ | _], [], !Subst) :-
+ error("polymorphism__unify_corresponding_types: " ++
+ "differing list lengths").
+unify_corresponding_types([A | As], [B | Bs], !Subst) :-
+ (
+ term__unify(A, B, !Subst)
+ ->
+ unify_corresponding_types(As, Bs, !Subst)
+ ;
+ error("polymorphism__unify_corresponding_types: " ++
+ "term__unify failed")
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred polymorphism__update_typeclass_infos(list(class_constraint)::in,
list(prog_var)::in, poly_info::in, poly_info::out) is det.
@@ -3321,6 +3437,17 @@
pred_info_get_constraint_proofs(PredInfo, Proofs),
proc_info_varset(ProcInfo, VarSet),
proc_info_vartypes(ProcInfo, VarTypes),
+ proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap),
+ proc_info_typeclass_info_varmap(ProcInfo, TypeClassInfoMap),
+ PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
+ TypeClassInfoMap, Proofs, PredInfo, ModuleInfo).
+
+ % create_poly_info creates a poly_info for a call.
+ % (See also init_poly_info.)
+create_poly_info_for_call(ModuleInfo, PredInfo, ProcInfo, VarSet, VarTypes,
+ PolyInfo) :-
+ pred_info_typevarset(PredInfo, TypeVarSet),
+ pred_info_get_constraint_proofs(PredInfo, Proofs),
proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap),
proc_info_typeclass_info_varmap(ProcInfo, TypeClassInfoMap),
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
only in patch2:
--- compiler/modecheck_unify.m 5 Sep 2004 23:52:29 -0000 1.69
+++ compiler/modecheck_unify.m 23 Nov 2004 02:38:12 -0000
@@ -72,12 +72,35 @@
%-----------------------------------------------------------------------------%
-modecheck_unification(X, var(Y), Unification0, UnifyContext, _GoalInfo,
- Unify, !ModeInfo, !IO) :-
+modecheck_unification(X, var(Y), Unification0, UnifyContext,
+ UnifyGoalInfo0, Unify, !ModeInfo, !IO) :-
mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
mode_info_get_instmap(!.ModeInfo, InstMap0),
- instmap__lookup_var(InstMap0, X, InstOfX),
- instmap__lookup_var(InstMap0, Y, InstOfY),
+ instmap__lookup_var(InstMap0, X, InstOfX0),
+ instmap__lookup_var(InstMap0, Y, InstOfY0),
+ % If X and Y are free and have a solver type and we are allowed to
+ % insert initialisation calls at this point, then do so to allow
+ % scheduling of the unification.
+ (
+ mode_info_may_initialise_solver_vars(!.ModeInfo),
+ InstOfX0 = free,
+ InstOfY0 = free,
+ VarType = VarTypes^elem(X),
+ type_util__type_is_solver_type(ModuleInfo0, VarType)
+ ->
+ modes__construct_initialisation_call(X, VarType, any_inst,
+ context_init, no, InitXGoal, !ModeInfo),
+ MaybeInitX = yes(InitXGoal),
+ instmap__set(InstMap0, X, any_inst, InstMap),
+ InstOfX = any_inst,
+ InstOfY = InstOfY0
+ ;
+ MaybeInitX = no,
+ InstMap = InstMap0,
+ InstOfX = InstOfX0,
+ InstOfY = InstOfY0
+ ),
mode_info_var_is_live(!.ModeInfo, X, LiveX),
mode_info_var_is_live(!.ModeInfo, Y, LiveY),
(
@@ -110,10 +133,19 @@
modecheck_set_var_inst(Y, Inst, yes(InstOfX), !ModeInfo),
ModeOfX = (InstOfX -> Inst),
ModeOfY = (InstOfY -> Inst),
- mode_info_get_var_types(!.ModeInfo, VarTypes),
categorize_unify_var_var(ModeOfX, ModeOfY, LiveX, LiveY, X, Y,
- Det, UnifyContext, VarTypes, Unification0, Unify,
- !ModeInfo)
+ Det, UnifyContext, VarTypes, Unification0, Unify0,
+ !ModeInfo),
+ (
+ MaybeInitX = no,
+ Unify = Unify0
+ ;
+ MaybeInitX = yes(InitGoal - InitGoalInfo),
+ modes__compute_goal_instmap_delta(InstMap, Unify0,
+ UnifyGoalInfo0, UnifyGoalInfo, !ModeInfo),
+ Unify = conj([InitGoal - InitGoalInfo,
+ Unify0 - UnifyGoalInfo])
+ )
;
set__list_to_set([X, Y], WaitingVars),
mode_info_error(WaitingVars, mode_error_unify_var_var(X, Y,
only in patch2:
--- compiler/modecheck_call.m 4 Oct 2004 07:27:09 -0000 1.54
+++ compiler/modecheck_call.m 30 Nov 2004 03:45:06 -0000
@@ -439,6 +439,9 @@
modecheck_end_of_call(ProcInfo, Purity, ProcArgModes, ArgVars0, ArgOffset,
InstVarSub, ArgVars, ExtraGoals, !ModeInfo) :-
+ mode_info_get_may_initialise_solver_vars(MayInitSolverVars,
+ !.ModeInfo),
+
% Since we can't reschedule impure goals, we must allow
% the initialisation of free solver type args if
% necessary in impure calls.
@@ -463,10 +466,7 @@
;
true
),
- % We only allow one call at any given time to be made
- % schedulable by inserting initialisation calls.
- %
- mode_info_set_may_initialise_solver_vars(no, !ModeInfo).
+ mode_info_set_may_initialise_solver_vars(MayInitSolverVars, !ModeInfo).
:- pred insert_new_mode(pred_id::in, list(prog_var)::in,
maybe(determinism)::in, proc_id::out,
only in patch2:
--- compiler/mode_info.m 5 Sep 2004 23:52:27 -0000 1.66
+++ compiler/mode_info.m 18 Nov 2004 05:57:25 -0000
@@ -224,6 +224,9 @@
:- pred mode_info_may_initialise_solver_vars(mode_info::in)
is semidet.
+:- pred mode_info_get_may_initialise_solver_vars(bool::out, mode_info::in)
+ is det.
+
:- pred mode_info_set_may_initialise_solver_vars(bool::in,
mode_info::in, mode_info::out) is det.
@@ -370,7 +373,7 @@
Changed = no,
CheckingExtraGoals = no,
- MayInitSolverVars = no,
+ MayInitSolverVars = yes,
ModeInfo = mode_info(ModuleInfo, PredId, ProcId, VarSet, VarTypes,
Context, ModeContext, InstMapping0, LockedVars, DelayInfo,
@@ -646,6 +649,9 @@
mode_info_may_initialise_solver_vars(ModeInfo) :-
ModeInfo ^ may_initialise_solver_vars = yes.
+
+mode_info_get_may_initialise_solver_vars(MayInit, !.ModeInfo) :-
+ MayInit = !.ModeInfo ^ may_initialise_solver_vars.
mode_info_set_may_initialise_solver_vars(MayInit, !ModeInfo) :-
!:ModeInfo = !.ModeInfo ^ may_initialise_solver_vars := MayInit.
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list