[m-rev.] Solver support for abstract equivalence solver types
Ralph Becket
rafe at cs.mu.OZ.AU
Wed Dec 1 17:22:32 AEDT 2004
Julien Fischer, Wednesday, 1 December 2004:
> Could you please post the full diff again as well.
A pleasure:
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.98
diff -u -r1.98 goal_util.m
--- compiler/goal_util.m 16 Oct 2004 15:05:51 -0000 1.98
+++ compiler/goal_util.m 16 Nov 2004 05:14:30 -0000
@@ -237,6 +237,9 @@
:- pred goal_util__generate_unsafe_cast(prog_var::in, prog_var::in,
prog_context::in, hlds_goal::out) is det.
+:- pred goal_util__generate_unsafe_cast(prog_var::in, prog_var::in,
+ (inst)::in, (inst)::in, prog_context::in, hlds_goal::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1272,12 +1275,15 @@
Goal = GoalExpr - GoalInfo.
generate_unsafe_cast(InArg, OutArg, Context, Goal) :-
+ Ground = ground(shared, none),
+ generate_unsafe_cast(InArg, OutArg, Ground, Ground, Context, Goal).
+
+generate_unsafe_cast(InArg, OutArg, InInst, OutInst, Context, Goal) :-
set__list_to_set([InArg, OutArg], NonLocals),
- instmap_delta_from_assoc_list([OutArg - ground(shared, none)],
- InstMapDelta),
+ instmap_delta_from_assoc_list([OutArg - OutInst], InstMapDelta),
goal_info_init(NonLocals, InstMapDelta, det, pure, Context, GoalInfo),
Goal = generic_call(unsafe_cast, [InArg, OutArg],
- [in_mode, out_mode], det) - GoalInfo.
+ [in_mode(InInst), out_mode(OutInst)], det) - GoalInfo.
%-----------------------------------------------------------------------------%
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.485
diff -u -r1.485 make_hlds.m
--- compiler/make_hlds.m 5 Nov 2004 05:39:05 -0000 1.485
+++ compiler/make_hlds.m 19 Nov 2004 04:12:27 -0000
@@ -4248,7 +4248,16 @@
module_info_name(!.Module, ModuleName),
special_pred_interface(SpecialPredId, Type, ArgTypes, ArgModes, Det),
Name = special_pred_name(SpecialPredId, TypeCtor),
- PredName = unqualified(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),
Index: compiler/mode_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_info.m,v
retrieving revision 1.66
diff -u -r1.66 mode_info.m
--- 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.
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.54
diff -u -r1.54 modecheck_call.m
--- 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,
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.69
diff -u -r1.69 modecheck_unify.m
--- 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,
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.285
diff -u -r1.285 modes.m
--- compiler/modes.m 4 Oct 2004 07:27:09 -0000 1.285
+++ compiler/modes.m 1 Dec 2004 05:20:05 -0000
@@ -323,6 +323,12 @@
:- pred mode_context_to_unify_context(mode_info::in, mode_context::in,
unify_context::out) is det.
+ % Construct a call to initialise a free solver type variable.
+ %
+:- 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.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -338,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.
@@ -941,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
@@ -985,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).
@@ -1467,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),
@@ -1480,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),
@@ -1531,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) :-
@@ -1742,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),
@@ -1768,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'?
@@ -2024,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),
@@ -2549,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),
@@ -2560,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.
@@ -2610,63 +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).
-:- 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.
-
-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.insert_extra_initialisation_call: " ++
- "modes.construct_initialisation_call failed")
+ 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.
+:- 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.
-modes__build_call(Module, Name, ArgVars, Context, CallUnifyContext,
- ModuleInfo, Goal) :-
- module_info_get_predicate_table(ModuleInfo, PredicateTable),
+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).
%-----------------------------------------------------------------------------%
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.254
diff -u -r1.254 polymorphism.m
--- 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,
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.144
diff -u -r1.144 type_util.m
--- compiler/type_util.m 16 Oct 2004 15:05:51 -0000 1.144
+++ compiler/type_util.m 16 Nov 2004 02:34:29 -0000
@@ -841,6 +841,9 @@
TypeBody = solver_type(_, _)
;
TypeBody = abstract_type(solver_type)
+ ;
+ TypeBody = eqv_type(EqvType),
+ type_util__type_is_solver_type(ModuleInfo, EqvType)
).
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.140
diff -u -r1.140 unify_proc.m
--- compiler/unify_proc.m 5 Sep 2004 23:52:49 -0000 1.140
+++ compiler/unify_proc.m 17 Nov 2004 06:40:33 -0000
@@ -733,7 +733,44 @@
unify_proc__quantify_clauses_body([X], Goal, Context, Clauses,
!Info)
;
- error("trying to create initialisation proc for type " ++
+ % If this is an equivalence type then we just generate a
+ % call to the initialisation pred of the type on the RHS
+ % of the equivalence and cast the result back to the type
+ % on the LHS of the equivalence.
+ TypeBody = eqv_type(EqvType)
+ ->
+ goal_info_init(Context, GoalInfo),
+ unify_proc__make_fresh_named_var_from_type(EqvType,
+ "PreCast_HeadVar", 1, X0, !Info),
+ (
+ type_to_ctor_and_args(EqvType, TypeCtor0, _TypeArgs)
+ ->
+ TypeCtor = TypeCtor0
+ ;
+ error("unify_proc__generate_initialise_clauses: " ++
+ "type_to_ctor_and_args failed")
+ ),
+ PredName = special_pred__special_pred_name(initialise,
+ TypeCtor),
+ hlds_module__module_info_name(ModuleInfo, ModuleName),
+ TypeCtor = TypeSymName - _TypeArity,
+ sym_name_get_module_name(TypeSymName, ModuleName,
+ TypeModuleName),
+ InitPred = qualified(TypeModuleName, PredName),
+ PredId = invalid_pred_id,
+ ModeId = invalid_proc_id,
+ InitCall = call(PredId, ModeId, [X0], not_builtin, no,
+ InitPred),
+ InitGoal = InitCall - GoalInfo,
+
+ Any = any(shared),
+ generate_unsafe_cast(X0, X, Any, Any, Context, CastGoal),
+ Goal = conj([InitGoal, CastGoal]) - GoalInfo,
+ unify_proc__quantify_clauses_body([X], Goal, Context, Clauses,
+ !Info)
+ ;
+ error("unify_proc__generate_initialise_clauses: " ++
+ "trying to create initialisation proc for type " ++
"that has no solver_type_details")
).
--------------------------------------------------------------------------
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