[m-rev.] diff: rtti_varmaps
Mark Brown
mark at cs.mu.OZ.AU
Wed Aug 17 01:32:54 AEST 2005
With this change the argument of typeclass_info/1 is no longer referred
to, and can be safely removed. The argument of type_info/1 is still needed,
though; removing that dependency is left for a separate change.
Cheers,
Mark.
Estimated hours taken: 25
Branches: main
Another step towards the removal of constraints and types from the arguments
of typeclass_info/1 and type_info/1. This involves ensuring that the
rtti_varmaps structure contains enough information for any code that
previously needed to refer to these arguments.
compiler/common.m:
When generating assignments between variables that hold type infos
or typeclass infos, calculate a type substitution representing the
aliasing of any type variables that results. This aliasing can
occur if the same existentially typed data structure is deconstructed
twice. The resulting substitution is applied to the simplify_info.
Update the rtti_varmaps if there is information stored for one of
the variables in the assignment, but not the other.
compiler/simplify.m:
Provide a means to apply a type substitution to the fields in
a simplify_info that may contain types.
compiler/hlds_pred.m:
Don't use an injection to model the typeclass_info_varmap. The
previous forward mapping was never intended to be complete: it
only covered constraints that could be reused by later goals when
doing the polymorphism transformation. Some prog_vars which hold
typeclass_infos cannot be reused since they may no longer be in
scope, for example, prog_vars for typeclass_infos that were
constructed in an earlier disjunct.
Instead of an injection we just use two separate maps. The reverse
map (from prog_vars to constraints) includes all known constraints.
The forward map (from constraints to prog_vars) only covers
constraints for which it is safe to reuse the prog_var. These
two maps are kept consistent be the fact that the latter map is
never updated directly; it only has entries added when a particular
prog_var is flagged as reusable.
Document the fact that when looking up a typeclass_info var, we only
consider those prog_vars which have been flagged as reusable.
Export a predicate to update already existing type_info_type
information. This is used when introducing exists_cast goals.
Export a predicate to duplicate the rtti_var_info from one variable
to another. This is used when introducing new variables in
saved_vars.m, and when updating the rtti_varmaps in common.m.
Export a predicate to return all known type_info and typeclass_info
vars. This is used by hlds_out to print out the table.
When applying substitutions to the rtti_varmaps, add a sanity check
to ensure that the various maps remain consistent.
Don't provide an interface to transform constraints. Instead,
provide an interface to transform types (which is also applied to
the constraint arguments). This interface is required when
fully expanding equivalence types, in which case all types need
to be expanded, not just those appearing in constraints.
compiler/clause_to_proc.m:
When adding exists_cast goals, ensure that the rtti_varmaps structure
is updated with the new information. This addresses an XXX comment
that was left here from an earlier change.
compiler/equiv_type_hlds.m:
Fully expand equivalence types in all types in the rtti_varmaps,
not just those types appearing in constraints.
compiler/goal_util.m:
compiler/lambda.m:
When calculating extra nonlocal typeinfos or constraints on lambda
expressions, only consider those constraints that are able to be
reused. These are the only constraints that the goal in question
could possibly have used.
compiler/hlds_out.m:
When printing out the typeclass_info_varmap, only consider the
reusable constraints. These are the only ones that have entries
in the typeclass_info_varmap.
Print out the available variable info for any type_info or
typeclass_info variables.
compiler/polymorphism.m:
Thread the entire poly_info through
polymorphism__new_typeclass_info_var, since it now makes use of
three fields within this structure. Ensure that the rtti_varmaps
field is updated with the information about the new typeclass_info
var.
Flag all universal constraints from the head and existential
constraints from the body as being reusable. The program variables
for these typeclass_infos will always be in scope wherever the
constraint could appear. Typeclass infos that have been constructed
from proofs within the current procedure may not be still in scope,
so they are not flagged as reusable.
compiler/saved_vars.m:
Make sure the rtti_varmaps is updated if we rename a variable that
contains a type_info or typeclass_info.
Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.52
diff -u -r1.52 clause_to_proc.m
--- compiler/clause_to_proc.m 14 Aug 2005 18:33:53 -0000 1.52
+++ compiler/clause_to_proc.m 15 Aug 2005 04:12:01 -0000
@@ -72,6 +72,7 @@
:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_type.
:- import_module assoc_list.
:- import_module bool.
@@ -372,7 +373,7 @@
),
% Add exists_casts for any head vars which are existentially typed,
- % and for which the type is bound inside the procedure. Subn
+ % and for which the type is statically bound inside the procedure. Subn
% represents which existential types are bound.
introduce_exists_casts_for_head(ModuleInfo, Subn, OrigArgTypes,
OrigArgModes, OrigHeadVars1, OrigHeadVars, VarSet0, VarSet1,
@@ -491,11 +492,28 @@
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]
+ 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.
+ % Update the rtti_varmaps. The old variable needs to have the
+ % substitution applied to its type/constraint. The new variable
+ % needs to be associated with the unsubstituted type/constraint.
+ %
+ rtti_varmaps_var_info(!.RttiVarMaps, Var0, VarInfo),
+ (
+ VarInfo = type_info_var(TypeInfoType0),
+ term__apply_rec_substitution(TypeInfoType0, Subn, TypeInfoType),
+ rtti_set_type_info_type(Var0, TypeInfoType, !RttiVarMaps),
+ rtti_det_insert_type_info_type(Var, TypeInfoType0, !RttiVarMaps)
+ ;
+ VarInfo = typeclass_info_var(Constraint0),
+ apply_rec_subst_to_prog_constraint(Subn, Constraint0, Constraint),
+ rtti_set_typeclass_info_var(Constraint, Var0, !RttiVarMaps),
+ rtti_det_insert_typeclass_info_var(Constraint0, Var, !RttiVarMaps)
+ ;
+ VarInfo = non_rtti_var,
+ unexpected(this_file, "introduce_exists_casts_extra: " ++
+ "rtti_varmaps info not found")
+ )
;
Var = Var0,
ExtraGoals = ExtraGoals0
Index: compiler/common.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/common.m,v
retrieving revision 1.79
diff -u -r1.79 common.m
--- compiler/common.m 12 Aug 2005 05:14:09 -0000 1.79
+++ compiler/common.m 16 Aug 2005 08:34:32 -0000
@@ -90,6 +90,7 @@
:- import_module check_hlds__det_util.
:- import_module check_hlds__inst_match.
:- import_module check_hlds__mode_util.
+:- import_module check_hlds__polymorphism.
:- import_module check_hlds__type_util.
:- import_module hlds__goal_util.
:- import_module hlds__hlds_data.
@@ -98,6 +99,7 @@
:- import_module hlds__quantification.
:- import_module libs__globals.
:- import_module libs__options.
+:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_util.
:- import_module parse_tree__prog_type.
:- import_module transform_hlds__pd_cost.
@@ -742,6 +744,7 @@
is det.
common__generate_assign(ToVar, FromVar, UniMode, _, Goal, !Info) :-
+ apply_induced_tsubst(ToVar, FromVar, !Info),
simplify_info_get_var_types(!.Info, VarTypes),
map__lookup(VarTypes, ToVar, ToVarType),
map__lookup(VarTypes, FromVar, FromVarType),
@@ -794,4 +797,86 @@
common__types_match_exactly_list(Types1, Types2).
%---------------------------------------------------------------------------%
+
+ % Two existentially quantified type variables may become aliased if two
+ % calls or two deconstructions are merged together. We detect this
+ % situation here and apply the appropriate tsubst to the vartypes and
+ % rtti_varmaps. This allows us to avoid an unsafe cast, and also may
+ % allow more opportunities for simplification.
+ %
+ % Note that this relies on the assignments for type_infos and
+ % typeclass_infos to be generated before other arguments with these
+ % existential types are processed. In other words, the arguments of
+ % calls and deconstructions must be processed in left to right order.
+ %
+:- pred apply_induced_tsubst(prog_var::in, prog_var::in, simplify_info::in,
+ simplify_info::out) is det.
+
+apply_induced_tsubst(ToVar, FromVar, !Info) :-
+ simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
+ rtti_varmaps_var_info(RttiVarMaps0, FromVar, FromVarRttiInfo),
+ rtti_varmaps_var_info(RttiVarMaps0, ToVar, ToVarRttiInfo),
+ (
+ calculate_induced_tsubst(ToVarRttiInfo, FromVarRttiInfo, TSubst)
+ ->
+ ( map__is_empty(TSubst) ->
+ true
+ ;
+ simplify_info_apply_type_substitution(TSubst, !Info)
+ )
+ ;
+ % Update the rtti_varmaps with new information if only one of the
+ % variables has rtti_var_info recorded. This can happen if a new
+ % variable has been introduced, eg in quantification, without
+ % being recorded in the rtti_varmaps.
+ %
+ FromVarRttiInfo = non_rtti_var
+ ->
+ rtti_var_info_duplicate(ToVar, FromVar, RttiVarMaps0, RttiVarMaps),
+ simplify_info_set_rtti_varmaps(RttiVarMaps, !Info)
+ ;
+ ToVarRttiInfo = non_rtti_var
+ ->
+ rtti_var_info_duplicate(FromVar, ToVar, RttiVarMaps0, RttiVarMaps),
+ simplify_info_set_rtti_varmaps(RttiVarMaps, !Info)
+ ;
+ % calculate_induced_tsubst failed for a different reason, either
+ % because unification failed or because one variable was a
+ % type_info and the other was a typeclass_info.
+ %
+ unexpected(this_file, "apply_induced_tsubst: inconsistent info")
+ ).
+
+ % Calculate the induced substitution by unifying the types or constraints,
+ % if they exist. Fail if given non-matching rtti_var_infos.
+ %
+:- pred calculate_induced_tsubst(rtti_var_info::in, rtti_var_info::in,
+ tsubst::out) is semidet.
+
+calculate_induced_tsubst(ToVarRttiInfo, FromVarRttiInfo, TSubst) :-
+ (
+ FromVarRttiInfo = type_info_var(FromVarTypeInfoType),
+ ToVarRttiInfo = type_info_var(ToVarTypeInfoType),
+ type_unify(FromVarTypeInfoType, ToVarTypeInfoType, [],
+ map__init, TSubst)
+ ;
+ FromVarRttiInfo = typeclass_info_var(FromVarConstraint),
+ ToVarRttiInfo = typeclass_info_var(ToVarConstraint),
+ FromVarConstraint = constraint(Name, FromArgs),
+ ToVarConstraint = constraint(Name, ToArgs),
+ type_unify_list(FromArgs, ToArgs, [], map__init, TSubst)
+ ;
+ FromVarRttiInfo = non_rtti_var,
+ ToVarRttiInfo = non_rtti_var,
+ map__init(TSubst)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "common.m".
+
+%---------------------------------------------------------------------------%
+:- end_module check_hlds__common.
%---------------------------------------------------------------------------%
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.15
diff -u -r1.15 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 22 Jul 2005 12:31:53 -0000 1.15
+++ compiler/equiv_type_hlds.m 4 Aug 2005 06:31:02 -0000
@@ -350,17 +350,17 @@
proc_info_set_vartypes(VarTypes, !ProcInfo),
proc_info_rtti_varmaps(!.ProcInfo, RttiVarMaps0),
- rtti_varmaps_constraints(RttiVarMaps0, AllConstraints),
+ rtti_varmaps_types(RttiVarMaps0, AllTypes),
list__foldl2(
- (pred(OldConstraint::in, !.CMap::in, !:CMap::out,
+ (pred(OldType::in, !.TMap::in, !:TMap::out,
!.TVarSet::in, !:TVarSet::out) is det :-
- equiv_type__replace_in_prog_constraint(EqvMap,
- OldConstraint, NewConstraint, !TVarSet, no, _),
- svmap__set(OldConstraint, NewConstraint, !CMap)
- ), AllConstraints, map__init, ConstraintMap, !TVarSet),
- rtti_varmaps_transform_constraints(
- (pred(!.Constraint::in, !:Constraint::out) is det :-
- map__lookup(ConstraintMap, !Constraint)
+ equiv_type__replace_in_type(EqvMap, OldType, NewType, _,
+ !TVarSet, no, _),
+ svmap__set(OldType, NewType, !TMap)
+ ), AllTypes, map__init, TypeMap, !TVarSet),
+ rtti_varmaps_transform_types(
+ (pred(!.VarMapType::in, !:VarMapType::out) is det :-
+ map__lookup(TypeMap, !VarMapType)
), RttiVarMaps0, RttiVarMaps),
proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo),
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.110
diff -u -r1.110 goal_util.m
--- compiler/goal_util.m 16 Aug 2005 10:42:36 -0000 1.110
+++ compiler/goal_util.m 16 Aug 2005 11:57:26 -0000
@@ -912,8 +912,10 @@
% that is non-local in the above sense.
%
solutions_set((pred(Var::out) is nondet :-
- % Search through all arguments of all constraints.
- rtti_varmaps_constraints(RttiVarMaps, Constraints),
+ % Search through all arguments of all constraints
+ % that the goal could have used.
+ rtti_varmaps_reusable_constraints(RttiVarMaps,
+ Constraints),
list__member(Constraint, Constraints),
Constraint = constraint(_Name, ArgTypes),
term__contains_var_list(ArgTypes, TypeVar),
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.363
diff -u -r1.363 hlds_out.m
--- compiler/hlds_out.m 14 Aug 2005 05:45:57 -0000 1.363
+++ compiler/hlds_out.m 14 Aug 2005 09:33:35 -0000
@@ -2945,18 +2945,23 @@
:- pred hlds_out__write_rtti_varmaps(int::in, bool::in, rtti_varmaps::in,
prog_varset::in, tvarset::in, io::di, io::uo) is det.
-hlds_out__write_rtti_varmaps(Indent, AppendVarNums,
- RttiVarMaps, VarSet, TVarSet, !IO) :-
+hlds_out__write_rtti_varmaps(Indent, AppendVarNums, RttiVarMaps, VarSet,
+ TVarSet, !IO) :-
hlds_out__write_indent(Indent, !IO),
io__write_string("% type_info varmap:\n", !IO),
rtti_varmaps_tvars(RttiVarMaps, TypeVars),
- list__foldl(write_type_info_locn(Indent, AppendVarNums,
- RttiVarMaps, VarSet, TVarSet), TypeVars, !IO),
+ list__foldl(write_type_info_locn(Indent, AppendVarNums, RttiVarMaps,
+ VarSet, TVarSet), TypeVars, !IO),
hlds_out__write_indent(Indent, !IO),
io__write_string("% typeclass_info varmap:\n", !IO),
- rtti_varmaps_constraints(RttiVarMaps, Constraints),
- list__foldl(write_typeclass_info_var(Indent, AppendVarNums,
- RttiVarMaps, VarSet, TVarSet), Constraints, !IO).
+ rtti_varmaps_reusable_constraints(RttiVarMaps, Constraints),
+ list__foldl(write_typeclass_info_var(Indent, AppendVarNums, RttiVarMaps,
+ VarSet, TVarSet), Constraints, !IO),
+ hlds_out__write_indent(Indent, !IO),
+ io__write_string("% rtti_var_info:\n", !IO),
+ rtti_varmaps_rtti_prog_vars(RttiVarMaps, ProgVars),
+ list__foldl(write_rtti_var_info(Indent, AppendVarNums, RttiVarMaps,
+ VarSet, TVarSet), ProgVars, !IO).
:- pred write_type_info_locn(int::in, bool::in, rtti_varmaps::in,
prog_varset::in, tvarset::in, tvar::in, io::di, io::uo) is det.
@@ -3006,6 +3011,35 @@
mercury_output_var(Var, VarSet, AppendVarNums, !IO),
io__nl(!IO).
+:- pred write_rtti_var_info(int::in, bool::in, rtti_varmaps::in,
+ prog_varset::in, tvarset::in, prog_var::in, io::di, io::uo) is det.
+
+write_rtti_var_info(Indent, AppendVarNums, RttiVarMaps, VarSet, TVarSet, Var,
+ !IO) :-
+ hlds_out__write_indent(Indent, !IO),
+ io__write_string("% ", !IO),
+ mercury_output_var(Var, VarSet, AppendVarNums, !IO),
+ io__write_string(" (number ", !IO),
+ term__var_to_int(Var, VarNum),
+ io__write_int(VarNum, !IO),
+ io__write_string(") ", !IO),
+ io__write_string(" -> ", !IO),
+ rtti_varmaps_var_info(RttiVarMaps, Var, VarInfo),
+ (
+ VarInfo = type_info_var(Type),
+ io__write_string("type_info for ", !IO),
+ mercury_output_term(Type, TVarSet, AppendVarNums, !IO)
+ ;
+ VarInfo = typeclass_info_var(Constraint),
+ io__write_string("typeclass_info for", !IO),
+ mercury_output_constraint(TVarSet, AppendVarNums, Constraint,
+ !IO)
+ ;
+ VarInfo = non_rtti_var,
+ unexpected(this_file, "write_rtti_var_info: non rtti var")
+ ),
+ io__nl(!IO).
+
:- pred hlds_out__write_stack_slots(int::in, stack_slots::in, prog_varset::in,
bool::in, io::di, io::uo) is det.
@@ -4132,4 +4166,11 @@
expanded_inst_info(VarSet, ModuleInfo, Expansions), "", String).
%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "hlds_out.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module hlds__hlds_out.
%-----------------------------------------------------------------------------%
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.173
diff -u -r1.173 hlds_pred.m
--- compiler/hlds_pred.m 15 Aug 2005 07:18:29 -0000 1.173
+++ compiler/hlds_pred.m 16 Aug 2005 07:15:37 -0000
@@ -57,7 +57,6 @@
:- import_module libs__options.
% Standard library modules.
-:- import_module injection.
:- import_module int.
:- import_module require.
:- import_module string.
@@ -286,13 +285,13 @@
type_info_locn::out) is semidet.
% Find the prog_var which contains the typeclass_info for a given
- % constraint.
+ % constraint and which can be reused.
%
:- pred rtti_lookup_typeclass_info_var(rtti_varmaps::in, prog_constraint::in,
prog_var::out) is det.
% Find the prog_var which contains the typeclass_info for a given
- % constraint, if it is known.
+ % constraint and which can be reused, if it is known.
%
:- pred rtti_search_typeclass_info_var(rtti_varmaps::in, prog_constraint::in,
prog_var::out) is semidet.
@@ -326,21 +325,52 @@
:- pred rtti_set_typeclass_info_var(prog_constraint::in, prog_var::in,
rtti_varmaps::in, rtti_varmaps::out) is det.
+ % Make the given typeclass_info var available for reuse in later
+ % goals. Abort if we know nothing about this variable.
+ %
+:- pred rtti_reuse_typeclass_info_var(prog_var::in,
+ rtti_varmaps::in, rtti_varmaps::out) is det.
+
% For a prog_var which holds a type_info, set the type that the
% type_info is for. Abort if such information already exists.
%
:- pred rtti_det_insert_type_info_type(prog_var::in, (type)::in,
rtti_varmaps::in, rtti_varmaps::out) is det.
+ % For a prog_var which holds a type_info, set the type that the
+ % type_info is for, overwriting any previous information.
+ %
+:- pred rtti_set_type_info_type(prog_var::in, (type)::in,
+ rtti_varmaps::in, rtti_varmaps::out) is det.
+
+ % rtti_var_info_duplicate(Var, NewVar, !RttiVarMaps)
+ %
+ % Duplicate the rtti_var_info we have about Var for NewVar.
+ %
+:- pred rtti_var_info_duplicate(prog_var::in, prog_var::in,
+ rtti_varmaps::in, rtti_varmaps::out) is det.
+
% Returns all of the tvars that we have information about in the
% rtti_varmaps structure.
%
:- pred rtti_varmaps_tvars(rtti_varmaps::in, list(tvar)::out) is det.
- % Returns all of the prog_constraints that we have information
- % about in the rtti_varmaps structure.
+ % Returns all of the types that we have information about in the
+ % rtti_varmaps structure, including those types which appear in the
+ % arguments of constraints.
+ %
+:- pred rtti_varmaps_types(rtti_varmaps::in, list(type)::out) is det.
+
+ % Returns all of the prog_constraints which have typeclass_infos
+ % stored in a prog_var we can reuse.
%
-:- pred rtti_varmaps_constraints(rtti_varmaps::in, list(prog_constraint)::out)
+:- pred rtti_varmaps_reusable_constraints(rtti_varmaps::in,
+ list(prog_constraint)::out) is det.
+
+ % Returns all of the prog_vars which are known to contain a type_info
+ % or typeclass_info.
+ %
+:- pred rtti_varmaps_rtti_prog_vars(rtti_varmaps::in, list(prog_var)::out)
is det.
% apply_substitutions_to_rtti_varmaps(TRenaming, TSubst, Subst,
@@ -354,13 +384,13 @@
map(prog_var, prog_var)::in, rtti_varmaps::in, rtti_varmaps::out)
is det.
- % rtti_varmaps_transform_constraints(Pred, !RttiVarMaps)
+ % rtti_varmaps_transform_types(Pred, !RttiVarMaps)
%
- % Apply the transformation predicate to every constraint appearing
- % in the rtti_varmaps structure.
+ % Apply the transformation predicate to every type appearing in the
+ % rtti_varmaps structure, including those in the arguments of constraints.
%
-:- pred rtti_varmaps_transform_constraints(
- pred(prog_constraint, prog_constraint)::in(pred(in, out) is det),
+:- pred rtti_varmaps_transform_types(
+ pred((type), (type))::in(pred(in, out) is det),
rtti_varmaps::in, rtti_varmaps::out) is det.
% rtti_varmaps_overlay(A, B, C)
@@ -383,18 +413,21 @@
:- type rtti_varmaps
---> rtti_varmaps(
- tci_varmap :: typeclass_info_varmap,
- ti_varmap :: type_info_varmap,
- ti_type_map :: type_info_type_map
+ tci_varmap :: typeclass_info_varmap,
+ ti_varmap :: type_info_varmap,
+ ti_type_map :: type_info_type_map,
+ tci_constraint_map :: typeclass_info_constraint_map
).
% A typeclass_info_varmap is a map which for each type class constraint
% records which variable contains the typeclass_info for that
- % constraint. The map is reversible in the sense that we can
- % efficiently look up which constraint, if any, has its
- % typeclass_info stored in a given prog_var.
+ % constraint. The constraints covered by this map are those which
+ % are passed in as head arguments and those which are produced as
+ % existential constraints from calls or deconstructions. These are
+ % the constraints for which it is safe to reuse the variable associated
+ % with the constraint.
%
-:- type typeclass_info_varmap == injection(prog_constraint, prog_var).
+:- type typeclass_info_varmap == map(prog_constraint, prog_var).
% A type_info_varmap is a map which for each type variable
% records where the type_info for that type variable is stored.
@@ -413,10 +446,17 @@
%
:- type type_info_type_map == map(prog_var, type).
-rtti_varmaps_init(rtti_varmaps(TCIMap, TIMap, TypeMap)) :-
- injection__init(TCIMap),
+ % Every program variable which holds a typeclass_info is a key in this
+ % map. The value associated with a given key is the prog_constraint
+ % that the typeclass_info is for.
+ %
+:- type typeclass_info_constraint_map == map(prog_var, prog_constraint).
+
+rtti_varmaps_init(rtti_varmaps(TCIMap, TIMap, TypeMap, ConstraintMap)) :-
+ map__init(TCIMap),
map__init(TIMap),
- map__init(TypeMap).
+ map__init(TypeMap),
+ map__init(ConstraintMap).
rtti_varmaps_no_tvars(VarMaps) :-
map__is_empty(VarMaps ^ ti_varmap).
@@ -428,15 +468,15 @@
map__search(VarMaps ^ ti_varmap, TVar, Locn).
rtti_lookup_typeclass_info_var(VarMaps, Constraint, ProgVar) :-
- injection__lookup(VarMaps ^ tci_varmap, Constraint, ProgVar).
+ map__lookup(VarMaps ^ tci_varmap, Constraint, ProgVar).
rtti_search_typeclass_info_var(VarMaps, Constraint, ProgVar) :-
- injection__forward_search(VarMaps ^ tci_varmap, Constraint, ProgVar).
+ map__search(VarMaps ^ tci_varmap, Constraint, ProgVar).
rtti_varmaps_var_info(VarMaps, Var, VarInfo) :-
( map__search(VarMaps ^ ti_type_map, Var, Type) ->
VarInfo = type_info_var(Type)
- ; injection__reverse_search(VarMaps ^ tci_varmap, Constraint, Var) ->
+ ; map__search(VarMaps ^ tci_constraint_map, Var, Constraint) ->
VarInfo = typeclass_info_var(Constraint)
;
VarInfo = non_rtti_var
@@ -470,25 +510,70 @@
maybe_check_type_info_var(typeclass_info(_, _), _, !VarMaps).
rtti_det_insert_typeclass_info_var(Constraint, ProgVar, !VarMaps) :-
- Map0 = !.VarMaps ^ tci_varmap,
- injection__det_insert(Map0, Constraint, ProgVar, Map),
- !:VarMaps = !.VarMaps ^ tci_varmap := Map.
+ Map0 = !.VarMaps ^ tci_constraint_map,
+ map__det_insert(Map0, ProgVar, Constraint, Map),
+ !:VarMaps = !.VarMaps ^ tci_constraint_map := Map.
rtti_set_typeclass_info_var(Constraint, ProgVar, !VarMaps) :-
- Map0 = !.VarMaps ^ tci_varmap,
- injection__det_set(Map0, Constraint, ProgVar, Map),
- !:VarMaps = !.VarMaps ^ tci_varmap := Map.
+ Map0 = !.VarMaps ^ tci_constraint_map,
+ map__set(Map0, ProgVar, Constraint, Map),
+ !:VarMaps = !.VarMaps ^ tci_constraint_map := Map.
+
+rtti_reuse_typeclass_info_var(ProgVar, !VarMaps) :-
+ ( map__search(!.VarMaps ^ tci_constraint_map, ProgVar, Constraint) ->
+ Map0 = !.VarMaps ^ tci_varmap,
+ map__set(Map0, Constraint, ProgVar, Map),
+ !:VarMaps = !.VarMaps ^ tci_varmap := Map
+ ;
+ unexpected(this_file, "rtti_reuse_typeclass_info_var: "
+ ++ "variable not known")
+ ).
rtti_det_insert_type_info_type(ProgVar, Type, !VarMaps) :-
Map0 = !.VarMaps ^ ti_type_map,
map__det_insert(Map0, ProgVar, Type, Map),
!:VarMaps = !.VarMaps ^ ti_type_map := Map.
+rtti_set_type_info_type(ProgVar, Type, !VarMaps) :-
+ Map0 = !.VarMaps ^ ti_type_map,
+ map__set(Map0, ProgVar, Type, Map),
+ !:VarMaps = !.VarMaps ^ ti_type_map := Map.
+
+rtti_var_info_duplicate(Var, NewVar, !VarMaps) :-
+ rtti_varmaps_var_info(!.VarMaps, Var, VarInfo),
+ (
+ VarInfo = type_info_var(Type),
+ rtti_det_insert_type_info_type(NewVar, Type, !VarMaps)
+ ;
+ VarInfo = typeclass_info_var(Constraint),
+ rtti_det_insert_typeclass_info_var(Constraint, NewVar, !VarMaps)
+ ;
+ VarInfo = non_rtti_var
+ ).
+
rtti_varmaps_tvars(VarMaps, TVars) :-
map__keys(VarMaps ^ ti_varmap, TVars).
-rtti_varmaps_constraints(VarMaps, Constraints) :-
- injection__keys(VarMaps ^ tci_varmap, Constraints).
+rtti_varmaps_types(VarMaps, Types) :-
+ solutions(rtti_varmaps_is_known_type(VarMaps), Types).
+
+:- pred rtti_varmaps_is_known_type(rtti_varmaps::in, (type)::out) is nondet.
+
+rtti_varmaps_is_known_type(VarMaps, Type) :-
+ map__values(VarMaps ^ ti_type_map, Types),
+ list__member(Type, Types).
+rtti_varmaps_is_known_type(VarMaps, Type) :-
+ map__values(VarMaps ^ tci_constraint_map, Constraints),
+ list__member(constraint(_, Types), Constraints),
+ list__member(Type, Types).
+
+rtti_varmaps_reusable_constraints(VarMaps, Constraints) :-
+ map__keys(VarMaps ^ tci_varmap, Constraints).
+
+rtti_varmaps_rtti_prog_vars(VarMaps, Vars) :-
+ map__keys(VarMaps ^ ti_type_map, TIVars),
+ map__keys(VarMaps ^ tci_constraint_map, TCIVars),
+ list__append(TIVars, TCIVars, Vars).
apply_substitutions_to_rtti_varmaps(TRenaming, TSubst, Subst, !RttiVarMaps) :-
(
@@ -499,82 +584,53 @@
->
true
;
- !.RttiVarMaps = rtti_varmaps(TCIMap0, TIMap0, TypeMap0),
- apply_substitutions_to_typeclass_var_map(TRenaming, TSubst,
- Subst, TCIMap0, TCIMap),
- apply_substitutions_to_var_map(TRenaming, TSubst, Subst,
- TIMap0, TIMap),
- apply_substitutions_to_type_map(TRenaming, TSubst, Subst,
- TypeMap0, TypeMap),
- !:RttiVarMaps = rtti_varmaps(TCIMap, TIMap, TypeMap)
- ).
-
- % Update a map from prog_constraint to var, using the type renaming
- % and substitution to rename tvars and a variable substition to
- % rename vars. The type renaming is applied before the type
- % substitution.
- %
-:- pred apply_substitutions_to_typeclass_var_map(tsubst::in, tsubst::in,
- map(prog_var, prog_var)::in,
- typeclass_info_varmap::in, typeclass_info_varmap::out) is det.
-
-apply_substitutions_to_typeclass_var_map(TRenaming, TSubst, Subst, !VarMap) :-
- % Note that the transformation on keys must be done before
- % the transformation on values. If the values are transformed
- % first then the invariants on the data structure may be
- % violated.
- injection.map_keys(
- apply_substitutions_to_tc_varmap_keys(TRenaming, TSubst), !VarMap),
- injection.map_values(apply_renaming_to_tc_varmap_values(Subst), !VarMap).
-
-:- pred apply_substitutions_to_tc_varmap_keys(tsubst::in, tsubst::in,
- prog_var::in, prog_constraint::in, prog_constraint::out) is det.
-
-apply_substitutions_to_tc_varmap_keys(TRenaming, TSubst, _Var, !Constraint) :-
- apply_subst_to_prog_constraint(TRenaming, !Constraint),
- apply_rec_subst_to_prog_constraint(TSubst, !Constraint).
+ !.RttiVarMaps = rtti_varmaps(TCIMap0, TIMap0, TypeMap0,
+ ConstraintMap0),
+ map__foldl(apply_substs_to_tci_map(TRenaming, TSubst, Subst),
+ TCIMap0, map__init, TCIMap),
+ map__foldl(apply_substs_to_ti_map(TRenaming, TSubst, Subst),
+ TIMap0, map__init, TIMap),
+ map__foldl(apply_substs_to_type_map(TRenaming, TSubst, Subst),
+ TypeMap0, map__init, TypeMap),
+ map__foldl(apply_substs_to_constraint_map(TRenaming, TSubst, Subst),
+ ConstraintMap0, map__init, ConstraintMap),
+ !:RttiVarMaps = rtti_varmaps(TCIMap, TIMap, TypeMap, ConstraintMap)
+ ).
-:- pred apply_renaming_to_tc_varmap_values(map(prog_var, prog_var)::in,
- prog_constraint::in, prog_var::in, prog_var::out) is det.
+:- pred apply_subst_to_prog_var(map(prog_var, prog_var)::in,
+ prog_var::in, prog_var::out) is det.
-apply_renaming_to_tc_varmap_values(Subst, _Constraint, Var0, Var) :-
+apply_subst_to_prog_var(Subst, Var0, Var) :-
( map__search(Subst, Var0, Var1) ->
Var = Var1
;
Var = Var0
).
- % Update a map from tvar to type_info_locn, using the type renaming
- % and substitution to rename tvars and a variable substitution to
- % rename vars. The type renaming is applied before the type
- % substitution.
+:- pred apply_substs_to_tci_map(tsubst::in, tsubst::in,
+ map(prog_var, prog_var)::in, prog_constraint::in, prog_var::in,
+ typeclass_info_varmap::in, typeclass_info_varmap::out) is det.
+
+apply_substs_to_tci_map(TRenaming, TSubst, Subst, Constraint0, Var0, !Map) :-
+ apply_subst_to_prog_constraint(TRenaming, Constraint0, Constraint1),
+ apply_rec_subst_to_prog_constraint(TSubst, Constraint1, Constraint),
+ apply_subst_to_prog_var(Subst, Var0, Var),
+ svmap__set(Constraint, Var, !Map).
+
+ % Update a map entry from tvar to type_info_locn, using the type renaming
+ % and substitution to rename tvars and a variable substitution to rename
+ % vars. The type renaming is applied before the type substitution.
%
- % If tvar maps to a another type variable, we keep the new
- % variable, if it maps to a type, we remove it from the map.
+ % If tvar maps to a another type variable, we keep the new variable, if
+ % it maps to a type, we remove it from the map.
%
-:- pred apply_substitutions_to_var_map(tsubst::in, tsubst::in,
- map(prog_var, prog_var)::in,
- type_info_varmap::in, type_info_varmap::out) is det.
-
-apply_substitutions_to_var_map(TRenaming, TSubst, Subst, VarMap0, VarMap) :-
- map__foldl(apply_substitutions_to_var_map_2(TRenaming, TSubst, Subst),
- VarMap0, map__init, VarMap).
-
-:- pred apply_substitutions_to_var_map_2(tsubst::in, tsubst::in,
+:- pred apply_substs_to_ti_map(tsubst::in, tsubst::in,
map(prog_var, prog_var)::in, tvar::in, type_info_locn::in,
type_info_varmap::in, type_info_varmap::out) is det.
-apply_substitutions_to_var_map_2(TRenaming, TSubst, Subst, TVar, Locn,
- !NewVarMap) :-
+apply_substs_to_ti_map(TRenaming, TSubst, Subst, TVar, Locn, !Map) :-
type_info_locn_var(Locn, Var),
- (
- % Find the new var, if there is one.
- map__search(Subst, Var, NewVar0)
- ->
- NewVar = NewVar0
- ;
- NewVar = Var
- ),
+ apply_subst_to_prog_var(Subst, Var, NewVar),
type_info_locn_set_var(NewVar, Locn, NewLocn),
(
% Find the new tvar, if there is one.
@@ -586,59 +642,108 @@
NewTVarType1 = term__variable(TVar)
),
term__apply_rec_substitution(NewTVarType1, TSubst, NewTVarType),
+
(
- % If the tvar is still a variable, insert it into the
- % map with the new var.
+ % If the tvar is still a variable, insert it into the map with the
+ % new var.
prog_type__var(NewTVarType, NewTVar)
->
- % Don't abort if two old type variables
- % map to the same new type variable.
- svmap__set(NewTVar, NewLocn, !NewVarMap)
+ % Don't abort if two old type variables map to the same new type
+ % variable.
+ svmap__set(NewTVar, NewLocn, !Map)
;
true
).
-:- pred apply_substitutions_to_type_map(tsubst::in, tsubst::in,
- map(prog_var, prog_var)::in,
- type_info_type_map::in, type_info_type_map::out) is det.
-
-apply_substitutions_to_type_map(TRenaming, TSubst, Subst, TypeMap0, TypeMap) :-
- map__foldl(apply_substitutions_to_type_map_2(TRenaming, TSubst, Subst),
- TypeMap0, map__init, TypeMap).
-
-:- pred apply_substitutions_to_type_map_2(tsubst::in, tsubst::in,
+:- pred apply_substs_to_type_map(tsubst::in, tsubst::in,
map(prog_var, prog_var)::in, prog_var::in, (type)::in,
type_info_type_map::in, type_info_type_map::out) is det.
-apply_substitutions_to_type_map_2(TRenaming, TSubst, Subst, Var0, Type0,
- !TypeMap) :-
+apply_substs_to_type_map(TRenaming, TSubst, Subst, Var0, Type0, !Map) :-
term__apply_substitution(Type0, TRenaming, Type1),
term__apply_rec_substitution(Type1, TSubst, Type),
- ( map__search(Subst, Var0, Var1) ->
- Var = Var1
+ apply_subst_to_prog_var(Subst, Var0, Var),
+ ( map__search(!.Map, Var, ExistingType) ->
+ ( Type = ExistingType ->
+ true
+ ;
+ unexpected(this_file, "inconsistent type_infos")
+ )
;
- Var = Var0
+ svmap__det_insert(Var, Type, !Map)
+ ).
+
+:- pred apply_substs_to_constraint_map(tsubst::in, tsubst::in,
+ map(prog_var, prog_var)::in, prog_var::in, prog_constraint::in,
+ typeclass_info_constraint_map::in, typeclass_info_constraint_map::out)
+ is det.
+
+apply_substs_to_constraint_map(TRenaming, TSubst, Subst, Var0, Constraint0,
+ !Map) :-
+ apply_subst_to_prog_constraint(TRenaming, Constraint0, Constraint1),
+ apply_rec_subst_to_prog_constraint(TSubst, Constraint1, Constraint),
+ apply_subst_to_prog_var(Subst, Var0, Var),
+ ( map__search(!.Map, Var, ExistingConstraint) ->
+ ( Constraint = ExistingConstraint ->
+ true
+ ;
+ unexpected(this_file, "inconsistent typeclass_infos")
+ )
+ ;
+ svmap__det_insert(Var, Constraint, !Map)
+ ).
+
+rtti_varmaps_transform_types(Pred, !RttiVarMaps) :-
+ TciMap0 = !.RttiVarMaps ^ tci_varmap,
+ TypeMap0 = !.RttiVarMaps ^ ti_type_map,
+ ConstraintMap0 = !.RttiVarMaps ^ tci_constraint_map,
+ map__foldl(apply_constraint_key_transformation(Pred), TciMap0,
+ map__init, TciMap),
+ Pred2 = (pred(_::in, V::in, W::out) is det :-
+ Pred(V, W)
),
- svmap__set(Var, Type, !TypeMap).
+ map__map_values(Pred2, TypeMap0, TypeMap),
+ map__map_values(apply_constraint_value_transformation(Pred),
+ ConstraintMap0, ConstraintMap),
+ !:RttiVarMaps = !.RttiVarMaps ^ tci_varmap := TciMap,
+ !:RttiVarMaps = !.RttiVarMaps ^ ti_type_map := TypeMap,
+ !:RttiVarMaps = !.RttiVarMaps ^ tci_constraint_map := ConstraintMap.
+
+:- pred apply_constraint_key_transformation(
+ pred((type), (type))::in(pred(in, out) is det),
+ prog_constraint::in, prog_var::in,
+ typeclass_info_varmap::in, typeclass_info_varmap::out) is det.
-rtti_varmaps_transform_constraints(Pred, !RttiVarMaps) :-
- Map0 = !.RttiVarMaps ^ tci_varmap,
- Pred2 = (pred(_::in, !.C::in, !:C::out) is det :- Pred(!C)),
- injection__map_keys(Pred2, Map0, Map),
- !:RttiVarMaps = !.RttiVarMaps ^ tci_varmap := Map.
+apply_constraint_key_transformation(Pred, Constraint0, Var, !Map) :-
+ Constraint0 = constraint(Name, Args0),
+ list__map(Pred, Args0, Args),
+ Constraint = constraint(Name, Args),
+ svmap__set(Constraint, Var, !Map).
+
+:- pred apply_constraint_value_transformation(
+ pred((type), (type))::in(pred(in, out) is det),
+ prog_var::in, prog_constraint::in, prog_constraint::out) is det.
+
+apply_constraint_value_transformation(Pred, _, Constraint0, Constraint) :-
+ Constraint0 = constraint(Name, Args0),
+ list__map(Pred, Args0, Args),
+ Constraint = constraint(Name, Args).
rtti_varmaps_overlay(VarMapsA, VarMapsB, VarMaps) :-
- VarMapsA = rtti_varmaps(TCImapA, TImapA, TypeMapA),
- VarMapsB = rtti_varmaps(TCImapB, TImapB, TypeMapB),
+ VarMapsA = rtti_varmaps(TCImapA, TImapA, TypeMapA, ConstraintMapA),
+ VarMapsB = rtti_varmaps(TCImapB, TImapB, TypeMapB, ConstraintMapB),
% Prefer VarMapsB for this information.
- injection__overlay(TCImapA, TCImapB, TCImap),
+ %
+ map__overlay(TCImapA, TCImapB, TCImap),
map__overlay(TImapA, TImapB, TImap),
% On the other hand, we insist that this information is consistent.
+ %
map__merge(TypeMapA, TypeMapB, TypeMap),
+ map__merge(ConstraintMapA, ConstraintMapB, ConstraintMap),
- VarMaps = rtti_varmaps(TCImap, TImap, TypeMap).
+ VarMaps = rtti_varmaps(TCImap, TImap, TypeMap, ConstraintMap).
%-----------------------------------------------------------------------------%
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.100
diff -u -r1.100 lambda.m
--- compiler/lambda.m 22 Jul 2005 12:31:55 -0000 1.100
+++ compiler/lambda.m 4 Aug 2005 05:53:07 -0000
@@ -324,7 +324,7 @@
% expression.
% Note currently we only allow lambda expressions
% to have universally quantified constraints.
- rtti_varmaps_constraints(RttiVarMaps, AllConstraints),
+ rtti_varmaps_reusable_constraints(RttiVarMaps, AllConstraints),
map__apply_to_list(Vars, VarTypes, LambdaVarTypes),
list__map(prog_type__vars, LambdaVarTypes, LambdaTypeVarsList),
list__condense(LambdaTypeVarsList, LambdaTypeVars),
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.268
diff -u -r1.268 polymorphism.m
--- compiler/polymorphism.m 14 Aug 2005 18:33:55 -0000 1.268
+++ compiler/polymorphism.m 16 Aug 2005 14:23:58 -0000
@@ -773,9 +773,8 @@
polymorphism__make_typeclass_info_head_vars(InstanceConstraints,
InstanceHeadTypeClassInfoVars, !Info),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- list__foldl_corresponding(rtti_det_insert_typeclass_info_var,
- InstanceConstraints, InstanceHeadTypeClassInfoVars,
- RttiVarMaps0, RttiVarMaps),
+ list__foldl(rtti_reuse_typeclass_info_var,
+ InstanceHeadTypeClassInfoVars, RttiVarMaps0, RttiVarMaps),
poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
list__append(UnconstrainedInstanceTypeInfoVars,
InstanceHeadTypeClassInfoVars, ExtraHeadVars0),
@@ -916,9 +915,8 @@
UnconstrainedInstanceTVars,
UnconstrainedInstanceTypeLocns, !RttiVarMaps),
- list__foldl_corresponding(rtti_set_typeclass_info_var,
- UnivConstraints, UnivHeadTypeClassInfoVars,
- !RttiVarMaps),
+ list__foldl(rtti_reuse_typeclass_info_var,
+ UnivHeadTypeClassInfoVars, !RttiVarMaps),
poly_info_set_rtti_varmaps(!.RttiVarMaps, !Info)
).
@@ -974,8 +972,10 @@
polymorphism__make_typeclass_info_vars(ActualExistConstraints,
ExistQVarsForCall, Context, ExistTypeClassVars,
ExtraTypeClassGoals, !Info),
- polymorphism__update_typeclass_infos(ActualExistConstraints,
- ExistTypeClassVars, !Info),
+ poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
+ list__foldl(rtti_reuse_typeclass_info_var, ExistTypeClassVars,
+ RttiVarMaps0, RttiVarMaps),
+ poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
polymorphism__assign_var_list(ExistTypeClassInfoHeadVars,
ExistTypeClassVars, ExtraTypeClassUnifyGoals),
@@ -2019,29 +2019,6 @@
%-----------------------------------------------------------------------------%
-:- pred polymorphism__update_typeclass_infos(list(prog_constraint)::in,
- list(prog_var)::in, poly_info::in, poly_info::out) is det.
-
-polymorphism__update_typeclass_infos(Constraints, Vars, !Info) :-
- poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- insert_typeclass_info_locns(Constraints, Vars, RttiVarMaps0,
- RttiVarMaps),
- poly_info_set_rtti_varmaps(RttiVarMaps, !Info).
-
-:- pred insert_typeclass_info_locns(list(prog_constraint)::in,
- list(prog_var)::in, rtti_varmaps::in, rtti_varmaps::out) is det.
-
-insert_typeclass_info_locns([], [], !RttiVarMaps).
-insert_typeclass_info_locns([C | Cs], [V | Vs], !RttiVarMaps) :-
- rtti_set_typeclass_info_var(C, V, !RttiVarMaps),
- insert_typeclass_info_locns(Cs, Vs, !RttiVarMaps).
-insert_typeclass_info_locns([], [_ | _], _, _) :-
- error("polymorphism:insert_typeclass_info_locns").
-insert_typeclass_info_locns([_ | _], [], _, _) :-
- error("polymorphism:insert_typeclass_info_locns").
-
-%-----------------------------------------------------------------------------%
-
:- pred polymorphism__fixup_quantification(list(prog_var)::in,
existq_tvars::in, hlds_goal::in, hlds_goal::out,
poly_info::in, poly_info::out) is det.
@@ -2200,7 +2177,7 @@
polymorphism__make_typeclass_info_head_var(Constraint,
NewVar, !Info),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- rtti_det_insert_typeclass_info_var(Constraint, NewVar,
+ rtti_reuse_typeclass_info_var(NewVar,
RttiVarMaps0, RttiVarMaps),
poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
MaybeVar = yes(NewVar)
@@ -2338,20 +2315,16 @@
polymorphism__make_typeclass_info_from_subclass(Constraint,
Seen, ClassId, SubClassConstraint, ExistQVars, Context,
MaybeVar, !ExtraGoals, !Info) :-
- !.Info = poly_info(VarSet0, VarTypes0, TypeVarSet, RttiVarMaps,
- Proofs, ConstraintMap, PredName, ModuleInfo),
ClassId = class_id(ClassName, _ClassArity),
% First create a variable to hold the new typeclass_info.
unqualify_name(ClassName, ClassNameString),
polymorphism__new_typeclass_info_var(Constraint, ClassNameString,
- Var, VarSet0, VarSet1, VarTypes0, VarTypes1),
+ Var, !Info),
MaybeVar = yes(Var),
% Then work out where to extract it from
SubClassConstraint = constraint(SubClassName, SubClassTypes),
list__length(SubClassTypes, SubClassArity),
SubClassId = class_id(SubClassName, SubClassArity),
- !:Info = poly_info(VarSet1, VarTypes1, TypeVarSet, RttiVarMaps,
- Proofs, ConstraintMap, PredName, ModuleInfo),
% Make the typeclass_info for the subclass
polymorphism__make_typeclass_info_var(SubClassConstraint, Seen,
@@ -2363,6 +2336,7 @@
),
% Look up the definition of the subclass
+ poly_info_get_module_info(!.Info, ModuleInfo),
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, SubClassId, SubClassDefn),
@@ -2382,10 +2356,10 @@
error("polymorphism.m: constraint not in constraint list")
),
- poly_info_get_varset(!.Info, VarSet2),
- poly_info_get_var_types(!.Info, VarTypes2),
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
make_int_const_construction(SuperClassIndex, yes("SuperClassIndex"),
- IndexGoal, IndexVar, VarTypes2, VarTypes, VarSet2, VarSet),
+ IndexGoal, IndexVar, VarTypes0, VarTypes, VarSet0, VarSet),
poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
% We extract the superclass typeclass_info by inserting a call
@@ -2420,9 +2394,6 @@
SuperClassProofs, ExistQVars, ArgSuperClassVars,
SuperClassGoals, !Info),
- poly_info_get_varset(!.Info, VarSet0),
- poly_info_get_var_types(!.Info, VarTypes0),
-
% lay out the argument variables as expected in the
% typeclass_info
list__append(ArgTypeClassInfoVars, ArgSuperClassVars, ArgVars0),
@@ -2433,7 +2404,7 @@
unqualify_name(ClassName, ClassNameString),
polymorphism__new_typeclass_info_var(Constraint, ClassNameString,
- BaseVar, VarSet0, VarSet1, VarTypes0, VarTypes1),
+ BaseVar, !Info),
module_info_instances(ModuleInfo, InstanceTable),
map__lookup(InstanceTable, ClassId, InstanceList),
@@ -2470,7 +2441,7 @@
% introduce a new variable
polymorphism__new_typeclass_info_var(Constraint, ClassNameString,
- NewVar, VarSet1, VarSet, VarTypes1, VarTypes),
+ NewVar, !Info),
% create the construction unification to initialize the
% variable
@@ -2504,8 +2475,7 @@
TypeClassInfoGoal = Unify - GoalInfo,
NewGoals0 = [TypeClassInfoGoal, BaseGoal],
- list__append(NewGoals0, SuperClassGoals, NewGoals),
- poly_info_set_varset_and_types(VarSet, VarTypes, !Info).
+ list__append(NewGoals0, SuperClassGoals, NewGoals).
%---------------------------------------------------------------------------%
@@ -2575,8 +2545,10 @@
poly_info_get_rtti_varmaps(!.Info, OldRttiVarMaps),
polymorphism__make_typeclass_info_head_vars(ExistentialConstraints,
ExtraTypeClassVars, !Info),
- polymorphism__update_typeclass_infos(ExistentialConstraints,
- ExtraTypeClassVars, !Info),
+ poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
+ list__foldl(rtti_reuse_typeclass_info_var, ExtraTypeClassVars,
+ RttiVarMaps0, RttiVarMaps),
+ poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
constraint_list_get_tvars(ExistentialConstraints, TVars0),
list__sort_and_remove_dups(TVars0, TVars),
@@ -3093,15 +3065,13 @@
prog_var::out, poly_info::in, poly_info::out) is det.
polymorphism__make_typeclass_info_head_var(Constraint, ExtraHeadVar, !Info) :-
- poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
(
+ poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
rtti_search_typeclass_info_var(RttiVarMaps0, Constraint,
ExistingVar)
->
ExtraHeadVar = ExistingVar
;
- poly_info_get_varset(!.Info, VarSet0),
- poly_info_get_var_types(!.Info, VarTypes0),
poly_info_get_module_info(!.Info, ModuleInfo),
Constraint = constraint(ClassName0, ClassTypes),
@@ -3119,7 +3089,7 @@
% Make a new variable to contain the dictionary for
% this typeclass constraint.
polymorphism__new_typeclass_info_var(Constraint, ClassName,
- ExtraHeadVar, VarSet0, VarSet1, VarTypes0, VarTypes1),
+ ExtraHeadVar, !Info),
% Find all the type variables in the constraint, and
% remember what index they appear in in the typeclass
@@ -3147,6 +3117,7 @@
% code which needs mode reordering and which calls
% existentially quantified predicates or
% deconstructs existentially quantified terms).
+ poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
IsNew = (pred(TypeVar0::in) is semidet :-
TypeVar0 = TypeVar - _Index,
(
@@ -3172,8 +3143,6 @@
),
list__foldl(MakeEntry, NewClassTypeVars, RttiVarMaps0,
RttiVarMaps),
-
- poly_info_set_varset_and_types(VarSet1, VarTypes1, !Info),
poly_info_set_rtti_varmaps(RttiVarMaps, !Info)
).
@@ -3182,17 +3151,24 @@
is_pair(_).
:- pred polymorphism__new_typeclass_info_var(prog_constraint::in, string::in,
- prog_var::out, prog_varset::in, prog_varset::out,
- map(prog_var, type)::in, map(prog_var, type)::out) is det.
+ prog_var::out, poly_info::in, poly_info::out) is det.
+
+polymorphism__new_typeclass_info_var(Constraint, ClassString, Var, !Info) :-
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
+ poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
-polymorphism__new_typeclass_info_var(Constraint, ClassString, Var,
- !VarSet, !VarTypes) :-
% introduce new variable
- varset__new_var(!.VarSet, Var, !:VarSet),
+ varset__new_var(VarSet0, Var, VarSet1),
string__append("TypeClassInfo_for_", ClassString, Name),
- varset__name_var(!.VarSet, Var, Name, !:VarSet),
+ varset__name_var(VarSet1, Var, Name, VarSet),
polymorphism__build_typeclass_info_type(Constraint, DictionaryType),
- map__set(!.VarTypes, Var, DictionaryType, !:VarTypes).
+ map__set(VarTypes0, Var, DictionaryType, VarTypes),
+ rtti_det_insert_typeclass_info_var(Constraint, Var,
+ RttiVarMaps0, RttiVarMaps),
+
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
+ poly_info_set_rtti_varmaps(RttiVarMaps, !Info).
polymorphism__build_typeclass_info_type(Constraint, DictionaryType) :-
Constraint = constraint(SymName, ArgTypes),
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/saved_vars.m,v
retrieving revision 1.50
diff -u -r1.50 saved_vars.m
--- compiler/saved_vars.m 16 Aug 2005 05:17:02 -0000 1.50
+++ compiler/saved_vars.m 16 Aug 2005 07:15:31 -0000
@@ -76,11 +76,13 @@
proc_info_goal(!.ProcInfo, Goal0),
proc_info_varset(!.ProcInfo, Varset0),
proc_info_vartypes(!.ProcInfo, VarTypes0),
- init_slot_info(Varset0, VarTypes0, TypeInfoLiveness, SlotInfo0),
+ proc_info_rtti_varmaps(!.ProcInfo, RttiVarMaps0),
+ init_slot_info(Varset0, VarTypes0, RttiVarMaps0, TypeInfoLiveness,
+ SlotInfo0),
saved_vars_in_goal(Goal0, Goal1, SlotInfo0, SlotInfo),
- final_slot_info(Varset1, VarTypes1, SlotInfo),
+ final_slot_info(Varset1, VarTypes1, RttiVarMaps, SlotInfo),
proc_info_headvars(!.ProcInfo, HeadVars),
% hlds_out__write_goal(Goal1, !.ModuleInfo, Varset1, 0, "\n"),
@@ -97,7 +99,8 @@
proc_info_set_goal(Goal, !ProcInfo),
proc_info_set_varset(Varset, !ProcInfo),
- proc_info_set_vartypes(VarTypes, !ProcInfo).
+ proc_info_set_vartypes(VarTypes, !ProcInfo),
+ proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo).
%-----------------------------------------------------------------------------%
@@ -510,29 +513,35 @@
---> slot_info(
prog_varset,
vartypes,
+ rtti_varmaps,
bool % TypeInfoLiveness
).
-:- pred init_slot_info(prog_varset::in, map(prog_var, type)::in, bool::in,
- slot_info::out) is det.
+:- pred init_slot_info(prog_varset::in, map(prog_var, type)::in,
+ rtti_varmaps::in, bool::in, slot_info::out) is det.
-init_slot_info(Varset, VarTypes, TypeInfoLiveness, SlotInfo) :-
- SlotInfo = slot_info(Varset, VarTypes, TypeInfoLiveness).
+init_slot_info(Varset, VarTypes, RttiVarMaps, TypeInfoLiveness, SlotInfo) :-
+ SlotInfo = slot_info(Varset, VarTypes, RttiVarMaps, TypeInfoLiveness).
-:- pred final_slot_info(prog_varset::out, vartypes::out, slot_info::in) is det.
+:- pred final_slot_info(prog_varset::out, vartypes::out, rtti_varmaps::out,
+ slot_info::in) is det.
-final_slot_info(Varset, VarTypes, slot_info(Varset, VarTypes, _)).
+final_slot_info(Varset, VarTypes, RttiVarMaps, SlotInfo) :-
+ SlotInfo = slot_info(Varset, VarTypes, RttiVarMaps, _).
:- pred rename_var(prog_var::in, prog_var::out, map(prog_var, prog_var)::out,
slot_info::in, slot_info::out) is det.
rename_var(Var, NewVar, Substitution, !SlotInfo) :-
- !.SlotInfo = slot_info(Varset0, VarTypes0, TypeInfoLiveness),
+ !.SlotInfo = slot_info(Varset0, VarTypes0, RttiVarMaps0,
+ TypeInfoLiveness),
varset__new_var(Varset0, NewVar, Varset),
map__from_assoc_list([Var - NewVar], Substitution),
map__lookup(VarTypes0, Var, Type),
map__det_insert(VarTypes0, NewVar, Type, VarTypes),
- !:SlotInfo = slot_info(Varset, VarTypes, TypeInfoLiveness).
+ rtti_var_info_duplicate(Var, NewVar, RttiVarMaps0, RttiVarMaps),
+ !:SlotInfo = slot_info(Varset, VarTypes, RttiVarMaps,
+ TypeInfoLiveness).
% Check whether it is ok to duplicate a given variable according
% to the information in the slot_info. If TypeInfoLiveness is set,
@@ -547,7 +556,7 @@
:- pred slot_info_do_not_duplicate_var(slot_info::in, prog_var::in) is semidet.
slot_info_do_not_duplicate_var(SlotInfo, Var) :-
- SlotInfo = slot_info(_, VarTypes, TypeInfoLiveness),
+ SlotInfo = slot_info(_, VarTypes, _, TypeInfoLiveness),
TypeInfoLiveness = yes,
map__lookup(VarTypes, Var, Type),
polymorphism__type_is_type_info_or_ctor_type(Type).
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.148
diff -u -r1.148 simplify.m
--- compiler/simplify.m 16 Aug 2005 10:42:38 -0000 1.148
+++ compiler/simplify.m 16 Aug 2005 11:57:29 -0000
@@ -2332,6 +2332,9 @@
:- pred simplify_info_set_module_info(module_info::in,
simplify_info::in, simplify_info::out) is det.
+:- pred simplify_info_apply_type_substitution(tsubst::in,
+ simplify_info::in, simplify_info::out) is det.
+
:- implementation.
simplify_info_set_det_info(Det, Info, Info ^ det_info := Det).
@@ -2379,6 +2382,18 @@
det_info_set_module_info(DetInfo0, ModuleInfo, DetInfo),
simplify_info_set_det_info(DetInfo, !Info).
+simplify_info_apply_type_substitution(TSubst, !Info) :-
+ simplify_info_get_var_types(!.Info, VarTypes0),
+ simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
+ ApplyTSubst = (pred(_::in, T0::in, T::out) is det :-
+ T = term__apply_rec_substitution(T0, TSubst)
+ ),
+ map__map_values(ApplyTSubst, VarTypes0, VarTypes),
+ apply_substitutions_to_rtti_varmaps(map__init, TSubst, map__init,
+ RttiVarMaps0, RttiVarMaps),
+ simplify_info_set_var_types(VarTypes, !Info),
+ simplify_info_set_rtti_varmaps(RttiVarMaps, !Info).
+
:- interface.
:- pred simplify_do_warn(simplify_info::in) is semidet.
--------------------------------------------------------------------------
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