[m-rev.] diff: exists_casts and --infer-all
Mark Brown
mark at cs.mu.OZ.AU
Mon Aug 15 04:31:37 AEST 2005
Estimated hours taken: 4
Branches: main
The transformation that introduces exists_cast goals occurs at the end of
polymorphism and operates on proc_infos which have just been copied from
clauses. A problem with this is that when inferring modes it is possible
that proc_infos may be reinitialised by copying the bodies from the clauses
again. This results in the exists_cast transformation being overwritten.
This change solves the problem by redoing the exists_cast transformation
after clauses are copied into procs during mode inference.
compiler/clause_to_proc.m:
Move the exists_cast transformation from polymorphism.m to
clause_to_proc.m, where it will be readily accessible to any stage
that needs to copy clauses to procs. The algorithm is changed
in two ways. First, it now uses the orig_arity field to determine
how many type_info and typeclass_info arguments have been added,
because the number of extra arguments is not directly available in
clause_to_proc. Second, the external type is derived from the arg
types in the pred_info instead of the vartypes in the proc_info,
because when called from modes.m the vartypes have already been
updated with different information.
Abstract out the decision whether or not copying clauses should be
done. The same decision needs to be made when redoing the exists_cast
transformation.
Provide an interface convenient for modes.m, which operates on a
module_info and list of pred_ids.
compiler/polymorphism.m:
Replace an XXX comment which this change addresses.
compiler/modes.m:
Perform the exists_cast transformation after copying clauses to procs.
compiler/hlds_pred.m:
Add a field to pred_info which stores the statically known binding
of existentially quantified type variables by a predicate. This
field is initialised to the empty substitution, and is set to its
correct value by polymorphism.m.
compiler/polymorphism.m:
Set the above field at the end of the polymorphism stage.
Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.51
diff -u -r1.51 clause_to_proc.m
--- compiler/clause_to_proc.m 8 Aug 2005 09:38:09 -0000 1.51
+++ compiler/clause_to_proc.m 14 Aug 2005 17:14:16 -0000
@@ -46,16 +46,30 @@
:- pred maybe_add_default_func_mode(pred_info::in, pred_info::out,
maybe(proc_id)::out) is det.
+ % After copying the clauses to the procs, we need to transform the
+ % procedures to introduce any required exists_casts..
+ %
+:- pred introduce_exists_casts(list(pred_id)::in, module_info::in,
+ module_info::out) is det.
+
+ % This version is used by polymorphism.m.
+ %
+:- pred introduce_exists_casts_proc(module_info::in, pred_info::in,
+ proc_info::in, proc_info::out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
+:- import_module check_hlds__mode_util.
:- import_module check_hlds__purity.
+:- import_module hlds__goal_util.
:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__make_hlds.
:- import_module libs__globals.
:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_mode.
@@ -65,6 +79,10 @@
:- import_module map.
:- import_module require.
:- import_module set.
+:- import_module string.
+:- import_module svmap.
+:- import_module svvarset.
+:- import_module term.
:- import_module varset.
maybe_add_default_func_modes([], Preds, Preds).
@@ -130,17 +148,22 @@
copy_pred_clauses_to_procs(PredId, !PredTable) :-
map__lookup(!.PredTable, PredId, PredInfo0),
(
- % Don't process typeclass methods, because their proc_infos
- % are generated already mode-correct.
- pred_info_get_markers(PredInfo0, PredMarkers),
- check_marker(PredMarkers, class_method)
+ do_copy_clauses_to_procs(PredInfo0)
->
- true
- ;
copy_clauses_to_procs(PredInfo0, PredInfo),
map__det_update(!.PredTable, PredId, PredInfo, !:PredTable)
+ ;
+ true
).
+:- pred do_copy_clauses_to_procs(pred_info::in) is semidet.
+
+do_copy_clauses_to_procs(PredInfo) :-
+ % Don't process typeclass methods, because their proc_infos
+ % are generated already mode-correct.
+ pred_info_get_markers(PredInfo, PredMarkers),
+ \+ check_marker(PredMarkers, class_method).
+
:- pred copy_clauses_to_procs(pred_info::in, pred_info::out) is det.
copy_clauses_to_procs(!PredInfo) :-
@@ -274,3 +297,225 @@
Clause = clause(_, Goal, _, _),
goal_to_disj_list(Goal, GoalList),
list__append(GoalList, Goals1, Goals).
+
+%-----------------------------------------------------------------------------%
+
+introduce_exists_casts(PredIds, !ModuleInfo) :-
+ module_info_preds(!.ModuleInfo, PredTable0),
+ list__foldl(introduce_exists_casts_pred(!.ModuleInfo), PredIds,
+ PredTable0, PredTable),
+ module_info_set_preds(PredTable, !ModuleInfo).
+
+:- pred introduce_exists_casts_pred(module_info::in, pred_id::in,
+ pred_table::in, pred_table::out) is det.
+
+introduce_exists_casts_pred(ModuleInfo, PredId, !PredTable) :-
+ map__lookup(!.PredTable, PredId, PredInfo0),
+ (
+ % Optimise the common case.
+ pred_info_get_existq_tvar_binding(PredInfo0, Subn),
+ \+ map__is_empty(Subn),
+
+ % Only process preds for which we copied clauses to procs.
+ do_copy_clauses_to_procs(PredInfo0)
+ ->
+ pred_info_procedures(PredInfo0, Procs0),
+ ProcIds = pred_info_all_non_imported_procids(PredInfo0),
+ introduce_exists_casts_procs(ModuleInfo, PredInfo0, ProcIds,
+ Procs0, Procs),
+ pred_info_set_procedures(Procs, PredInfo0, PredInfo),
+ svmap__det_update(PredId, PredInfo, !PredTable)
+ ;
+ true
+ ).
+
+:- pred introduce_exists_casts_procs(module_info::in, pred_info::in,
+ list(proc_id)::in, proc_table::in, proc_table::out) is det.
+
+introduce_exists_casts_procs(_, _, [], !Procs).
+introduce_exists_casts_procs(ModuleInfo, PredInfo, [ProcId | ProcIds],
+ !Procs) :-
+ map__lookup(!.Procs, ProcId, ProcInfo0),
+ introduce_exists_casts_proc(ModuleInfo, PredInfo, ProcInfo0, ProcInfo),
+ svmap__det_update(ProcId, ProcInfo, !Procs),
+ introduce_exists_casts_procs(ModuleInfo, PredInfo, ProcIds, !Procs).
+
+introduce_exists_casts_proc(ModuleInfo, PredInfo, !ProcInfo) :-
+ pred_info_arg_types(PredInfo, ArgTypes),
+ pred_info_get_existq_tvar_binding(PredInfo, Subn),
+ OrigArity = pred_info_orig_arity(PredInfo),
+ NumExtraHeadVars = list__length(ArgTypes) - OrigArity,
+
+ proc_info_varset(!.ProcInfo, VarSet0),
+ proc_info_vartypes(!.ProcInfo, VarTypes0),
+ proc_info_headvars(!.ProcInfo, HeadVars0),
+ proc_info_goal(!.ProcInfo, Body0),
+ proc_info_rtti_varmaps(!.ProcInfo, RttiVarMaps0),
+ proc_info_argmodes(!.ProcInfo, ArgModes),
+
+ (
+ list__split_list(NumExtraHeadVars, ArgTypes, ExtraArgTypes0,
+ OrigArgTypes0),
+ list__split_list(NumExtraHeadVars, HeadVars0, ExtraHeadVars0,
+ OrigHeadVars0),
+ list__split_list(NumExtraHeadVars, ArgModes, ExtraArgModes0,
+ OrigArgModes0)
+ ->
+ ExtraArgTypes = ExtraArgTypes0,
+ OrigArgTypes = OrigArgTypes0,
+ ExtraHeadVars1 = ExtraHeadVars0,
+ OrigHeadVars1 = OrigHeadVars0,
+ ExtraArgModes = ExtraArgModes0,
+ OrigArgModes = OrigArgModes0
+ ;
+ unexpected(this_file, "introduce_exists_casts_proc: split_list failed")
+ ),
+
+ % Add exists_casts for any head vars which are existentially typed,
+ % and for which the type is bound inside the procedure. Subn
+ % represents which existential types are bound.
+ introduce_exists_casts_for_head(ModuleInfo, Subn, OrigArgTypes,
+ OrigArgModes, OrigHeadVars1, OrigHeadVars, VarSet0, VarSet1,
+ VarTypes0, VarTypes1, [], ExistsCastHeadGoals),
+
+ % Add exists_casts for any existential type_infos or typeclass_infos.
+ % We determine which of these are existential by looking at the mode.
+ %
+ % Currently we pass in PredTypesMap so that the external type of type_infos
+ % and typeclass_infos can be looked up. When the arguments of these two
+ % types are removed, we will no longer need to do this.
+ %
+ map__from_corresponding_lists(ExtraHeadVars1, ExtraArgTypes,
+ ExternalTypes),
+ introduce_exists_casts_extra(ModuleInfo, ExternalTypes, Subn,
+ ExtraArgModes, ExtraHeadVars1, ExtraHeadVars, VarSet1, VarSet,
+ VarTypes1, VarTypes, RttiVarMaps0, RttiVarMaps, ExistsCastExtraGoals),
+
+ Body0 = _ - GoalInfo0,
+ goal_to_conj_list(Body0, Goals0),
+ Goals = Goals0 ++ ExistsCastHeadGoals ++ ExistsCastExtraGoals,
+ HeadVars = ExtraHeadVars ++ OrigHeadVars,
+ set__list_to_set(HeadVars, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+ Body = conj(Goals) - GoalInfo,
+ proc_info_set_body(VarSet, VarTypes, HeadVars, Body, RttiVarMaps,
+ !ProcInfo).
+
+:- pred introduce_exists_casts_for_head(module_info::in, tsubst::in,
+ list(type)::in, list(mode)::in, list(prog_var)::in,
+ list(prog_var)::out, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out, list(hlds_goal)::in, list(hlds_goal)::out)
+ is det.
+
+introduce_exists_casts_for_head(ModuleInfo, Subn, ArgTypes, ArgModes,
+ !HeadVars, !VarSet, !VarTypes, !ExtraGoals) :-
+ (
+ ArgTypes = [],
+ ArgModes = [],
+ !.HeadVars = []
+ ->
+ true
+ ;
+ ArgTypes = [ArgType | ArgTypesRest],
+ ArgModes = [ArgMode | ArgModesRest],
+ !.HeadVars = [HeadVar0 | HeadVarsRest0]
+ ->
+ introduce_exists_casts_for_head(ModuleInfo, Subn, ArgTypesRest,
+ ArgModesRest, HeadVarsRest0, HeadVarsRest, !VarSet, !VarTypes,
+ !ExtraGoals),
+ introduce_exists_casts_for_arg(ModuleInfo, Subn, ArgType, ArgMode,
+ HeadVar0, HeadVar, !VarSet, !VarTypes, !ExtraGoals),
+ !:HeadVars = [HeadVar | HeadVarsRest]
+ ;
+ unexpected(this_file, "introduce_exists_casts_for_head: " ++
+ "length mismatch")
+ ).
+
+:- pred introduce_exists_casts_for_arg(module_info::in, tsubst::in,
+ (type)::in, (mode)::in, prog_var::in, prog_var::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ list(hlds_goal)::in, list(hlds_goal)::out) is det.
+
+introduce_exists_casts_for_arg(ModuleInfo, Subn, ExternalType, ArgMode,
+ HeadVar0, HeadVar, !VarSet, !VarTypes, !ExtraGoals) :-
+ term__apply_rec_substitution(ExternalType, Subn, InternalType),
+ (
+ % Add an exists_cast for the head variable if its type
+ % inside the procedure is different from its type at the
+ % interface.
+ InternalType \= ExternalType
+ ->
+ term__context_init(Context),
+ svmap__det_update(HeadVar0, InternalType, !VarTypes),
+ make_new_exist_cast_var(HeadVar0, HeadVar, !VarSet),
+ svmap__det_insert(HeadVar, ExternalType, !VarTypes),
+ mode_get_insts(ModuleInfo, ArgMode, _, Inst),
+ generate_cast(exists_cast, HeadVar0, HeadVar, Inst, Inst, Context,
+ ExtraGoal),
+ !:ExtraGoals = [ExtraGoal | !.ExtraGoals]
+ ;
+ HeadVar = HeadVar0
+ ).
+
+:- pred introduce_exists_casts_extra(module_info::in, vartypes::in, tsubst::in,
+ list(mode)::in, list(prog_var)::in, list(prog_var)::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ rtti_varmaps::in, rtti_varmaps::out, list(hlds_goal)::out) is det.
+
+introduce_exists_casts_extra(_, _, _, [], [], [], !VarSet, !VarTypes,
+ !RttiVarMaps, []).
+introduce_exists_casts_extra(_, _, _, [], [_ | _], _, _, _, _, _, _, _, _) :-
+ unexpected(this_file, "introduce_exists_casts_extra: length mismatch").
+introduce_exists_casts_extra(_, _, _, [_ | _], [], _, _, _, _, _, _, _, _) :-
+ unexpected(this_file, "introduce_exists_casts_extra: length mismatch").
+introduce_exists_casts_extra(ModuleInfo, ExternalTypes, Subn,
+ [ArgMode | ArgModes], [Var0 | Vars0], [Var | Vars], !VarSet, !VarTypes,
+ !RttiVarMaps, ExtraGoals) :-
+ introduce_exists_casts_extra(ModuleInfo, ExternalTypes, Subn, ArgModes,
+ Vars0, Vars, !VarSet, !VarTypes, !RttiVarMaps, ExtraGoals0),
+
+ (
+ mode_is_output(ModuleInfo, ArgMode)
+ ->
+ % Update the type of this variable. This only needs to be done
+ % because type_info/1 and typeclass_info/1 have types in their
+ % respective arguments.
+ %
+ map__lookup(ExternalTypes, Var0, ExternalType),
+ term__apply_rec_substitution(ExternalType, Subn, InternalType),
+ svmap__det_update(Var0, InternalType, !VarTypes),
+
+ % Create the exists_cast goal.
+ %
+ term__context_init(Context),
+ make_new_exist_cast_var(Var0, Var, !VarSet),
+ svmap__det_insert(Var, ExternalType, !VarTypes),
+ generate_cast(exists_cast, Var0, Var, Context, ExtraGoal),
+ ExtraGoals = [ExtraGoal | ExtraGoals0]
+
+ % XXX when rtti_varmaps includes information about
+ % the external view of type_infos and typeclass_infos,
+ % it will need to be updated here.
+ ;
+ Var = Var0,
+ ExtraGoals = ExtraGoals0
+ ).
+
+:- pred make_new_exist_cast_var(prog_var::in, prog_var::out,
+ prog_varset::in, prog_varset::out) is det.
+
+make_new_exist_cast_var(InternalVar, ExternalVar, !VarSet) :-
+ svvarset__new_var(ExternalVar, !VarSet),
+ varset__lookup_name(!.VarSet, InternalVar, InternalName),
+ string__append("ExistQ", InternalName, ExternalName),
+ svvarset__name_var(ExternalVar, ExternalName, !VarSet).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "clause_to_proc.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module check_hlds.clause_to_proc.
+%-----------------------------------------------------------------------------%
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.171
diff -u -r1.171 hlds_pred.m
--- compiler/hlds_pred.m 14 Aug 2005 03:20:38 -0000 1.171
+++ compiler/hlds_pred.m 14 Aug 2005 08:55:57 -0000
@@ -1336,6 +1336,7 @@
:- pred pred_info_typevarset(pred_info::in, tvarset::out) is det.
:- pred pred_info_get_exist_quant_tvars(pred_info::in, existq_tvars::out)
is det.
+:- pred pred_info_get_existq_tvar_binding(pred_info::in, tsubst::out) is det.
:- pred pred_info_get_head_type_params(pred_info::in, head_type_params::out)
is det.
:- pred pred_info_get_class_context(pred_info::in, prog_constraints::out)
@@ -1364,6 +1365,8 @@
pred_info::in, pred_info::out) is det.
:- pred pred_info_set_typevarset(tvarset::in,
pred_info::in, pred_info::out) is det.
+:- pred pred_info_set_existq_tvar_binding(tsubst::in,
+ pred_info::in, pred_info::out) is det.
:- pred pred_info_set_head_type_params(head_type_params::in,
pred_info::in, pred_info::out) is det.
:- pred pred_info_set_class_context(prog_constraints::in,
@@ -1695,6 +1698,12 @@
% The set of existentially quantified type
% variables in the predicate's type decl.
+ existq_tvar_binding :: tsubst,
+ % The statically known bindings of existentially
+ % quantified type variables inside this predicate.
+ % This field is set at the end of the polymorphism
+ % stage.
+
head_type_params :: head_type_params,
% The set of type variables which the body of the
% predicate can't bind, and whose type_infos are
@@ -1759,14 +1768,15 @@
term__vars_list(ArgTypes, TVars),
list__delete_elems(TVars, ExistQVars, HeadTypeParams),
Attributes = [],
+ map__init(ExistQVarBindings),
UnprovenBodyConstraints = [],
set__init(Assertions),
Indexes = [],
map__init(Procs),
PredInfo = pred_info(PredModuleName, PredName, Arity, PredOrFunc,
Context, Origin, Status, GoalType, Markers, Attributes,
- ArgTypes, TypeVarSet, TypeVarSet, ExistQVars, HeadTypeParams,
- ClassContext, ClassProofs, ClassConstraintMap,
+ ArgTypes, TypeVarSet, TypeVarSet, ExistQVars, ExistQVarBindings,
+ HeadTypeParams, ClassContext, ClassProofs, ClassConstraintMap,
UnprovenBodyConstraints, inst_graph_info_init, [],
Assertions, User, Indexes, ClausesInfo, Procs).
@@ -1783,6 +1793,7 @@
map__init(ClassConstraintMap),
term__vars_list(ArgTypes, TVars),
list__delete_elems(TVars, ExistQVars, HeadTypeParams),
+ map__init(ExistQVarBindings),
UnprovenBodyConstraints = [],
Indexes = [],
@@ -1800,8 +1811,8 @@
PredInfo = pred_info(ModuleName, PredName, Arity, PredOrFunc,
Context, Origin, Status, clauses, Markers, Attributes,
- ArgTypes, TypeVarSet, TypeVarSet, ExistQVars, HeadTypeParams,
- ClassContext, ClassProofs, ClassConstraintMap,
+ ArgTypes, TypeVarSet, TypeVarSet, ExistQVars, ExistQVarBindings,
+ HeadTypeParams, ClassContext, ClassProofs, ClassConstraintMap,
UnprovenBodyConstraints, inst_graph_info_init, [], Assertions,
User, Indexes, ClausesInfo, Procs).
@@ -1911,6 +1922,7 @@
pred_info_arg_types(PI, PI ^ arg_types).
pred_info_typevarset(PI, PI ^ typevarset).
pred_info_get_exist_quant_tvars(PI, PI ^ exist_quant_tvars).
+pred_info_get_existq_tvar_binding(PI, PI ^ existq_tvar_binding).
pred_info_get_head_type_params(PI, PI ^ head_type_params).
pred_info_get_class_context(PI, PI ^ class_context).
pred_info_get_constraint_proofs(PI, PI ^ constraint_proofs).
@@ -1928,6 +1940,7 @@
pred_info_set_markers(X, PI, PI ^ markers := X).
pred_info_set_attributes(X, PI, PI ^ attributes := X).
pred_info_set_typevarset(X, PI, PI ^ typevarset := X).
+pred_info_set_existq_tvar_binding(X, PI, PI ^ existq_tvar_binding := X).
pred_info_set_head_type_params(X, PI, PI ^ head_type_params := X).
pred_info_set_class_context(X, PI, PI ^ class_context := X).
pred_info_set_constraint_proofs(X, PI, PI ^ constraint_proofs := X).
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.305
diff -u -r1.305 modes.m
--- compiler/modes.m 14 Aug 2005 03:20:40 -0000 1.305
+++ compiler/modes.m 14 Aug 2005 08:19:30 -0000
@@ -473,9 +473,11 @@
(
WhatToCheck = check_modes,
- % Restore the proc_info goals from the
- % clauses in the pred_info.
- copy_module_clauses_to_procs(PredIds, !ModuleInfo)
+ % Restore the proc_info goals from the clauses in the
+ % pred_info. Reintroduce exists_cast goals, since these
+ % do not appear in the clauses.
+ copy_module_clauses_to_procs(PredIds, !ModuleInfo),
+ introduce_exists_casts(PredIds, !ModuleInfo)
;
WhatToCheck = check_unique_modes,
% Restore the proc_info goals from the
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.267
diff -u -r1.267 polymorphism.m
--- compiler/polymorphism.m 12 Aug 2005 05:14:14 -0000 1.267
+++ compiler/polymorphism.m 14 Aug 2005 18:24:05 -0000
@@ -504,8 +504,9 @@
type_list_subsumes(ArgTypes0, OldHeadVarTypes, Subn),
\+ map__is_empty(Subn)
->
+ pred_info_set_existq_tvar_binding(Subn, PredInfo1, PredInfo2),
introduce_exists_casts_pred(!.ModuleInfo, Subn, ExtraHeadVars,
- PredInfo1, PredInfo)
+ PredInfo2, PredInfo)
;
PredInfo = PredInfo1
),
@@ -517,16 +518,16 @@
list(prog_var)::in, pred_info::in, pred_info::out) is det.
introduce_exists_casts_pred(ModuleInfo, Subn, ExtraHeadVars, !PredInfo) :-
- list__length(ExtraHeadVars, NumExtraHeadVars),
-
% Note that updating the vartypes here, and also below, only needs
% to be done because type_info/1 and typeclass_info/1 have types
% appearing in their respective arguments. When we get rid of those,
% updating the vartypes will no longer be required.
%
- % XXX Do we really need to modify the clauses_info here? The
- % clauses_info shouldn't be used beyond this point anyway. Do we
- % also need to introduce the exists_cast goals to the clauses_info?
+ % We need to update the clauses_info here because later on modes.m
+ % may once again copy the clauses to the procs. We don't need to
+ % introduce exists_casts in the clauses_info, however. Instead,
+ % we make sure that they are introduced again if the clauses are
+ % copied.
%
pred_info_clauses_info(!.PredInfo, ClausesInfo0),
clauses_info_vartypes(ClausesInfo0, VarTypes0),
@@ -541,178 +542,14 @@
pred_info_set_clauses_info(ClausesInfo, !PredInfo),
pred_info_procedures(!.PredInfo, Procs0),
- pred_info_arg_types(!.PredInfo, ArgTypes),
map__map_values(
(pred(_::in, !.ProcInfo::in, !:ProcInfo::out) is det :-
% Add the extra goals to each procedure.
- introduce_exists_casts_proc(ModuleInfo, ArgTypes, Subn,
- NumExtraHeadVars, !ProcInfo)
+ introduce_exists_casts_proc(ModuleInfo, !.PredInfo,
+ !ProcInfo)
), Procs0, Procs),
pred_info_set_procedures(Procs, !PredInfo).
-:- pred introduce_exists_casts_proc(module_info::in, list(type)::in,
- tsubst::in, int::in, proc_info::in, proc_info::out) is det.
-
-introduce_exists_casts_proc(ModuleInfo, ArgTypes, Subn, NumExtraHeadVars,
- !ProcInfo) :-
- proc_info_varset(!.ProcInfo, VarSet0),
- proc_info_vartypes(!.ProcInfo, VarTypes0),
- proc_info_headvars(!.ProcInfo, HeadVars0),
- proc_info_goal(!.ProcInfo, Body0),
- proc_info_rtti_varmaps(!.ProcInfo, RttiVarMaps0),
- proc_info_argmodes(!.ProcInfo, ArgModes),
-
- (
- list__drop(NumExtraHeadVars, ArgTypes, OrigArgTypes0),
- list__split_list(NumExtraHeadVars, HeadVars0,
- ExtraHeadVars0, OrigHeadVars0),
- list__split_list(NumExtraHeadVars, ArgModes,
- ExtraArgModes0, OrigArgModes0)
- ->
- OrigArgTypes = OrigArgTypes0,
- ExtraHeadVars1 = ExtraHeadVars0,
- OrigHeadVars1 = OrigHeadVars0,
- ExtraArgModes = ExtraArgModes0,
- OrigArgModes = OrigArgModes0
- ;
- unexpected(this_file, "introduce_exists_casts_proc: "
- ++ "split_list failed")
- ),
-
- % Add exists_casts for any head vars which are existentially typed,
- % and for which the type is bound inside the procedure. Subn
- % represents which existential types are bound.
- introduce_exists_casts_for_head(ModuleInfo, Subn, OrigArgTypes,
- OrigArgModes, OrigHeadVars1, OrigHeadVars, VarSet0, VarSet1,
- VarTypes0, VarTypes1, [], ExistsCastHeadGoals),
-
- % Add exists_casts for any existential type_infos or typeclass_infos.
- % We determine which of these are existential by looking at the mode.
- introduce_exists_casts_extra(ModuleInfo, Subn, ExtraArgModes,
- ExtraHeadVars1, ExtraHeadVars, VarSet1, VarSet,
- VarTypes1, VarTypes, RttiVarMaps0, RttiVarMaps,
- ExistsCastExtraGoals),
-
- Body0 = _ - GoalInfo0,
- goal_to_conj_list(Body0, Goals0),
- Goals = Goals0 ++ ExistsCastHeadGoals ++ ExistsCastExtraGoals,
- HeadVars = ExtraHeadVars ++ OrigHeadVars,
- set__list_to_set(HeadVars, NonLocals),
- goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
- Body = conj(Goals) - GoalInfo,
- proc_info_set_body(VarSet, VarTypes, HeadVars, Body, RttiVarMaps,
- !ProcInfo).
-
-:- pred introduce_exists_casts_for_head(module_info::in, tsubst::in,
- list(type)::in, list(mode)::in, list(prog_var)::in,
- list(prog_var)::out, prog_varset::in, prog_varset::out,
- vartypes::in, vartypes::out, list(hlds_goal)::in, list(hlds_goal)::out)
- is det.
-
-introduce_exists_casts_for_head(ModuleInfo, Subn, ArgTypes, ArgModes,
- !HeadVars, !VarSet, !VarTypes, !ExtraGoals) :-
- (
- ArgTypes = [],
- ArgModes = [],
- !.HeadVars = []
- ->
- true
- ;
- ArgTypes = [ArgType | ArgTypesRest],
- ArgModes = [ArgMode | ArgModesRest],
- !.HeadVars = [HeadVar0 | HeadVarsRest0]
- ->
- introduce_exists_casts_for_head(ModuleInfo, Subn, ArgTypesRest,
- ArgModesRest, HeadVarsRest0, HeadVarsRest, !VarSet,
- !VarTypes, !ExtraGoals),
- introduce_exists_casts_for_arg(ModuleInfo, Subn, ArgType,
- ArgMode, HeadVar0, HeadVar, !VarSet, !VarTypes,
- !ExtraGoals),
- !:HeadVars = [HeadVar | HeadVarsRest]
- ;
- unexpected(this_file,
- "introduce_exists_casts_for_head: length mismatch")
- ).
-
-:- pred introduce_exists_casts_for_arg(module_info::in, tsubst::in,
- (type)::in, (mode)::in, prog_var::in, prog_var::out,
- prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
- list(hlds_goal)::in, list(hlds_goal)::out) is det.
-
-introduce_exists_casts_for_arg(ModuleInfo, Subn, ExternalType, ArgMode,
- HeadVar0, HeadVar, !VarSet, !VarTypes, !ExtraGoals) :-
- term__apply_rec_substitution(ExternalType, Subn, InternalType),
- (
- % Add an exists_cast for the head variable if its type
- % inside the procedure is different from its type at the
- % interface.
- InternalType \= ExternalType
- ->
- term__context_init(Context),
- svmap__det_update(HeadVar0, InternalType, !VarTypes),
- make_new_exist_cast_var(HeadVar0, HeadVar, !VarSet),
- svmap__det_insert(HeadVar, ExternalType, !VarTypes),
- mode_get_insts(ModuleInfo, ArgMode, _, Inst),
- generate_cast(exists_cast, HeadVar0, HeadVar, Inst, Inst,
- Context, ExtraGoal),
- !:ExtraGoals = [ExtraGoal | !.ExtraGoals]
- ;
- HeadVar = HeadVar0
- ).
-
-:- pred introduce_exists_casts_extra(module_info::in, tsubst::in,
- list(mode)::in, list(prog_var)::in, list(prog_var)::out,
- prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
- rtti_varmaps::in, rtti_varmaps::out, list(hlds_goal)::out) is det.
-
-introduce_exists_casts_extra(_, _, [], [], [], !VarSet, !VarTypes,
- !RttiVarMaps, []).
-introduce_exists_casts_extra(_, _, [], [_ | _], _, _, _, _, _, _, _, _) :-
- unexpected(this_file, "introduce_exists_casts_extra: length mismatch").
-introduce_exists_casts_extra(_, _, [_ | _], [], _, _, _, _, _, _, _, _) :-
- unexpected(this_file, "introduce_exists_casts_extra: length mismatch").
-introduce_exists_casts_extra(ModuleInfo, Subn, [ArgMode | ArgModes],
- [Var0 | Vars0], [Var | Vars], !VarSet, !VarTypes, !RttiVarMaps,
- ExtraGoals) :-
- introduce_exists_casts_extra(ModuleInfo, Subn, ArgModes, Vars0, Vars,
- !VarSet, !VarTypes, !RttiVarMaps, ExtraGoals0),
-
- (
- mode_is_output(ModuleInfo, ArgMode)
- ->
- % Update the type of this variable. This only needs
- % to be done because type_info/1 and typeclass_info/1
- % have types in their respective arguments.
- %
- map__lookup(!.VarTypes, Var0, ExternalType),
- term__apply_rec_substitution(ExternalType, Subn, InternalType),
- svmap__det_update(Var0, InternalType, !VarTypes),
-
- % Create the exists_cast goal.
- %
- term__context_init(Context),
- make_new_exist_cast_var(Var0, Var, !VarSet),
- svmap__det_insert(Var, ExternalType, !VarTypes),
- generate_cast(exists_cast, Var0, Var, Context, ExtraGoal),
- ExtraGoals = [ExtraGoal | ExtraGoals0]
-
- % XXX when rtti_varmaps includes information about
- % the external view of type_infos and typeclass_infos,
- % it will need to be updated here.
- ;
- Var = Var0,
- ExtraGoals = ExtraGoals0
- ).
-
-:- pred make_new_exist_cast_var(prog_var::in, prog_var::out,
- prog_varset::in, prog_varset::out) is det.
-
-make_new_exist_cast_var(InternalVar, ExternalVar, !VarSet) :-
- svvarset__new_var(ExternalVar, !VarSet),
- varset__lookup_name(!.VarSet, InternalVar, InternalName),
- string__append("ExistQ", InternalName, ExternalName),
- svvarset__name_var(ExternalVar, ExternalName, !VarSet).
-
%---------------------------------------------------------------------------%
:- pred polymorphism__process_pred(pred_id::in,
--------------------------------------------------------------------------
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