for review: more existential types stuff [1/2]
Fergus Henderson
fjh at cs.mu.OZ.AU
Wed Jun 17 15:28:11 AEST 1998
DJ, can you please review this one too?
I've committed this on the `existential_types' branch for now.
P.S. Sorry if anyone gets this twice -- the original message was over
the 100k limit.
--------------------
Estimated hours taken: 20
Improve the support for existential types in the following ways:
1. Fix several bugs related to existentially typed predicates
(a bug with type inference, a bug with quantification of type_infos,
and some problems with the code generated by polymorphism.m to
construct type_infos).
2. Allow mixing of type classes and existential typed predicates/functions,
by adding support for existentially quantified type class constraints.
Existentially quantified constraints are introduced with `&' instead
of `<=', and should apply only to existentially quantified type variables.
(XXX this is not yet checked.)
3. Make a start towards allowing existentially typed data types.
The compiler now accepts quantifiers on type definitions, and
type checks them accordingly (XXX assuming all functor occurrences are
deconstructors, not constructors). But there's no special handling
for them in polymorphism.m, so it will abort and/or generate
incorrect code. Also type class constraints are not yet allowed.
There are still some bugs in the handling of inlining, specialization,
etc. for existentially typed predicates which this change does not fix.
compiler/polymorphism.m:
Lots of changes to support existentially quantified
type class constraints.
Also some changes to make the code more maintainable:
- add access predicates for the `poly_info' type,
and modify the code to use them.
- split up polymorphism__process_proc into several subroutines.
compiler/prog_data.m:
Add a new type `class_constraints', which holds two different
lists of constraints, namely the existentially quantified constraints
and the universally quantified ones.
Add a new field to the `constructor' data type (formerly just a pair)
to hold the existentially quantified type variables.
(TODO: add another field to hold the class constraints on those
type variables. I should have done that at the same time.)
compiler/prog_io.m:
Add code to parse the new constructs.
compiler/typecheck.m:
Fix a bug in the inference of which type variables are
existentially quantified. Ensure that we keep iterating
type inference if the set of existentially quantified type
variables changes.
Modify the code to support existentially quantified type class
constraints.
compiler/equiv_type.m:
compiler/make_hlds.m:
compiler/make_tags.m:
compiler/mercury_to_goedel.m:
compiler/mercury_to_mercury.m:
compiler/mode_util.m:
compiler/module_qual.m:
compiler/term_util.m:
compiler/type_util.m:
compiler/unify_proc.m:
Trivial changes to handle the new field in the `constructor' type.
compiler/check_typeclass.m:
compiler/dnf.m:
compiler/equiv_type.m:
compiler/hlds_pred.m:
compiler/lambda.m:
compiler/make_hlds.m:
compiler/mercury_to_mercury.m:
compiler/module_qual.m:
compiler/type_util.m:
Various minor changes to reflect the fact that class
constraints are now a pair of lists (for the universally
and existentially quantified constraints) rather than
a single list.
compiler/hlds_data.m:
Add a new field to hlds_cons_defn to hold the existentially
quantified type variables.
compiler/base_type_layout.m:
compiler/hlds_out.m:
compiler/make_hlds.m:
compiler/type_util.m:
compiler/typecheck.m:
Trivial changes to handle the new field in hlds_cons_defn.
compiler/goal_util.m:
compiler/polymorphism.m:
compiler/hlds_pred.m:
compiler/lambda.m:
Include type_infos for existentially quantified type variables
in the set of extra type_info variables computed by
goal_util__extra_type_info_vars.
Index: compiler/base_type_layout.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/base_type_layout.m,v
retrieving revision 1.30
diff -u -r1.30 base_type_layout.m
--- base_type_layout.m 1998/05/25 21:48:45 1.30
+++ base_type_layout.m 1998/06/06 17:31:07
@@ -1218,9 +1218,9 @@
(
map__search(ConsTable, ConsId, HldsConsList),
list__filter(lambda([X::in] is semidet, (
- X = hlds_cons_defn(_, TypeId, _))),
+ X = hlds_cons_defn(_, _, TypeId, _))),
HldsConsList,
- [hlds_cons_defn(TypeArgs0, _, _)])
+ [hlds_cons_defn(_, TypeArgs0, _, _)])
->
TypeArgs = TypeArgs0
;
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.9.2.1
diff -u -r1.9.2.1 check_typeclass.m
--- check_typeclass.m 1998/06/06 11:39:28 1.9.2.1
+++ check_typeclass.m 1998/06/08 08:48:13
@@ -161,7 +161,7 @@
arity, % Arity of the method.
list(type), % Expected types of
% arguments.
- list(class_constraint), % Constraints from
+ class_constraints, % Constraints from
% class method.
list(pair(list(mode), determinism)), % Modes and
% determinisms of the
@@ -205,9 +205,10 @@
% declaration, we don't check that constraint... the instance
% declaration itself satisfies it!
(
- ClassContext0 = [_|Tail]
+ ClassContext0 = constraints([_|OtherUnivCs], ExistCs)
->
- ClassContext = Tail
+ UnivCs = OtherUnivCs,
+ ClassContext = constraints(UnivCs, ExistCs)
;
error("check_instance_pred: no constraint on class method")
),
@@ -406,7 +407,7 @@
RenameSubst),
term__apply_substitution_to_list(InstanceTypes0, RenameSubst,
InstanceTypes),
- apply_subst_to_constraints(RenameSubst, InstanceConstraints0,
+ apply_subst_to_constraint_list(RenameSubst, InstanceConstraints0,
InstanceConstraints),
% Work out what the type variables are bound to for this
@@ -419,7 +420,9 @@
% constraints from the class method. This allows an instance
% method to have constraints on it which are part of the
% instance declaration as a whole.
- list__append(InstanceConstraints, ClassContext1, ClassContext),
+ ClassContext1 = constraints(UnivConstraints1, ExistConstraints),
+ list__append(InstanceConstraints, UnivConstraints1, UnivConstraints),
+ ClassContext = constraints(UnivConstraints, ExistConstraints),
Info1 = instance_method_info(ModuleInfo, PredName, PredArity,
ArgTypes, ClassContext, ArgModes, Errors0, ArgTypeVars,
@@ -669,7 +672,7 @@
Subst),
% Make the constraints in terms of the instance variables
- apply_subst_to_constraints(Subst, SuperClasses0, SuperClasses),
+ apply_subst_to_constraint_list(Subst, SuperClasses0, SuperClasses),
% Now handle the class variables
map__apply_to_list(ClassVars0, Subst, ClassVarTerms),
@@ -694,7 +697,7 @@
typecheck__reduce_context_by_rule_application(InstanceTable,
SuperClassTable, InstanceConstraints, TypeSubst,
InstanceVarSet1, InstanceVarSet2,
- Proofs0, Proofs1, SuperClasses,
+ Proofs0, Proofs1, SuperClasses,
[])
->
Errors = Errors0,
Index: compiler/dnf.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dnf.m,v
retrieving revision 1.30
diff -u -r1.30 dnf.m
--- dnf.m 1998/04/27 04:00:55 1.30
+++ dnf.m 1998/06/06 18:59:59
@@ -157,7 +157,7 @@
:- type dnf_info ---> dnf_info(
tvarset,
map(var, type),
- list(class_constraint),
+ class_constraints,
varset,
pred_markers,
map(tvar, type_info_locn),
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/equiv_type.m,v
retrieving revision 1.15.2.1
diff -u -r1.15.2.1 equiv_type.m
--- equiv_type.m 1998/06/06 11:39:32 1.15.2.1
+++ equiv_type.m 1998/06/06 17:32:51
@@ -147,7 +147,7 @@
typeclass(Constraints, ClassName, Vars,
ClassInterface, VarSet),
no) :-
- equiv_type__replace_in_class_constraints(Constraints0, VarSet0,
+ equiv_type__replace_in_class_constraint_list(Constraints0, VarSet0,
EqvMap, Constraints, VarSet),
equiv_type__replace_in_class_interface(ClassInterface0,
EqvMap, ClassInterface).
@@ -159,7 +159,7 @@
instance(Constraints, ClassName, Ts,
InstanceInterface, VarSet),
no) :-
- equiv_type__replace_in_class_constraints(Constraints0, VarSet0,
+ equiv_type__replace_in_class_constraint_list(Constraints0, VarSet0,
EqvMap, Constraints, VarSet1),
equiv_type__replace_in_type_list(Ts0, VarSet1, EqvMap, Ts, VarSet, _).
@@ -184,16 +184,29 @@
%-----------------------------------------------------------------------------%
-:- pred equiv_type__replace_in_class_constraints(list(class_constraint),
- varset, eqv_map, list(class_constraint), varset).
+:- pred equiv_type__replace_in_class_constraints(class_constraints,
+ varset, eqv_map, class_constraints, varset).
:- mode equiv_type__replace_in_class_constraints(in, in, in, out, out) is det.
-equiv_type__replace_in_class_constraints([], VarSet, _, [], VarSet).
-equiv_type__replace_in_class_constraints([C0|C0s], VarSet0, EqvMap,
+equiv_type__replace_in_class_constraints(Cs0, VarSet0, EqvMap, Cs, VarSet) :-
+ Cs0 = constraints(UnivCs0, ExistCs0),
+ Cs = constraints(UnivCs, ExistCs),
+ equiv_type__replace_in_class_constraint_list(UnivCs0, VarSet0, EqvMap,
+ UnivCs, VarSet1),
+ equiv_type__replace_in_class_constraint_list(ExistCs0, VarSet1, EqvMap,
+ ExistCs, VarSet).
+
+:- pred equiv_type__replace_in_class_constraint_list(list(class_constraint),
+ varset, eqv_map, list(class_constraint), varset).
+:- mode equiv_type__replace_in_class_constraint_list(in, in, in, out, out)
+ is det.
+
+equiv_type__replace_in_class_constraint_list([], VarSet, _, [], VarSet).
+equiv_type__replace_in_class_constraint_list([C0|C0s], VarSet0, EqvMap,
[C|Cs], VarSet) :-
equiv_type__replace_in_class_constraint(C0, VarSet0, EqvMap, C,
VarSet1),
- equiv_type__replace_in_class_constraints(C0s, VarSet1, EqvMap, Cs,
+ equiv_type__replace_in_class_constraint_list(C0s, VarSet1, EqvMap, Cs,
VarSet).
:- pred equiv_type__replace_in_class_constraint(class_constraint, varset,
@@ -284,8 +297,8 @@
constructor, tvarset).
:- mode equiv_type__replace_in_ctor(in, in, in, out, out) is det.
-equiv_type__replace_in_ctor(TName - Targs0, VarSet0, EqvMap,
- TName - Targs, VarSet) :-
+equiv_type__replace_in_ctor(ctor(ExistQVars, TName, Targs0), VarSet0, EqvMap,
+ ctor(ExistQVars, TName, Targs), VarSet) :-
equiv_type__replace_in_ctor_arg_list(Targs0, VarSet0, EqvMap,
Targs, VarSet, _).
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.45
diff -u -r1.45 goal_util.m
--- goal_util.m 1998/04/27 04:00:58 1.45
+++ goal_util.m 1998/06/16 13:25:24
@@ -70,17 +70,17 @@
%
% A type-info variable may be non-local to a goal if any of
% the ordinary non-local variables for that goal are
- % polymorphically typed with a type that depends on that
- % type-info variable.
+ % polymorphically or existentially typed with a type
+ % that depends on that type-info variable.
%
% In addition, a typeclass-info may be non-local to a goal if
% any of the non-local variables for that goal are
- % polymorphically typed and are constrained by the typeclass
- % constraints for that typeclass-info variable.
+ % polymorphically or existentially typed and are constrained
+ % by the typeclass constraints for that typeclass-info variable.
%
-:- pred goal_util__extra_nonlocal_typeinfos(map(var, type_info_locn),
- map(var, type), hlds_goal, set(var)).
-:- mode goal_util__extra_nonlocal_typeinfos(in, in, in, out) is det.
+:- pred goal_util__extra_nonlocal_typeinfos(map(tvar, type_info_locn),
+ map(var, type), existq_tvars, hlds_goal, set(var)).
+:- mode goal_util__extra_nonlocal_typeinfos(in, in, in, in, out) is det.
% See whether the goal is a branched structure.
:- pred goal_util__goal_is_branched(hlds_goal_expr).
@@ -520,7 +520,7 @@
%-----------------------------------------------------------------------------%
-goal_util__extra_nonlocal_typeinfos(TypeVarMap, VarTypes,
+goal_util__extra_nonlocal_typeinfos(TypeVarMap, VarTypes, ExistQVars,
Goal0, NonLocalTypeInfos) :-
Goal0 = _ - GoalInfo0,
goal_info_get_nonlocals(GoalInfo0, NonLocals),
@@ -530,8 +530,10 @@
% Find all the type-infos and typeclass-infos that are
% non-local
solutions_set(lambda([Var::out] is nondet, (
- list__member(TheVar, NonLocalTypeVars),
- map__search(TypeVarMap, TheVar, Location),
+ ( list__member(TypeVar, NonLocalTypeVars)
+ ; list__member(TypeVar, ExistQVars)
+ ),
+ map__search(TypeVarMap, TypeVar, Location),
type_info_locn_var(Location, Var)
)), NonLocalTypeInfos).
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.24
diff -u -r1.24 hlds_data.m
--- hlds_data.m 1998/05/15 07:07:07 1.24
+++ hlds_data.m 1998/06/06 16:55:34
@@ -49,7 +49,9 @@
:- type hlds_cons_defn
---> hlds_cons_defn(
- % maybe add tvarset?
+ % maybe add tvarset here?
+ % you can get the tvarset from the hlds__type_defn.
+ existq_tvars,
list(type), % The types of the arguments
% of this functor (if any)
type_id, % The result type, i.e. the
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.193.2.1
diff -u -r1.193.2.1 hlds_out.m
--- hlds_out.m 1998/06/06 11:39:36 1.193.2.1
+++ hlds_out.m 1998/06/06 18:36:48
@@ -1939,7 +1939,8 @@
:- pred hlds_out__write_constructor(tvarset, constructor, io__state, io__state).
:- mode hlds_out__write_constructor(in, in, di, uo) is det.
-hlds_out__write_constructor(Tvarset, Name - Args) -->
+hlds_out__write_constructor(Tvarset, ctor(ExistQVars, Name, Args)) -->
+ mercury_output_quantifier(Tvarset, ExistQVars),
prog_out__write_sym_name(Name),
( { Args = [Arg | Rest] } ->
io__write_char('('),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.48.2.1
diff -u -r1.48.2.1 hlds_pred.m
--- hlds_pred.m 1998/06/06 11:39:37 1.48.2.1
+++ hlds_pred.m 1998/06/16 13:24:15
@@ -266,7 +266,7 @@
% call the created predicate.
:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(var),
instmap, string, tvarset, map(var, type),
- list(class_constraint), map(tvar, type_info_locn),
+ class_constraints, map(tvar, type_info_locn),
map(class_constraint, var), varset, pred_markers,
module_info, module_info, pred_proc_id).
:- mode hlds_pred__define_new_pred(in, out, in, in, in, in, in,
@@ -277,14 +277,14 @@
:- pred pred_info_init(module_name, sym_name, arity, tvarset, existq_tvars,
list(type), condition, term__context, clauses_info, import_status,
- pred_markers, goal_type, pred_or_func, list(class_constraint),
+ pred_markers, goal_type, pred_or_func, class_constraints,
map(class_constraint, constraint_proof), pred_info).
:- mode pred_info_init(in, in, in, in, in, in, in, in, in, in, in, in, in,
in, in, out) is det.
:- pred pred_info_create(module_name, sym_name, tvarset, existq_tvars,
list(type), condition, term__context, import_status, pred_markers,
- pred_or_func, list(class_constraint), proc_info, proc_id, pred_info).
+ pred_or_func, class_constraints, proc_info, proc_id, pred_info).
:- mode pred_info_create(in, in, in, in, in, in, in, in, in, in, in, in,
out, out) is det.
@@ -397,11 +397,10 @@
:- pred pred_info_get_is_pred_or_func(pred_info, pred_or_func).
:- mode pred_info_get_is_pred_or_func(in, out) is det.
-:- pred pred_info_get_class_context(pred_info, list(class_constraint)).
+:- pred pred_info_get_class_context(pred_info, class_constraints).
:- mode pred_info_get_class_context(in, out) is det.
-:- pred pred_info_set_class_context(pred_info, list(class_constraint),
- pred_info).
+:- pred pred_info_set_class_context(pred_info, class_constraints, pred_info).
:- mode pred_info_set_class_context(in, in, out) is det.
:- pred pred_info_get_constraint_proofs(pred_info,
@@ -505,7 +504,7 @@
pred_markers, % various boolean flags
pred_or_func, % whether this "predicate" was really
% a predicate or a function
- list(class_constraint),
+ class_constraints,
% the class constraints on the
% predicate
map(class_constraint, constraint_proof),
@@ -802,6 +801,10 @@
goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap),
+ % XXX The set of existentially quantified type variables
+ % here might not be correct.
+ ExistQVars = [],
+
% If typeinfo_liveness is set, all type_infos for the argument
% variables need to be passed in, not just the ones that are used.
module_info_globals(ModuleInfo0, Globals),
@@ -809,7 +812,7 @@
TypeInfoLiveness),
( TypeInfoLiveness = yes ->
goal_util__extra_nonlocal_typeinfos(TVarMap, VarTypes0,
- Goal0, ExtraTypeInfos0),
+ ExistQVars, Goal0, ExtraTypeInfos0),
set__delete_list(ExtraTypeInfos0, ArgVars0, ExtraTypeInfos),
set__to_sorted_list(ExtraTypeInfos, ExtraArgs),
list__append(ExtraArgs, ArgVars0, ArgVars)
@@ -845,10 +848,6 @@
Detism, Goal0, Context, TVarMap, TCVarMap, ArgsMethod,
ProcInfo0),
proc_info_set_maybe_termination_info(ProcInfo0, TermInfo, ProcInfo),
-
- % XXX The set of existentially quantified type variables
- % here might not be correct.
- ExistQVars = [],
pred_info_create(ModuleName, SymName, TVarSet, ExistQVars, ArgTypes,
true, Context, local, Markers, predicate, ClassContext,
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.42.2.1
diff -u -r1.42.2.1 lambda.m
--- lambda.m 1998/06/06 11:39:40 1.42.2.1
+++ lambda.m 1998/06/16 13:23:24
@@ -48,7 +48,7 @@
:- pred lambda__transform_lambda(pred_or_func, string, list(var), list(mode),
determinism, list(var), set(var), hlds_goal, unification,
- varset, map(var, type), list(class_constraint), tvarset,
+ varset, map(var, type), class_constraints, tvarset,
map(tvar, type_info_locn), map(class_constraint, var),
module_info, unify_rhs, unification, module_info).
:- mode lambda__transform_lambda(in, in, in, in, in, in, in, in, in, in, in,
@@ -68,7 +68,7 @@
lambda_info(
varset, % from the proc_info
map(var, type), % from the proc_info
- list(class_constraint), % from the pred_info
+ class_constraints, % from the pred_info
tvarset, % from the proc_info
map(tvar, type_info_locn),
% from the proc_info
@@ -238,7 +238,8 @@
Unification0, Functor, Unification, LambdaInfo0, LambdaInfo) :-
LambdaInfo0 = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
TVarMap, TCVarMap, POF, PredName, ModuleInfo0),
- goal_util__extra_nonlocal_typeinfos(TVarMap, VarTypes,
+ ExistQVars = [],
+ goal_util__extra_nonlocal_typeinfos(TVarMap, VarTypes, ExistQVars,
LambdaGoal, ExtraTypeInfos),
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals0, ExtraTypeInfos, LambdaGoal, Unification0,
@@ -355,9 +356,9 @@
goal_info_get_context(LambdaGoalInfo, LambdaContext),
% The TVarSet is a superset of what it really ought be,
% but that shouldn't matter.
- % Currently lambda expressions are always monomorphic
- % in Mercury, so there are no existentially quantified
- % type variables (no universally quantified tvars either).
+ % Currently we don't allow existentially typed lambda
+ % expressions (we can change this if/when we allow
+ % `in' modes for existentially typed arguments)
ExistQVars = [],
lambda__uni_modes_to_modes(UniModes1, OrigArgModes),
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.265.2.1
diff -u -r1.265.2.1 make_hlds.m
--- make_hlds.m 1998/06/06 11:39:41 1.265.2.1
+++ make_hlds.m 1998/06/06 19:01:37
@@ -1140,10 +1140,11 @@
:- mode ctors_add(in, in, in, in, in, out, di, uo) is det.
ctors_add([], _TypeId, _NeedQual, _Context, Ctors, Ctors) --> [].
-ctors_add([Name - Args | Rest], TypeId, NeedQual, Context, Ctors0, Ctors) -->
+ctors_add([Ctor | Rest], TypeId, NeedQual, Context, Ctors0, Ctors) -->
+ { Ctor = ctor(ExistQVars, Name, Args) },
{ make_cons_id(Name, Args, TypeId, QualifiedConsId) },
{ assoc_list__values(Args, Types) },
- { ConsDefn = hlds_cons_defn(Types, TypeId, Context) },
+ { ConsDefn = hlds_cons_defn(ExistQVars, Types, TypeId, Context) },
(
{ map__search(Ctors0, QualifiedConsId, QualifiedConsDefns0) }
->
@@ -1153,7 +1154,7 @@
),
(
{ list__member(OtherConsDefn, QualifiedConsDefns1) },
- { OtherConsDefn = hlds_cons_defn(_, TypeId, _) }
+ { OtherConsDefn = hlds_cons_defn(_, _, TypeId, _) }
->
% XXX we should record each error using module_info_incr_errors
io__stderr_stream(StdErr),
@@ -1207,8 +1208,7 @@
:- pred module_add_pred(module_info, varset, existq_tvars, sym_name,
list(type_and_mode), maybe(determinism), condition, purity,
- list(class_constraint),
- pred_markers, term__context, item_status,
+ class_constraints, pred_markers, term__context, item_status,
maybe(pair(pred_id, proc_id)), module_info,
io__state, io__state).
:- mode module_add_pred(in, in, in, in, in, in, in, in, in, in, in, in,
@@ -1243,7 +1243,7 @@
:- pred module_add_func(module_info, varset, existq_tvars, sym_name,
list(type_and_mode),
type_and_mode, maybe(determinism), condition, purity,
- list(class_constraint), pred_markers, term__context,
+ class_constraints, pred_markers, term__context,
item_status, maybe(pair(pred_id, proc_id)),
module_info, io__state, io__state).
:- mode module_add_func(in, in, in, in, in, in, in, in, in, in, in, in, in, out, out, di, uo) is det.
@@ -1376,7 +1376,9 @@
{ Method = pred(VarSet, ExistQVars, PredName, TypesAndModes,
MaybeDet, Cond, ClassContext, Context) },
{ term__var_list_to_term_list(Vars, VarTerms) },
- { NewClassContext = [constraint(Name, VarTerms)|ClassContext] },
+ { ClassContext = constraints(UnivCnstrs, ExistCnstrs) },
+ { NewUnivCnstrs = [constraint(Name, VarTerms) | UnivCnstrs] },
+ { NewClassContext = constraints(NewUnivCnstrs, ExistCnstrs) },
{ init_markers(Markers0) },
{ add_marker(Markers0, class_method, Markers) },
module_add_pred(Module0, VarSet, ExistQVars, PredName,
@@ -1387,7 +1389,9 @@
RetTypeAndMode, MaybeDet, Cond, ClassContext,
Context) },
{ term__var_list_to_term_list(Vars, VarTerms) },
- { NewClassContext = [constraint(Name, VarTerms)|ClassContext] },
+ { ClassContext = constraints(UnivCnstrs, ExistCnstrs) },
+ { NewUnivCnstrs = [constraint(Name, VarTerms) | UnivCnstrs] },
+ { NewClassContext = constraints(NewUnivCnstrs, ExistCnstrs) },
{ init_markers(Markers0) },
{ add_marker(Markers0, class_method, Markers) },
module_add_func(Module0, VarSet, ExistQVars, FuncName,
@@ -1503,7 +1507,7 @@
%-----------------------------------------------------------------------------%
:- pred add_new_pred(module_info, tvarset, existq_tvars, sym_name, list(type),
- condition, purity, list(class_constraint), pred_markers,
+ condition, purity, class_constraints, pred_markers,
term__context, import_status, need_qualifier, pred_or_func,
module_info, io__state, io__state).
:- mode add_new_pred(in, in, in, in, in, in, in, in, in, in, in, in, in, out,
@@ -1724,7 +1728,7 @@
init_markers(Markers),
% XXX If/when we have "comparable" or "unifiable" typeclasses,
% XXX this context might not be empty
- ClassContext = [],
+ ClassContext = constraints([], []),
ExistQVars = [],
pred_info_init(ModuleName, PredName, Arity, TVarSet, ExistQVars,
ArgTypes, Cond, Context, ClausesInfo0, Status, Markers,
@@ -1883,7 +1887,7 @@
map__init(Proofs),
% The class context is empty since this is an implicit
% definition. Inference will fill it in.
- ClassContext = [],
+ ClassContext = constraints([], []),
% We assume none of the arguments are existentially typed.
% Existential types must be declared, they won't be inferred.
ExistQVars = [],
Index: compiler/make_tags.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_tags.m,v
retrieving revision 1.27
diff -u -r1.27 make_tags.m
--- make_tags.m 1998/03/03 17:35:02 1.27
+++ make_tags.m 1998/06/06 17:35:46
@@ -108,7 +108,8 @@
:- mode assign_enum_constants(in, in, in, out) is det.
assign_enum_constants([], _, CtorTags, CtorTags).
-assign_enum_constants([Name - Args | Rest], Val, CtorTags0, CtorTags) :-
+assign_enum_constants([ctor(_ExistQVars, Name, Args) | Rest], Val,
+ CtorTags0, CtorTags) :-
create_cons_id(Name, Args, ConsId),
Tag = int_constant(Val),
map__set(CtorTags0, ConsId, Tag, CtorTags1),
@@ -144,12 +145,13 @@
:- mode assign_simple_tags(in, in, in, in, out) is det.
assign_simple_tags([], _, _, CtorTags, CtorTags).
-assign_simple_tags([Name - Args | Rest], Val, MaxTag, CtorTags0, CtorTags) :-
+assign_simple_tags([Ctor | Rest], Val, MaxTag, CtorTags0, CtorTags) :-
+ Ctor = ctor(_ExistQVars, Name, Args),
create_cons_id(Name, Args, ConsId),
% if we're about to run out of simple tags, start assigning
% complicated tags instead
( Val = MaxTag, Rest \= [] ->
- assign_complicated_tags([Name - Args | Rest], MaxTag, 0,
+ assign_complicated_tags([Ctor | Rest], MaxTag, 0,
CtorTags0, CtorTags)
;
Tag = simple_tag(Val),
@@ -163,8 +165,9 @@
:- mode assign_complicated_tags(in, in, in, in, out) is det.
assign_complicated_tags([], _, _, CtorTags, CtorTags).
-assign_complicated_tags([Name - Args | Rest], PrimaryVal, SecondaryVal,
+assign_complicated_tags([Ctor | Rest], PrimaryVal, SecondaryVal,
CtorTags0, CtorTags) :-
+ Ctor = ctor(_ExistQVars, Name, Args),
create_cons_id(Name, Args, ConsId),
Tag = complicated_tag(PrimaryVal, SecondaryVal),
map__set(CtorTags0, ConsId, Tag, CtorTags1),
@@ -177,8 +180,9 @@
:- mode assign_complicated_constant_tags(in, in, in, in, out) is det.
assign_complicated_constant_tags([], _, _, CtorTags, CtorTags).
-assign_complicated_constant_tags([Name - Args | Rest], PrimaryVal,
- SecondaryVal, CtorTags0, CtorTags) :-
+assign_complicated_constant_tags([Ctor | Rest], PrimaryVal, SecondaryVal,
+ CtorTags0, CtorTags) :-
+ Ctor = ctor(_ExistQVars, Name, Args),
create_cons_id(Name, Args, ConsId),
Tag = complicated_constant_tag(PrimaryVal, SecondaryVal),
map__set(CtorTags0, ConsId, Tag, CtorTags1),
@@ -200,7 +204,7 @@
:- mode ctors_are_all_constants(in) is semidet.
ctors_are_all_constants([]).
-ctors_are_all_constants([_Name - Args | Rest]) :-
+ctors_are_all_constants([ctor(_ExistQVars, _Name, Args) | Rest]) :-
Args = [],
ctors_are_all_constants(Rest).
@@ -212,7 +216,7 @@
split_constructors([], [], []).
split_constructors([Ctor | Ctors], Constants, Functors) :-
- Ctor = _Name - Args,
+ Ctor = ctor(_ExistQVars, _Name, Args),
( Args = [] ->
Constants = [Ctor | Constants0],
Functors = Functors0
Index: compiler/mercury_to_goedel.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_goedel.m,v
retrieving revision 1.63.2.1
diff -u -r1.63.2.1 mercury_to_goedel.m
--- mercury_to_goedel.m 1998/06/06 11:39:44 1.63.2.1
+++ mercury_to_goedel.m 1998/06/06 17:38:28
@@ -332,9 +332,10 @@
:- mode goedel_output_ctors(in, in, in, di, uo) is det.
goedel_output_ctors([], _, _) --> [].
-goedel_output_ctors([Name - Args | Ctors], Type, VarSet) -->
- { unqualify_name(Name, Name2),
- convert_functor_name(Name2, Name3) },
+goedel_output_ctors([Ctor | Ctors], Type, VarSet) -->
+ { Ctor = ctor(_ExistQVars, Name, Args) },
+ { unqualify_name(Name, Name2) },
+ { convert_functor_name(Name2, Name3) },
(
{ Args = [_ArgName - ArgType | Rest] }
->
@@ -461,7 +462,7 @@
goedel_output_func_type(VarSet, FuncName, Types, RetType, _Context) -->
{ list__map(lambda([Type::in, Arg::out] is det, (Arg = "" - Type)),
Types, Args) },
- goedel_output_ctors([FuncName - Args], RetType, VarSet).
+ goedel_output_ctors([ctor([], FuncName, Args)], RetType, VarSet).
%-----------------------------------------------------------------------------%
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.136.2.1
diff -u -r1.136.2.1 mercury_to_mercury.m
--- mercury_to_mercury.m 1998/06/06 11:39:45 1.136.2.1
+++ mercury_to_mercury.m 1998/06/06 19:01:56
@@ -32,13 +32,13 @@
:- mode convert_to_mercury(in, in, in, di, uo) is det.
:- pred mercury_output_pred_type(tvarset, existq_tvars, sym_name, list(type),
- maybe(determinism), purity, list(class_constraint),
+ maybe(determinism), purity, class_constraints,
term__context, io__state, io__state).
:- mode mercury_output_pred_type(in, in, in, in, in, in, in, in, di, uo) is det.
:- pred mercury_output_func_type(tvarset, existq_tvars, sym_name,
list(type), type,
- maybe(determinism), purity, list(class_constraint),
+ maybe(determinism), purity, class_constraints,
term__context, io__state, io__state).
:- mode mercury_output_func_type(in, in, in, in, in, in, in, in, in,
di, uo) is det.
@@ -170,6 +170,10 @@
io__state, io__state).
:- mode mercury_output_constraint(in, in, di, uo) is det.
+ % output an existential quantifier
+:- pred mercury_output_quantifier(tvarset, existq_tvars, io__state, io__state).
+:- mode mercury_output_quantifier(in, in, di, uo) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -369,14 +373,7 @@
),
io__write_char(')'),
- (
- { Constraints = [] }
- ;
- { Constraints = [_|_] },
- io__write_string(" <= ("),
- output_class_constraints(Constraints, VarSet),
- io__write_string(")")
- ),
+ mercury_output_class_constraint_list(Constraints, VarSet, "<="),
io__write_string(" where [\n"),
@@ -396,14 +393,7 @@
io__write_char(')'),
io__write_char(')'),
- (
- { Constraints = [] }
- ;
- { Constraints = [_|_] },
- io__write_string(" <= ("),
- output_class_constraints(Constraints, VarSet),
- io__write_string(")")
- ),
+ mercury_output_class_constraint_list(Constraints, VarSet, "<="),
io__write_string(" where [\n"),
@@ -412,21 +402,6 @@
io__write_string("\n].\n").
%-----------------------------------------------------------------------------%
-:- pred output_class_constraints(list(class_constraint), varset,
- io__state, io__state).
-:- mode output_class_constraints(in, in, di, uo) is det.
-
-output_class_constraints(Constraints, VarSet) -->
- io__write_list(Constraints, ", ", output_class_constraint(VarSet)).
-
-:- pred output_class_constraint(varset, class_constraint, io__state, io__state).
-:- mode output_class_constraint(in, in, di, uo) is det.
-
-output_class_constraint(VarSet, constraint(Name, Types)) -->
- mercury_output_sym_name(Name),
- io__write_char('('),
- io__write_list(Types, ", ", term_io__write_term(VarSet)),
- io__write_char(')').
:- pred output_class_methods(list(class_method), io__state, io__state).
:- mode output_class_methods(in, di, uo) is det.
@@ -1177,7 +1152,9 @@
:- mode mercury_output_ctors(in, in, di, uo) is det.
mercury_output_ctors([], _) --> [].
-mercury_output_ctors([Name - Args | Ctors], VarSet) -->
+mercury_output_ctors([Ctor | Ctors], VarSet) -->
+ { Ctor = ctor(ExistQVars, Name, Args) },
+
% we need to quote ';'/2 and '{}'/2
{ list__length(Args, Arity) },
(
@@ -1188,6 +1165,7 @@
;
[]
),
+ mercury_output_quantifier(VarSet, ExistQVars),
(
{ Args = [Arg | Rest] }
->
@@ -1241,7 +1219,7 @@
:- pred mercury_output_pred_decl(tvarset, existq_tvars,
sym_name, list(type_and_mode),
- maybe(determinism), purity, list(class_constraint),
+ maybe(determinism), purity, class_constraints,
term__context, string, string, string, io__state, io__state).
:- mode mercury_output_pred_decl(in, in, in, in, in, in, in, in, in, in, in,
di, uo) is det.
@@ -1272,7 +1250,7 @@
:- pred mercury_output_pred_type_2(tvarset, existq_tvars, sym_name, list(type),
- maybe(determinism), purity, list(class_constraint),
+ maybe(determinism), purity, class_constraints,
term__context, string, string, io__state, io__state).
:- mode mercury_output_pred_type_2(in, in, in, in, in, in, in, in, in, in,
di, uo) is det.
@@ -1326,7 +1304,7 @@
:- pred mercury_output_func_decl(tvarset, existq_tvars, sym_name,
list(type_and_mode), type_and_mode, maybe(determinism),
- purity, list(class_constraint), term__context, string, string,
+ purity, class_constraints, term__context, string, string,
string, io__state, io__state).
:- mode mercury_output_func_decl(in, in, in, in, in, in, in, in, in, in, in,
in, di, uo) is det.
@@ -1359,7 +1337,7 @@
":- ", ".\n").
:- pred mercury_output_func_type_2(varset, existq_tvars, sym_name, list(type),
- type, maybe(determinism), purity, list(class_constraint),
+ type, maybe(determinism), purity, class_constraints,
term__context, string, string, io__state, io__state).
:- mode mercury_output_func_type_2(in, in, in, in, in, in, in, in, in, in, in,
di, uo) is det.
@@ -1390,9 +1368,6 @@
%-----------------------------------------------------------------------------%
-:- pred mercury_output_quantifier(tvarset, list(tvar), io__state, io__state).
-:- mode mercury_output_quantifier(in, in, di, uo) is det.
-
mercury_output_quantifier(VarSet, ExistQVars) -->
( { ExistQVars = [] } ->
[]
@@ -1404,17 +1379,26 @@
%-----------------------------------------------------------------------------%
-:- pred mercury_output_class_context(list(class_constraint), varset,
+:- pred mercury_output_class_context(class_constraints, varset,
io__state, io__state).
:- mode mercury_output_class_context(in, in, di, uo) is det.
mercury_output_class_context(ClassContext, VarSet) -->
+ { ClassContext = constraints(UnivCs, ExistCs) },
+ mercury_output_class_constraint_list(ExistCs, VarSet, "&"),
+ mercury_output_class_constraint_list(UnivCs, VarSet, "<=").
+
+:- pred mercury_output_class_constraint_list(list(class_constraint), varset,
+ string, io__state, io__state).
+:- mode mercury_output_class_constraint_list(in, in, in, di, uo) is det.
+
+mercury_output_class_constraint_list(Constraints, VarSet, Operator) -->
(
- { ClassContext = [] }
+ { Constraints = [] }
;
- { ClassContext = [_|_] },
- io__write_string(" <= ("),
- io__write_list(ClassContext, ", ",
+ { Constraints = [_|_] },
+ io__write_strings([" ", Operator, " ("]),
+ io__write_list(Constraints, ", ",
mercury_output_constraint(VarSet)),
io__write_char(')')
).
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.109
diff -u -r1.109 mode_util.m
--- mode_util.m 1998/05/25 21:48:50 1.109
+++ mode_util.m 1998/06/06 19:02:50
@@ -761,7 +761,7 @@
constructors_to_bound_insts([], _, _, []).
constructors_to_bound_insts([Ctor | Ctors], Uniq, ModuleInfo,
[BoundInst | BoundInsts]) :-
- Ctor = Name - Args,
+ Ctor = ctor(_ExistQVars, Name, Args),
ctor_arg_list_to_inst_list(Args, Uniq, Insts),
list__length(Insts, Arity),
BoundInst = functor(cons(Name, Arity), Insts),
@@ -819,12 +819,12 @@
(
ConsId = cons(ConsName, Arity),
GetCons = lambda([Ctor::in] is semidet, (
- Ctor = ConsName - CtorArgs,
+ Ctor = ctor(_, ConsName, CtorArgs),
list__length(CtorArgs, Arity)
)),
list__filter(GetCons, Constructors, [Constructor])
->
- Constructor = _ - Args,
+ Constructor = ctor(_ExistQVars, _Name, Args),
GetArgTypes = lambda([CtorArg::in, ArgType::out] is det, (
CtorArg = _ArgName - ArgType
)),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.36.2.1
diff -u -r1.36.2.1 module_qual.m
--- module_qual.m 1998/06/06 11:39:47 1.36.2.1
+++ module_qual.m 1998/06/06 18:07:12
@@ -336,7 +336,7 @@
{ list__length(Vars, Arity) },
{ Id = Name - Arity },
{ mq_info_set_error_context(Info0, class(Id) - Context, Info1) },
- qualify_class_constraints(Constraints0, Constraints, Info1, Info2),
+ qualify_class_constraint_list(Constraints0, Constraints, Info1, Info2),
qualify_class_interface(Interface0, Interface, Info2, Info).
module_qualify_item(instance(Constraints0, Name0, Types0, Interface0, VarSet) -
@@ -349,7 +349,7 @@
{ mq_info_set_error_context(Info0, instance(Id) - Context, Info1) },
% We don't qualify the implementation yet, since that requires
% us to resolve overloading.
- qualify_class_constraints(Constraints0, Constraints, Info1, Info2),
+ qualify_class_constraint_list(Constraints0, Constraints, Info1, Info2),
qualify_class_name(Id, Name - _, Info2, Info3),
qualify_type_list(Types0, Types, Info3, Info),
{ qualify_instance_interface(Name, Interface0, Interface) }.
@@ -417,8 +417,9 @@
mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
qualify_constructors([], [], Info, Info) --> [].
-qualify_constructors([SymName - Args0 | Ctors0], [SymName - Args | Ctors],
- Info0, Info) -->
+qualify_constructors([Ctor0 | Ctors0], [Ctor | Ctors], Info0, Info) -->
+ { Ctor0 = ctor(ExistQVars, SymName, Args0) },
+ { Ctor = ctor(ExistQVars, SymName, Args) },
qualify_constructor_arg_list(Args0, Args, Info0, Info1),
qualify_constructors(Ctors0, Ctors, Info1, Info).
@@ -702,14 +703,23 @@
qualify_mode(Mode0, Mode, Info0, Info1),
qualify_pragma_vars(PragmaVars0, PragmaVars, Info1, Info).
-:- pred qualify_class_constraints(list(class_constraint)::in,
+:- pred qualify_class_constraints(class_constraints::in,
+ class_constraints::out, mq_info::in, mq_info::out, io__state::di,
+ io__state::uo) is det.
+
+qualify_class_constraints(constraints(UnivCs0, ExistCs0),
+ constraints(UnivCs, ExistCs), MQInfo0, MQInfo) -->
+ qualify_class_constraint_list(UnivCs0, UnivCs, MQInfo0, MQInfo1),
+ qualify_class_constraint_list(ExistCs0, ExistCs, MQInfo1, MQInfo).
+
+:- pred qualify_class_constraint_list(list(class_constraint)::in,
list(class_constraint)::out, mq_info::in, mq_info::out, io__state::di,
io__state::uo) is det.
-qualify_class_constraints([], [], MQInfo, MQInfo) --> [].
-qualify_class_constraints([C0|C0s], [C|Cs], MQInfo0, MQInfo) -->
+qualify_class_constraint_list([], [], MQInfo, MQInfo) --> [].
+qualify_class_constraint_list([C0|C0s], [C|Cs], MQInfo0, MQInfo) -->
qualify_class_constraint(C0, C, MQInfo0, MQInfo1),
- qualify_class_constraints(C0s, Cs, MQInfo1, MQInfo).
+ qualify_class_constraint_list(C0s, Cs, MQInfo1, MQInfo).
:- pred qualify_class_constraint(class_constraint::in, class_constraint::out,
mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.134.2.1
diff -u -r1.134.2.1 polymorphism.m
--- polymorphism.m 1998/06/06 11:39:48 1.134.2.1
+++ polymorphism.m 1998/06/16 15:26:16
@@ -366,8 +366,8 @@
write_proc_progress_message("% Transforming polymorphism for ",
PredId, ProcId, ModuleInfo0, IO0, IO1),
- polymorphism__process_proc(ProcInfo0, PredInfo0, ModuleInfo0,
- ProcInfo, PredInfo1, ModuleInfo1),
+ polymorphism__process_proc(ProcId, ProcInfo0, PredId, PredInfo0,
+ ModuleInfo0, ProcInfo, PredInfo1, ModuleInfo1),
pred_info_procedures(PredInfo1, ProcTable1),
map__det_update(ProcTable1, ProcId, ProcInfo, ProcTable),
@@ -445,60 +445,105 @@
%---------------------------------------------------------------------------%
-:- type poly_info --->
- poly_info(
- varset, % from the proc_info
- map(var, type), % from the proc_info
- tvarset, % from the proc_info
- map(tvar, type_info_locn),
- % specifies the location of
- % the type_info var
- % for each of the pred's type
- % parameters
- map(class_constraint, var),
- % specifies the location of
- % the typeclass_info var
- % for each of the pred's class
- % constraints
- map(class_constraint, constraint_proof),
- % specifies why each constraint
- % that was eliminated from the
- % pred was able to be eliminated
- % (this allows us to efficiently
- % construct the dictionary)
+:- pred polymorphism__process_proc(proc_id, proc_info, pred_id, pred_info,
+ module_info, proc_info, pred_info, module_info).
+:- mode polymorphism__process_proc(in, in, in, in, in, out, out, out) is det.
- % Note that the two maps above
- % are separate since the second
- % is the information calculated
- % by typecheck.m, while the
- % first is the information
- % calculated here in
- % polymorphism.m
+polymorphism__process_proc(ProcId, ProcInfo0, PredId, PredInfo0, ModuleInfo0,
+ ProcInfo, PredInfo, ModuleInfo) :-
+ proc_info_goal(ProcInfo0, Goal0),
+ init_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, Info0),
+ polymorphism__setup_headvars(PredInfo0, ProcInfo0,
+ HeadVars, ArgModes, HeadTypeVars, UnconstrainedTVars,
+ ExtraTypeInfoHeadVars, Info0, Info1),
- string, % pred name
- module_info
- ).
+ (
+ ( pred_info_is_imported(PredInfo0)
+ ; pred_info_is_pseudo_imported(PredInfo0),
+ in_in_unification_proc_id(ProcId)
+ )
+ ->
+ Goal = Goal0,
+ Info = Info1
+ ;
+ %
+ % process any polymorphic calls inside the goal
+ %
+ polymorphism__process_goal(Goal0, Goal1, Info1, Info2),
-:- pred polymorphism__process_proc(proc_info, pred_info, module_info,
- proc_info, pred_info, module_info).
-:- mode polymorphism__process_proc(in, in, in, out, out, out) is det.
+ %
+ % generate code to construct the type-class-infos
+ % and type-infos for existentially quantified type vars
+ %
+ polymorphism__produce_existq_tvars(
+ PredId, PredInfo0, ProcId, ProcInfo0,
+ UnconstrainedTVars, ExtraTypeInfoHeadVars,
+ Goal1, Goal2, Info2, Info3),
+
+ pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
+ polymorphism__fixup_quantification(Goal2, ExistQVars, Goal3, _,
+ Info3, Info4),
-polymorphism__process_proc(ProcInfo0, PredInfo0, ModuleInfo0,
- ProcInfo, PredInfo, ModuleInfo) :-
+ %
+ % if there were any existentially quantified type variables,
+ % either in this predicate or in any predicate that it calls,
+ % then we may need to recompute the instmap deltas too
+ %
+ (
+ ExistQVars = [],
+ pred_info_get_head_type_params(PredInfo0,
+ HeadTypeParams),
+ HeadTypeVars = HeadTypeParams
+ ->
+ Goal = Goal3,
+ Info = Info4
+ ;
+ poly_info_get_module_info(Info4, ModuleInfo4),
+ mode_list_get_initial_insts(ArgModes, ModuleInfo4,
+ InitialInsts),
+ assoc_list__from_corresponding_lists(HeadVars,
+ InitialInsts, InstAL),
+ instmap__from_assoc_list(InstAL, InstMap),
+ recompute_instmap_delta(no, Goal3, Goal, InstMap,
+ ModuleInfo4, ModuleInfo5),
+ poly_info_set_module_info(ModuleInfo5, Info4, Info)
+ )
+ ),
+
+ %
+ % set the new values of the fields in proc_info and pred_info
+ %
+ Info = poly_info(VarSet, VarTypes, TypeVarSet,
+ TypeInfoMap, TypeClassInfoMap,
+ _Proofs, _PredName, ModuleInfo),
+ proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
+ proc_info_set_goal(ProcInfo1, Goal, ProcInfo2),
+ proc_info_set_varset(ProcInfo2, VarSet, ProcInfo3),
+ proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo4),
+ proc_info_set_argmodes(ProcInfo4, ArgModes, ProcInfo5),
+ proc_info_set_typeinfo_varmap(ProcInfo5, TypeInfoMap, ProcInfo6),
+ proc_info_set_typeclass_info_varmap(ProcInfo6, TypeClassInfoMap,
+ ProcInfo),
+ pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
+
+:- pred polymorphism__setup_headvars(pred_info, proc_info,
+ list(var), list(mode), list(tvar), list(tvar), list(var),
+ poly_info, poly_info).
+:- mode polymorphism__setup_headvars(in, in, out, out, out, out, out, in, out)
+ is det.
+
+polymorphism__setup_headvars(PredInfo, ProcInfo, HeadVars, ArgModes,
+ HeadTypeVars, UnconstrainedTVars, ExtraHeadTypeInfoVars,
+ PolyInfo0, PolyInfo) :-
%
% grab the appropriate fields from the pred_info and proc_info
%
- pred_info_arg_types(PredInfo0, ArgTypeVarSet, ExistQVars, ArgTypes),
- pred_info_typevarset(PredInfo0, TypeVarSet0),
- pred_info_get_class_context(PredInfo0, ClassContext),
- pred_info_get_constraint_proofs(PredInfo0, Proofs),
- pred_info_name(PredInfo0, PredName),
- proc_info_headvars(ProcInfo0, HeadVars0),
- proc_info_varset(ProcInfo0, VarSet0),
- proc_info_vartypes(ProcInfo0, VarTypes0),
- proc_info_goal(ProcInfo0, Goal0),
- proc_info_argmodes(ProcInfo0, ArgModes0),
+ pred_info_arg_types(PredInfo, ArgTypeVarSet, ExistQVars, ArgTypes),
+ pred_info_get_class_context(PredInfo, ClassContext),
+ proc_info_headvars(ProcInfo, HeadVars0),
+ proc_info_argmodes(ProcInfo, ArgModes0),
+
%
% Insert extra head variables to hold the address of the
@@ -507,25 +552,29 @@
% (for the type_info) and one variable for each constraint (for
% the typeclass_info).
%
- term__vars_list(ArgTypes, HeadTypeVars0),
+
% Make a fresh variable for each class constraint, returning
% a list of variables that appear in the constraints, along
% with the location of the type infos for them.
- polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo0,
- VarSet0, VarTypes0, ExtraHeadTypeclassInfoVars,
- TypeClassInfoMap, ConstrainedTVars,
- VarSet1, VarTypes1),
+ ClassContext = constraints(UnivConstraints, ExistConstraints),
+ list__append(UnivConstraints, ExistConstraints, AllConstraints),
- list__delete_elems(HeadTypeVars0, ConstrainedTVars,
+ polymorphism__make_typeclass_info_head_vars(AllConstraints,
+ ExtraHeadTypeClassInfoVars, PolyInfo0, PolyInfo1),
+ poly_info_get_type_info_map(PolyInfo1, TypeInfoMap1),
+
+ term__vars_list(ArgTypes, HeadTypeVars),
+ map__keys(TypeInfoMap1, ConstrainedTVars),
+ list__delete_elems(HeadTypeVars, ConstrainedTVars,
UnconstrainedTVars0),
list__remove_dups(UnconstrainedTVars0, UnconstrainedTVars),
polymorphism__make_head_vars(UnconstrainedTVars, ArgTypeVarSet,
- VarSet1, VarTypes1, ExtraHeadTypeInfoVars, VarSet2, VarTypes2),
+ ExtraHeadTypeInfoVars, PolyInfo1, PolyInfo2),
% First the type_infos, then the typeclass_infos,
% but we have to do it in reverse because we're appending...
- list__append(ExtraHeadTypeclassInfoVars, HeadVars0, HeadVars1),
+ list__append(ExtraHeadTypeClassInfoVars, HeadVars0, HeadVars1),
list__append(ExtraHeadTypeInfoVars, HeadVars1, HeadVars),
%
@@ -536,7 +585,7 @@
list__map(polymorphism__typeinfo_mode(ExistQVars),
UnconstrainedTVars, TypeInfoModes),
in_mode(In),
- list__length(ExtraHeadTypeclassInfoVars, NumExtraClassInfoVars),
+ list__length(ExtraHeadTypeClassInfoVars, NumExtraClassInfoVars),
list__duplicate(NumExtraClassInfoVars, In, TypeClassInfoModes),
list__append(TypeClassInfoModes, ArgModes0, ArgModes1),
list__append(TypeInfoModes, ArgModes1, ArgModes),
@@ -549,42 +598,147 @@
AddLocn = lambda([TVarAndVar::in, TIM0::in, TIM::out] is det,
(
TVarAndVar = TVar - TheVar,
- map__det_insert(TIM0, TVar, type_info(TheVar),
- TIM)
+ map__det_insert(TIM0, TVar, type_info(TheVar), TIM)
)),
assoc_list__from_corresponding_lists(UnconstrainedTVars,
- ExtraHeadTypeInfoVars, TVarsAndVars),
- list__foldl(AddLocn, TVarsAndVars, TypeClassInfoMap, TypeInfoMap1),
+ ExtraHeadTypeInfoVars, TVarsAndVars),
+ list__foldl(AddLocn, TVarsAndVars, TypeInfoMap1, TypeInfoMap2),
+
+ poly_info_set_type_info_map(TypeInfoMap2, PolyInfo2, PolyInfo3),
% Make a map of the locations of the typeclass_infos
- map__from_corresponding_lists(ClassContext, ExtraHeadTypeclassInfoVars,
- TypeclassInfoLocations0),
+ map__from_corresponding_lists(AllConstraints,
+ ExtraHeadTypeClassInfoVars, TypeClassInfoMap),
+
+ poly_info_set_typeclass_info_map(TypeClassInfoMap,
+ PolyInfo3, PolyInfo).
- Info0 = poly_info(VarSet2, VarTypes2, TypeVarSet0,
- TypeInfoMap1, TypeclassInfoLocations0,
- Proofs, PredName, ModuleInfo0),
+%
+% generate code to produce the values of type_infos and typeclass_infos
+% for existentially quantified type variables in the head
+%
+:- pred polymorphism__produce_existq_tvars(
+ pred_id, pred_info, proc_id, proc_info,
+ list(tvar), list(var), hlds_goal, hlds_goal,
+ poly_info, poly_info).
+:- mode polymorphism__produce_existq_tvars(in, in, in, in, in, in, in, out,
+ in, out) is det.
+
+polymorphism__produce_existq_tvars(PredId, PredInfo, ProcId, ProcInfo,
+ UnconstrainedTVars, TypeInfoHeadVars,
+ Goal0, Goal, Info0, Info) :-
+ poly_info_get_var_types(Info0, VarTypes0),
+ pred_info_arg_types(PredInfo, _ArgTypeVarSet, ExistQVars, ArgTypes),
+ pred_info_get_class_context(PredInfo, ClassContext),
+ proc_info_headvars(ProcInfo, HeadVars0),
+
+ %
+ % Figure out the bindings for any existentially quantified
+ % type variables in the head.
+ %
+ ClassContext = constraints(_UnivConstraints, ExistConstraints),
+ ( map__is_empty(VarTypes0) ->
+ % this can happen for compiler-generated procedures
+ map__init(TypeSubst)
+ ;
+ map__apply_to_list(HeadVars0, VarTypes0, ActualArgTypes),
+ type_list_subsumes(ArgTypes, ActualArgTypes, ArgTypeSubst)
+ ->
+ TypeSubst = ArgTypeSubst
+ ;
+ % this can happen for unification procedures
+ % of equivalence types
+ % error("polymorphism.m: type_list_subsumes failed")
+ map__init(TypeSubst)
+ ),
+
+ poly_info_get_type_class_info_map(Info0, TypeClassInfoMap0),
+ map__apply_to_list(ExistConstraints, TypeClassInfoMap0,
+ ExistTypeClassInfoHeadVars),
+ map__delete_list(TypeClassInfoMap0, ExistConstraints,
+ TypeClassInfoMap1),
+ poly_info_set_typeclass_info_map(TypeClassInfoMap1, Info0, Info1),
+
+ %
+ % generate code to produce values for any existentially quantified
+ % typeclass-info variables in the head
+ %
+ map__init(Subst),
+ ExistQVarsForCall = [],
+ Goal0 = _ - GoalInfo,
+ goal_info_get_context(GoalInfo, Context),
+ polymorphism__make_typeclass_info_vars(
+ ExistConstraints, Subst, TypeSubst, ExistQVarsForCall, Context,
+ hlds_class_proc(PredId, ProcId),
+ hlds_class_proc(NewPredId, NewProcId),
+ ExistTypeClassVars, ExtraTypeClassGoals,
+ _ExistConstrainedTVars, Info1, Info2),
+ % sanity check
+ ( PredId = NewPredId, ProcId = NewProcId ->
+ true
+ ;
+ error("polymorphism.m: impossible specialization")
+ ),
+ polymorphism__assign_var_list(
+ ExistTypeClassInfoHeadVars, ExistTypeClassVars,
+ ExtraTypeClassUnifyGoals),
+
%
- % process any polymorphic calls inside the goal
+ % figure out the list of universally quantified type variables
%
- polymorphism__process_goal(Goal0, Goal1, Info0, Info1),
- polymorphism__fixup_quantification(Goal1, Goal, _, Info1, Info),
- Info = poly_info(VarSet, VarTypes, TypeVarSet,
- TypeInfoMap, TypeclassInfoLocations,
- _Proofs, _PredName, ModuleInfo),
+ term__vars_list(ArgTypes, HeadTypeVars0),
+ list__remove_dups(HeadTypeVars0, HeadTypeVars),
+ list__delete_elems(HeadTypeVars, ExistQVars, UnivQTVars),
%
- % set the new values of the fields in proc_info and pred_info
- %
- proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
- proc_info_set_goal(ProcInfo1, Goal, ProcInfo2),
- proc_info_set_varset(ProcInfo2, VarSet, ProcInfo3),
- proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo4),
- proc_info_set_argmodes(ProcInfo4, ArgModes, ProcInfo5),
- proc_info_set_typeinfo_varmap(ProcInfo5, TypeInfoMap, ProcInfo6),
- proc_info_set_typeclass_info_varmap(ProcInfo6, TypeclassInfoLocations,
- ProcInfo),
- pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
+ % apply the type bindings to the unconstrained type variables
+ % to give the actual types, and then generate code
+ % to initialize the type_infos for those types
+ %
+ term__var_list_to_term_list(UnconstrainedTVars,
+ UnconstrainedTVarTerms),
+ term__apply_substitution_to_list(UnconstrainedTVarTerms,
+ TypeSubst, ActualTypes),
+ polymorphism__make_type_info_vars(ActualTypes, UnivQTVars, Context,
+ TypeInfoVars, ExtraTypeInfoGoals, Info2, Info),
+ polymorphism__assign_var_list(TypeInfoHeadVars, TypeInfoVars,
+ ExtraTypeInfoUnifyGoals),
+ list__condense([[Goal0],
+ ExtraTypeClassGoals, ExtraTypeClassUnifyGoals,
+ ExtraTypeInfoGoals, ExtraTypeInfoUnifyGoals],
+ GoalList),
+ conj_list_to_goal(GoalList, GoalInfo, Goal).
+
+:- pred polymorphism__assign_var_list(list(var), list(var), list(hlds_goal)).
+:- mode polymorphism__assign_var_list(in, in, out) is det.
+
+polymorphism__assign_var_list([], [_|_], _) :-
+ error("unify_proc__assign_var_list: length mismatch").
+polymorphism__assign_var_list([_|_], [], _) :-
+ error("unify_proc__assign_var_list: length mismatch").
+polymorphism__assign_var_list([], [], []).
+polymorphism__assign_var_list([Var1 | Vars1], [Var2 | Vars2], [Goal | Goals]) :-
+
+ % Doing just this wouldn't work, because we also need to fill in
+ % the mode and determinism info:
+ % term__context_init(Context),
+ % create_atomic_unification(Var1, var(Var2), Context, explicit,
+ % [], Goal),
+
+ Ground = ground(shared, no),
+ Mode = ((free -> Ground) - (Ground -> Ground)),
+ UnifyInfo = assign(Var1, Var2),
+ UnifyC = unify_context(explicit, []),
+ goal_info_init(GoalInfo0),
+ instmap_delta_from_assoc_list([Var1 - Ground], InstMapDelta),
+ goal_info_set_instmap_delta(GoalInfo0, InstMapDelta, GoalInfo1),
+ goal_info_set_determinism(GoalInfo1, det, GoalInfo2),
+ set__list_to_set([Var1, Var2], NonLocals),
+ goal_info_set_nonlocals(GoalInfo2, NonLocals, GoalInfo),
+ Goal = unify(Var1, var(Var2), Mode, UnifyInfo, UnifyC) - GoalInfo,
+
+ polymorphism__assign_var_list(Vars1, Vars2, Goals).
:- pred polymorphism__process_goal(hlds_goal, hlds_goal,
poly_info, poly_info).
@@ -621,7 +775,8 @@
{ list__length(ArgVars0, Arity) },
{ special_pred_name_arity(SpecialPredId, PredName0,
MangledPredName, Arity) },
- =(poly_info(_, VarTypes, _, _, _, _, _, ModuleInfo)),
+ =(Info0),
+ { poly_info_get_var_types(Info0, VarTypes) },
{ special_pred_get_type(MangledPredName, ArgVars0, MainVar) },
{ map__lookup(VarTypes, MainVar, Type) },
{ Type \= term__variable(_) },
@@ -632,6 +787,7 @@
{ special_pred_list(SpecialPredIds) },
{ list__member(SpecialPredId, SpecialPredIds) }
->
+ { poly_info_get_module_info(Info0, ModuleInfo) },
{ classify_type(Type, ModuleInfo, TypeCategory) },
{ polymorphism__get_special_proc(TypeCategory, Type,
SpecialPredId, ModuleInfo, Name, PredId1, ProcId1) }
@@ -655,7 +811,10 @@
{ Unification = complicated_unify(UniMode, CanFail) },
{ Y = var(YVar) }
->
- =(poly_info(_, VarTypes, _, TypeInfoMap, _, _, _, ModuleInfo)),
+ =(Info0),
+ { poly_info_get_var_types(Info0, VarTypes) },
+ { poly_info_get_type_info_map(Info0, TypeInfoMap) },
+ { poly_info_get_module_info(Info0, ModuleInfo) },
{ map__lookup(VarTypes, XVar, Type) },
( { Type = term__variable(TypeVar) } ->
% Convert polymorphic unifications into calls to
@@ -766,7 +925,10 @@
% lambda goal and then convert the lambda expression
% into a new predicate
polymorphism__process_goal(LambdaGoal0, LambdaGoal1),
- polymorphism__fixup_quantification(LambdaGoal1,
+ % XXX currently we don't allow lambda goals to be
+ % existentially typed
+ { ExistQVars = [] },
+ polymorphism__fixup_quantification(LambdaGoal1, ExistQVars,
LambdaGoal, NonLocalTypeInfos),
polymorphism__process_lambda(PredOrFunc, Vars, Modes,
Det, ArgVars, NonLocalTypeInfos, LambdaGoal,
@@ -811,7 +973,8 @@
% so that the c_code can refer to the type_info variable
% for type T as `TypeInfo_for_T'.
%
- =(poly_info(_, _, _, _, _, _, _, ModuleInfo)),
+ =(Info0),
+ { poly_info_get_module_info(Info0, ModuleInfo) },
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
{ pred_info_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
PredArgTypes) },
@@ -913,7 +1076,9 @@
PredId, ProcId, ArgVars, ExtraVars, GoalInfo, ExtraGoals,
Info0, Info) :-
- Info0 = poly_info(A, VarTypes, TypeVarSet0, D, E, F, G, ModuleInfo),
+ poly_info_get_var_types(Info0, VarTypes),
+ poly_info_get_typevarset(Info0, TypeVarSet0),
+ poly_info_get_module_info(Info0, ModuleInfo),
module_info_pred_info(ModuleInfo, PredId0, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredExistQVars0,
@@ -973,23 +1138,34 @@
apply_subst_to_constraints(Subst, PredClassContext0,
PredClassContext),
- Info1 = poly_info(A, VarTypes, TypeVarSet, D, E, F, G,
- ModuleInfo),
+ poly_info_set_typevarset(TypeVarSet, Info0, Info1),
% Make the typeclass_infos for the call, and return
% a list of which variables were constrained by the
% context
goal_info_get_context(GoalInfo0, Context),
+ PredClassContext = constraints(UniversalConstraints,
+ ExistentialConstraints),
polymorphism__make_typeclass_info_vars(
- PredClassContext, Subst, TypeSubst,
+ UniversalConstraints, Subst, TypeSubst,
PredExistQVars, Context,
hlds_class_proc(PredId0, ProcId0),
hlds_class_proc(PredId, ProcId),
- ExtraTypeClassVars, ExtraTypeClassGoals,
- ConstrainedVars, Info1, Info2),
+ UnivTypeClassVars, ExtraTypeClassGoals,
+ UnivConstrainedTVars, Info1, Info2),
+ polymorphism__make_typeclass_info_head_vars(
+ ExistentialConstraints, ExistTypeClassVars,
+ Info2, Info3),
+ constraint_list_get_tvars(ExistentialConstraints,
+ ExistConstrainedTVars),
+
+ list__append(UnivTypeClassVars, ExistTypeClassVars,
+ ExtraTypeClassVars),
% No need to make typeinfos for the constrained vars
- list__delete_elems(PredTypeVars1, ConstrainedVars,
+ list__delete_elems(PredTypeVars1, UnivConstrainedTVars,
+ PredTypeVars2),
+ list__delete_elems(PredTypeVars2, ExistConstrainedTVars,
PredTypeVars),
term__var_list_to_term_list(PredTypeVars, PredTypes0),
@@ -1002,7 +1178,7 @@
polymorphism__make_type_info_vars(PredTypes, PredExistQVars,
Context, ExtraTypeInfoVars, ExtraTypeInfoGoals,
- Info2, Info),
+ Info3, Info),
list__append(ExtraTypeClassVars, ArgVars0, ArgVars1),
list__append(ExtraTypeInfoVars, ArgVars1, ArgVars),
list__append(ExtraTypeClassGoals, ExtraTypeInfoGoals,
@@ -1022,8 +1198,7 @@
% any existentially quantified type vars in the callee's
% type: such typeinfo variables are produced by this call
%
- Info = poly_info(_, _, _, TypeVarMap, _, _, _, _),
-
+ poly_info_get_type_info_map(Info, TypeVarMap),
goal_info_get_instmap_delta(GoalInfo1, InstmapDelta0),
AddInstDelta = lambda([TVar::in, IMD0::in, IMD::out] is det, (
map__lookup(TypeVarMap, TVar, TypeInfoLocn),
@@ -1036,9 +1211,27 @@
goal_info_set_instmap_delta(GoalInfo1, InstmapDelta, GoalInfo)
).
-:- pred polymorphism__fixup_quantification(hlds_goal, hlds_goal,
- set(var), poly_info, poly_info).
-:- mode polymorphism__fixup_quantification(in, out, out, in, out) is det.
+%-----------------------------------------------------------------------------%
+
+% constraint_list_get_tvars(Constraints, TVars):
+% return the list of type variables contained in a list of constraints
+
+:- pred constraint_list_get_tvars(list(class_constraint), list(tvar)).
+:- mode constraint_list_get_tvars(in, out) is det.
+constraint_list_get_tvars(Constraints, TVars) :-
+ list__map(constraint_get_tvars, Constraints, TVarsList),
+ list__condense(TVarsList, TVars).
+
+:- pred constraint_get_tvars(class_constraint, list(tvar)).
+:- mode constraint_get_tvars(in, out) is det.
+constraint_get_tvars(constraint(_Name, Args), TVars) :-
+ term__vars_list(Args, TVars).
+
+%-----------------------------------------------------------------------------%
+
+:- pred polymorphism__fixup_quantification(hlds_goal, existq_tvars,
+ hlds_goal, set(var), poly_info, poly_info).
+:- mode polymorphism__fixup_quantification(in, in, out, out, in, out) is det.
%
% If the predicate we are processing is a polymorphic predicate,
@@ -1047,23 +1240,24 @@
% so that it includes the type-info variables in the non-locals set.
%
-polymorphism__fixup_quantification(Goal0, Goal, NewOutsideVars, Info0, Info) :-
- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeVarMap,
- TypeClassVarMap, Proofs, PredName, ModuleInfo),
+polymorphism__fixup_quantification(Goal0, ExistQVars, Goal, NewOutsideVars,
+ Info0, Info) :-
+ poly_info_get_type_info_map(Info0, TypeVarMap),
( map__is_empty(TypeVarMap) ->
set__init(NewOutsideVars),
Info = Info0,
Goal = Goal0
;
- goal_util__extra_nonlocal_typeinfos(TypeVarMap,
- VarTypes0, Goal0, NewOutsideVars),
+ poly_info_get_varset(Info0, VarSet0),
+ poly_info_get_var_types(Info0, VarTypes0),
+ goal_util__extra_nonlocal_typeinfos(TypeVarMap, VarTypes0,
+ ExistQVars, Goal0, NewOutsideVars),
Goal0 = _ - GoalInfo0,
goal_info_get_nonlocals(GoalInfo0, NonLocals),
set__union(NewOutsideVars, NonLocals, OutsideVars),
implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
OutsideVars, Goal, VarSet, VarTypes, _Warnings),
- Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarMap,
- TypeClassVarMap, Proofs, PredName, ModuleInfo)
+ poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info)
).
:- pred polymorphism__process_lambda(pred_or_func, list(var),
@@ -1077,23 +1271,24 @@
NonLocalTypeInfos, LambdaGoal, Unification0, Functor,
Unification, PolyInfo0, PolyInfo) :-
PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
- TCVarMap, Proofs, PredName, ModuleInfo0),
+ TCVarMap, _Proofs, PredName, ModuleInfo0),
% Calculate the constraints which apply to this lambda
- % expression.
+ % expression.
+ % XXX Note currently we only allow lambda expressions
+ % to have universally quantified constraints.
map__keys(TCVarMap, AllConstraints),
map__apply_to_list(Vars, VarTypes, LambdaVarTypes),
list__map(type_util__vars, LambdaVarTypes, LambdaTypeVarsList),
list__condense(LambdaTypeVarsList, LambdaTypeVars),
list__filter(polymorphism__constraint_contains_vars(LambdaTypeVars),
- AllConstraints, Constraints),
-
+ AllConstraints, UnivConstraints),
+ Constraints = constraints(UnivConstraints, []),
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals, NonLocalTypeInfos, LambdaGoal, Unification0,
VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap,
ModuleInfo0, Functor, Unification, ModuleInfo),
- PolyInfo = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
- TCVarMap, Proofs, PredName, ModuleInfo).
+ poly_info_set_module_info(ModuleInfo, PolyInfo0, PolyInfo).
:- pred polymorphism__constraint_contains_vars(list(var), class_constraint).
:- mode polymorphism__constraint_contains_vars(in, in) is semidet.
@@ -1114,10 +1309,15 @@
% variables to hold the typeclass_info for those constraints,
% and create a list of goals to initialize those typeclass_info variables
% to the appropriate typeclass_info structures for the constraints.
+%
+% Constraints which are already in the TypeClassInfoMap are assumed to
+% have already had their typeclass_infos initialized; for them, we
+% just return the variable in the TypeClassInfoMap.
+%
% If the called predicate is a class method, and we know which instance
% it is, then instead of creating a type_info variable for the type class
-% instance, just return the pred_proc_id for that instance.
-% Otherwise return the original pred_proc_id unchanged.
+% instance, we just return the pred_proc_id for that instance.
+% Otherwise we return the original pred_proc_id unchanged.
:- pred polymorphism__make_typeclass_info_vars(list(class_constraint),
substitution, tsubst, existq_tvars, term__context,
@@ -1432,7 +1632,7 @@
;
error("polymorphism__make_typeclass_info_var")
),
- apply_rec_subst_to_constraints(SubTypeSubst,
+ apply_rec_subst_to_constraint_list(SubTypeSubst,
SuperClasses0, SuperClasses),
(
list__nth_member_search(SuperClasses,
@@ -1441,21 +1641,17 @@
SuperClassIndex0 = SuperClassIndex
;
% We shouldn't have got this far if
- % the constraints were not satifsied
+ % the constraints were not satisfied
error("polymorphism.m: constraint not in constraint list")
),
- Info2 = poly_info(VarSet2, VarTypes2, TypeVarSet2,
- TypeInfoMap2, TypeClassInfoMap2, Proofs2,
- PredName2, ModuleInfo2),
-
+ poly_info_get_varset(Info2, VarSet2),
+ poly_info_get_var_types(Info2, VarTypes2),
polymorphism__make_count_var(SuperClassIndex, VarSet2,
VarTypes2, IndexVar, IndexGoal, VarSet,
VarTypes),
-
- Info = poly_info(VarSet, VarTypes, TypeVarSet2,
- TypeInfoMap2, TypeClassInfoMap2, Proofs2,
- PredName2, ModuleInfo2),
+ poly_info_set_varset_and_types(VarSet, VarTypes,
+ Info2, Info),
% We extract the superclass typeclass_info by
% inserting a call to
@@ -1506,7 +1702,7 @@
ClassId, InstanceNum, ExistQVars,
NewVar, NewGoals, Info0, Info) :-
- Info0 = poly_info(_, _, _, _, _, _, _, ModuleInfo),
+ poly_info_get_module_info(Info0, ModuleInfo),
module_info_instances(ModuleInfo, InstanceTable),
map__lookup(InstanceTable, ClassId, InstanceList),
@@ -1521,8 +1717,8 @@
SuperClassProofs, ExistQVars, ArgSuperClassVars,
SuperClassGoals, Info0, Info1),
- Info1 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap, TCVarMap,
- Proofs, PredName, _),
+ poly_info_get_varset(Info1, VarSet0),
+ poly_info_get_var_types(Info1, VarTypes0),
% lay out the argument variables as expected in the
% typeclass_info
@@ -1607,8 +1803,7 @@
TypeClassInfoGoal = Unify - GoalInfo,
NewGoals0 = [TypeClassInfoGoal, BaseGoal],
list__append(SuperClassGoals, NewGoals0, NewGoals),
- Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
- TCVarMap, Proofs, PredName, ModuleInfo).
+ poly_info_set_varset_and_types(VarSet, VarTypes, Info1, Info).
%---------------------------------------------------------------------------%
@@ -1622,25 +1817,20 @@
SuperClassProofs, ExistQVars, NewVars, NewGoals,
Info0, Info) :-
- Info0 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
- Proofs, PredName, ModuleInfo),
+ poly_info_get_proofs(Info0, Proofs),
+ poly_info_get_varset(Info0, VarSet0),
ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet, _),
-
map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
varset__merge_subst(VarSet0, ClassVarSet, VarSet1, Subst),
+ poly_info_set_varset(VarSet1, Info0, Info1),
- Info1 = poly_info(VarSet1, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
- SuperClassProofs, PredName, ModuleInfo),
-
+ poly_info_set_proofs(SuperClassProofs, Info1, Info2),
polymorphism__make_superclasses_from_proofs(SuperClasses, Subst,
- TypeSubst, ExistQVars, [], NewGoals, Info1, Info2,
+ TypeSubst, ExistQVars, [], NewGoals, Info2, Info3,
[], NewVars),
- Info2 = poly_info(VarSet, VarTypes, _, TVarMap, TCVarMap, _, _, _),
-
- Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap, TCVarMap,
- Proofs, PredName, ModuleInfo) .
+ poly_info_set_proofs(Proofs, Info3, Info).
:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint),
@@ -1712,8 +1902,7 @@
Type = term__variable(TVar),
list__member(TVar, ExistQVars)
->
- Info0 = poly_info(VarSet0, VarTypes0, C, TypeInfoMap0,
- E, F, G, H),
+ poly_info_get_type_info_map(Info0, TypeInfoMap0),
% existentially quantified tvars in the head will already
% have a type_info var allocated for them
( map__search(TypeInfoMap0, TVar, type_info(HeadVar)) ->
@@ -1721,11 +1910,10 @@
Info = Info0
;
polymorphism__new_type_info_var(Type, "type_info",
- VarSet0, VarTypes0, Var, VarSet, VarTypes),
+ Var, Info0, Info1),
map__det_insert(TypeInfoMap0, TVar, type_info(Var),
TypeInfoMap),
- Info = poly_info(VarSet, VarTypes, C, TypeInfoMap,
- E, F, G, H)
+ poly_info_set_type_info_map(TypeInfoMap, Info1, Info)
),
ExtraGoals = []
;
@@ -1758,7 +1946,7 @@
no, ExistQVars, Context, Var, ExtraGoals, Info0, Info)
;
Type = term__variable(TypeVar),
- Info0 = poly_info(_, _, _, TypeInfoMap0, _, _, _, _),
+ poly_info_get_type_info_map(Info0, TypeInfoMap0),
map__search(TypeInfoMap0, TypeVar, TypeInfoLocn)
->
% This occurs for code where a predicate calls a polymorphic
@@ -1798,15 +1986,13 @@
% This occurs for code where a predicate calls a polymorphic
% predicate with an unbound type variable.
% Cases where there is no producer at all for the type
- % variable should get caught by purity.m.
+ % variable should get caught by post_typecheck.m.
% XXX Cases where there is a producer but it occurs
% somewhere further on in the goal should be avoided by
% mode reordering, but currently mode analysis doesn't
% do that.
%
- Info0 = poly_info(_VarSet, _VarTypes, TypeVarSet, _TypeVarMap,
- _TypeClassVarMap, _Proofs, PredName,
- _ModuleInfo),
+ poly_info_get_typevarset(Info0, TypeVarSet),
varset__lookup_name(TypeVarSet, TypeVar, TypeVarName),
term__context_file(Context, FileName),
term__context_line(Context, LineNumber),
@@ -1816,6 +2002,7 @@
string__format("%s:%03d: ",
[s(FileName), i(LineNumber)], ContextMessage)
),
+ poly_info_get_pred_name(Info0, PredName),
string__append_list([
"polymorphism__make_var:\n",
ContextMessage, "In predicate `", PredName, "':\n",
@@ -1840,7 +2027,9 @@
polymorphism__make_type_info_vars(TypeArgs, ExistQVars, Context,
ArgTypeInfoVars, ArgTypeInfoGoals, Info0, Info1),
- Info1 = poly_info(VarSet1, VarTypes1, C, D, E, F, G, ModuleInfo),
+ poly_info_get_varset(Info1, VarSet1),
+ poly_info_get_var_types(Info1, VarTypes1),
+ poly_info_get_module_info(Info1, ModuleInfo),
polymorphism__init_const_base_type_info_var(Type,
TypeId, ModuleInfo, VarSet1, VarTypes1,
@@ -1850,7 +2039,7 @@
BaseVar, VarSet2, VarTypes2, [BaseGoal],
Var, VarSet, VarTypes, ExtraGoals),
- Info = poly_info(VarSet, VarTypes, C, D, E, F, G, ModuleInfo).
+ poly_info_set_varset_and_types(VarSet, VarTypes, Info1, Info).
% Create a unification for the two-cell type_info
% variable for this type if the type arity is not zero:
@@ -2200,28 +2389,38 @@
%---------------------------------------------------------------------------%
-:- pred polymorphism__make_head_vars(list(tvar), tvarset,
- varset, map(var, type),
- list(var), varset, map(var, type)).
-:- mode polymorphism__make_head_vars(in, in, in, in, out, out, out) is det.
-
-polymorphism__make_head_vars([], _, VarSet, VarTypes, [], VarSet, VarTypes).
-polymorphism__make_head_vars([TypeVar|TypeVars], TypeVarSet,
- VarSet0, VarTypes0,
- TypeInfoVars, VarSet, VarTypes) :-
- Type = term__variable(TypeVar),
- polymorphism__new_type_info_var(Type, "type_info", VarSet0, VarTypes0,
- Var, VarSet1, VarTypes1),
- ( varset__search_name(TypeVarSet, TypeVar, TypeVarName) ->
- string__append("TypeInfo_for_", TypeVarName, VarName),
- varset__name_var(VarSet1, Var, VarName, VarSet2)
+:- pred polymorphism__make_head_vars(list(tvar), tvarset, list(var),
+ poly_info, poly_info).
+:- mode polymorphism__make_head_vars(in, in, out, in, out) is det.
+
+polymorphism__make_head_vars([], _, []) --> [].
+polymorphism__make_head_vars([TypeVar|TypeVars], TypeVarSet, TypeInfoVars) -->
+ { Type = term__variable(TypeVar) },
+ polymorphism__new_type_info_var(Type, "type_info", Var),
+ ( { varset__search_name(TypeVarSet, TypeVar, TypeVarName) } ->
+ =(Info0),
+ { poly_info_get_varset(Info0, VarSet0) },
+ { string__append("TypeInfo_for_", TypeVarName, VarName) },
+ { varset__name_var(VarSet0, Var, VarName, VarSet) },
+ poly_info_set_varset(VarSet)
;
- VarSet2 = VarSet1
+ []
),
- TypeInfoVars = [Var | TypeInfoVars1],
- polymorphism__make_head_vars(TypeVars, TypeVarSet,
- VarSet2, VarTypes1,
- TypeInfoVars1, VarSet, VarTypes).
+ { TypeInfoVars = [Var | TypeInfoVars1] },
+ polymorphism__make_head_vars(TypeVars, TypeVarSet, TypeInfoVars1).
+
+
+:- pred polymorphism__new_type_info_var(type, string, var,
+ poly_info, poly_info).
+:- mode polymorphism__new_type_info_var(in, in, out, in, out) is det.
+
+polymorphism__new_type_info_var(Type, Symbol, Var, Info0, Info) :-
+ poly_info_get_varset(Info0, VarSet0),
+ poly_info_get_var_types(Info0, VarTypes0),
+ polymorphism__new_type_info_var(Type, Symbol, VarSet0, VarTypes0,
+ Var, VarSet, VarTypes),
+ poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info).
+
:- pred polymorphism__new_type_info_var(type, string, varset, map(var, type),
var, varset, map(var, type)).
@@ -2248,13 +2447,15 @@
extract_type_info(Type, TypeVar, TypeClassInfoVar, Index, Goals,
TypeInfoVar, PolyInfo0, PolyInfo) :-
- PolyInfo0 = poly_info(VarSet0, VarTypes0, C, TypeInfoLocns0,
- E, F, G, ModuleInfo),
+ poly_info_get_varset(PolyInfo0, VarSet0),
+ poly_info_get_var_types(PolyInfo0, VarTypes0),
+ poly_info_get_type_info_map(PolyInfo0, TypeInfoLocns0),
+ poly_info_get_module_info(PolyInfo0, ModuleInfo),
extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo,
Goals, TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
VarSet, VarTypes, TypeInfoLocns),
- PolyInfo = poly_info(VarSet, VarTypes, C, TypeInfoLocns, E, F, G,
- ModuleInfo).
+ poly_info_set_varset_and_types(VarSet, VarTypes, PolyInfo0, PolyInfo1),
+ poly_info_set_type_info_map(TypeInfoLocns, PolyInfo1, PolyInfo).
:- pred extract_type_info_2(type, tvar, var, int, module_info, list(hlds_goal),
var, varset, map(var, type), map(tvar, type_info_locn),
@@ -2322,56 +2523,36 @@
*/
TypeInfoLocns = TypeInfoLocns0.
-%---------------------------------------------------------------------------%
-
- % Add a head var for each class constraint, and make an entry in the
- % typeinfo locations map for each constrained type var.
-:- pred polymorphism__make_typeclass_info_head_vars(list(class_constraint),
- module_info, varset, map(var, type), list(var),
- map(var, type_info_locn), list(var), varset, map(var, type)).
-:- mode polymorphism__make_typeclass_info_head_vars(in, in, in, in,
- out, out, out, out, out) is det.
-
-polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo, VarSet0,
- VarTypes0, ExtraHeadVars, TypeClassInfoMap, ConstrainedTVars,
- VarSet, VarTypes) :-
-
- % initialise the new accumulators
- ExtraHeadVars0 = [],
- map__init(TypeClassInfoMap0),
+%-----------------------------------------------------------------------------%
- % do the work
- polymorphism__make_typeclass_info_head_vars_2(ClassContext, ModuleInfo,
- VarSet0, VarSet,
- VarTypes0, VarTypes,
- ExtraHeadVars0, ExtraHeadVars1,
- TypeClassInfoMap0, TypeClassInfoMap),
-
- % A type var has a location in a typeclass info iff it is
- % constrained
- map__keys(TypeClassInfoMap, ConstrainedTVars),
+ % Create a head var for each class constraint, and make an entry in
+ % the typeinfo locations map for each constrained type var.
- % The ExtraHeadVars are built up in reverse
- list__reverse(ExtraHeadVars1, ExtraHeadVars).
+:- pred polymorphism__make_typeclass_info_head_vars(list(class_constraint),
+ list(var), poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_head_vars(in, out, in, out)
+ is det.
+
+polymorphism__make_typeclass_info_head_vars(Constraints, ExtraHeadVars) -->
+ { ExtraHeadVars0 = [] },
+ polymorphism__make_typeclass_info_head_vars_2(Constraints,
+ ExtraHeadVars0, ExtraHeadVars1),
+ { list__reverse(ExtraHeadVars1, ExtraHeadVars) }.
:- pred polymorphism__make_typeclass_info_head_vars_2(list(class_constraint),
- module_info, varset, varset,
- map(var, type), map(var, type),
- list(var), list(var),
- map(var, type_info_locn), map(var, type_info_locn)).
-:- mode polymorphism__make_typeclass_info_head_vars_2(in, in, in, out, in, out,
- in, out, in, out) is det.
-
-polymorphism__make_typeclass_info_head_vars_2([], _,
- VarSet, VarSet,
- VarTypes, VarTypes,
- ExtraHeadVars, ExtraHeadVars,
- TypeInfoLocations, TypeInfoLocations).
-polymorphism__make_typeclass_info_head_vars_2([C|Cs], ModuleInfo,
- VarSet0, VarSet,
- VarTypes0, VarTypes,
- ExtraHeadVars0, ExtraHeadVars,
- TypeClassInfoMap0, TypeClassInfoMap) :-
+ list(var), list(var), poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_head_vars_2(in, in, out, in, out)
+ is det.
+
+polymorphism__make_typeclass_info_head_vars_2([],
+ ExtraHeadVars, ExtraHeadVars) --> [].
+polymorphism__make_typeclass_info_head_vars_2([C|Cs],
+ ExtraHeadVars0, ExtraHeadVars, Info0, Info) :-
+
+ poly_info_get_varset(Info0, VarSet0),
+ poly_info_get_var_types(Info0, VarTypes0),
+ poly_info_get_type_info_map(Info0, TypeInfoMap0),
+ poly_info_get_module_info(Info0, ModuleInfo),
C = constraint(ClassName0, ClassTypes),
@@ -2414,7 +2595,7 @@
IsNew = lambda([TypeVar0::in] is semidet,
(
TypeVar0 = TypeVar - _Index,
- \+ map__search(TypeClassInfoMap0, TypeVar, _)
+ \+ map__search(TypeInfoMap0, TypeVar, _)
)),
list__filter(IsNew, ClassTypeVars, NewClassTypeVars),
@@ -2428,15 +2609,14 @@
map__det_insert(LocnMap0, TheTypeVar,
typeclass_info(Var, Location), LocnMap)
)),
- list__foldl(MakeEntry, NewClassTypeVars,
- TypeClassInfoMap0, TypeClassInfoMap1),
+ list__foldl(MakeEntry, NewClassTypeVars, TypeInfoMap0, TypeInfoMap1),
+
+ poly_info_set_varset_and_types(VarSet1, VarTypes1, Info0, Info1),
+ poly_info_set_type_info_map(TypeInfoMap1, Info1, Info2),
% Handle the rest of the constraints
- polymorphism__make_typeclass_info_head_vars_2(Cs, ModuleInfo,
- VarSet1, VarSet,
- VarTypes1, VarTypes,
- ExtraHeadVars1, ExtraHeadVars,
- TypeClassInfoMap1, TypeClassInfoMap).
+ polymorphism__make_typeclass_info_head_vars_2(Cs,
+ ExtraHeadVars1, ExtraHeadVars, Info2, Info).
:- pred is_pair(pair(_, _)::in) is det.
is_pair(_).
@@ -2503,7 +2683,7 @@
% introduced because it is a class method.
pred_info_get_class_context(PredInfo0, ClassContext),
(
- ClassContext = [Head|_]
+ ClassContext = constraints([Head|_], _)
->
InstanceConstraint = Head
;
@@ -2575,16 +2755,158 @@
%---------------------------------------------------------------------------%
-:- pred polymorphism__get_module_info(module_info, poly_info, poly_info).
-:- mode polymorphism__get_module_info(out, in, out) is det.
+:- type poly_info --->
+ poly_info(
+ varset, % from the proc_info
+ map(var, type), % from the proc_info
+ tvarset, % from the proc_info
+ map(tvar, type_info_locn),
+ % specifies the location of
+ % the type_info var
+ % for each of the pred's type
+ % parameters
+
+ map(class_constraint, var),
+ % specifies the location of
+ % the typeclass_info var
+ % for each of the pred's class
+ % constraints
+ map(class_constraint, constraint_proof),
+ % specifies why each constraint
+ % that was eliminated from the
+ % pred was able to be eliminated
+ % (this allows us to efficiently
+ % construct the dictionary)
+
+ % Note that the two maps above
+ % are separate since the second
+ % is the information calculated
+ % by typecheck.m, while the
+ % first is the information
+ % calculated here in
+ % polymorphism.m
+
+ string, % pred name
+ module_info
+ ).
+
+:- pred init_poly_info(module_info, pred_info, proc_info, poly_info).
+:- mode init_poly_info(in, in, in, out) is det.
+
+init_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
+ pred_info_typevarset(PredInfo, TypeVarSet),
+ pred_info_name(PredInfo, PredName),
+ proc_info_varset(ProcInfo, VarSet),
+ proc_info_vartypes(ProcInfo, VarTypes),
+ map__init(TypeInfoMap),
+ map__init(TypeClassInfoMap),
+ map__init(Proofs),
+ PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet,
+ TypeInfoMap, TypeClassInfoMap,
+ Proofs, PredName, ModuleInfo).
+
+:- pred poly_info_get_varset(poly_info, varset).
+:- mode poly_info_get_varset(in, out) is det.
+
+poly_info_get_varset(PolyInfo, VarSet) :-
+ PolyInfo = poly_info(VarSet, _, _, _, _, _, _, _).
+
+:- pred poly_info_get_var_types(poly_info, map(var, type)).
+:- mode poly_info_get_var_types(in, out) is det.
+
+poly_info_get_var_types(PolyInfo, VarTypes) :-
+ PolyInfo = poly_info(_, VarTypes, _, _, _, _, _, _).
+
+:- pred poly_info_get_typevarset(poly_info, tvarset).
+:- mode poly_info_get_typevarset(in, out) is det.
+
+poly_info_get_typevarset(PolyInfo, TypeVarSet) :-
+ PolyInfo = poly_info(_, _, TypeVarSet, _, _, _, _, _).
+
+:- pred poly_info_get_type_info_map(poly_info, map(tvar, type_info_locn)).
+:- mode poly_info_get_type_info_map(in, out) is det.
+
+poly_info_get_type_info_map(PolyInfo, TypeInfoMap) :-
+ PolyInfo = poly_info(_, _, _, TypeInfoMap, _, _, _, _).
-polymorphism__get_module_info(ModuleInfo, PolyInfo, PolyInfo) :-
+:- pred poly_info_get_type_class_info_map(poly_info,
+ map(class_constraint, var)).
+:- mode poly_info_get_type_class_info_map(in, out) is det.
+
+poly_info_get_type_class_info_map(PolyInfo, TypeClassInfoMap) :-
+ PolyInfo = poly_info(_, _, _, _, TypeClassInfoMap, _, _, _).
+
+:- pred poly_info_get_proofs(poly_info,
+ map(class_constraint, constraint_proof)).
+:- mode poly_info_get_proofs(in, out) is det.
+
+poly_info_get_proofs(PolyInfo, Proofs) :-
+ PolyInfo = poly_info(_, _, _, _, _, Proofs, _, _).
+
+:- pred poly_info_get_pred_name(poly_info, string).
+:- mode poly_info_get_pred_name(in, out) is det.
+
+poly_info_get_pred_name(PolyInfo, PredName) :-
+ PolyInfo = poly_info(_, _, _, _, _, _, PredName, _).
+
+:- pred poly_info_get_module_info(poly_info, module_info).
+:- mode poly_info_get_module_info(in, out) is det.
+
+poly_info_get_module_info(PolyInfo, ModuleInfo) :-
PolyInfo = poly_info(_, _, _, _, _, _, _, ModuleInfo).
-:- pred polymorphism__set_module_info(module_info, poly_info, poly_info).
-:- mode polymorphism__set_module_info(in, in, out) is det.
-polymorphism__set_module_info(ModuleInfo, PolyInfo0, PolyInfo) :-
+:- pred poly_info_set_varset(varset, poly_info, poly_info).
+:- mode poly_info_set_varset(in, in, out) is det.
+
+poly_info_set_varset(VarSet, PolyInfo0, PolyInfo) :-
+ PolyInfo0 = poly_info(_, B, C, D, E, F, G, H),
+ PolyInfo = poly_info(VarSet, B, C, D, E, F, G, H).
+
+:- pred poly_info_set_varset_and_types(varset, map(var, type),
+ poly_info, poly_info).
+:- mode poly_info_set_varset_and_types(in, in, in, out) is det.
+
+poly_info_set_varset_and_types(VarSet, VarTypes, PolyInfo0, PolyInfo) :-
+ PolyInfo0 = poly_info(_, _, C, D, E, F, G, H),
+ PolyInfo = poly_info(VarSet, VarTypes, C, D, E, F, G, H).
+
+:- pred poly_info_set_typevarset(tvarset, poly_info, poly_info).
+:- mode poly_info_set_typevarset(in, in, out) is det.
+
+poly_info_set_typevarset(TypeVarSet, PolyInfo0, PolyInfo) :-
+ PolyInfo0 = poly_info(A, B, _, D, E, F, G, H),
+ PolyInfo = poly_info(A, B, TypeVarSet, D, E, F, G, H).
+
+:- pred poly_info_set_type_info_map(map(tvar, type_info_locn),
+ poly_info, poly_info).
+:- mode poly_info_set_type_info_map(in, in, out) is det.
+
+poly_info_set_type_info_map(TypeInfoMap, PolyInfo0, PolyInfo) :-
+ PolyInfo0 = poly_info(A, B, C, _, E, F, G, H),
+ PolyInfo = poly_info(A, B, C, TypeInfoMap, E, F, G, H).
+
+:- pred poly_info_set_typeclass_info_map(map(class_constraint, var),
+ poly_info, poly_info).
+:- mode poly_info_set_typeclass_info_map(in, in, out) is det.
+
+poly_info_set_typeclass_info_map(TypeClassInfoMap, PolyInfo0, PolyInfo) :-
+ PolyInfo0 = poly_info(A, B, C, D, _, F, G, H),
+ PolyInfo = poly_info(A, B, C, D, TypeClassInfoMap, F, G, H).
+
+
+:- pred poly_info_set_proofs(map(class_constraint, constraint_proof),
+ poly_info, poly_info).
+:- mode poly_info_set_proofs(in, in, out) is det.
+
+poly_info_set_proofs(Proofs, PolyInfo0, PolyInfo) :-
+ PolyInfo0 = poly_info(A, B, C, D, E, _, G, H),
+ PolyInfo = poly_info(A, B, C, D, E, Proofs, G, H).
+
+:- pred poly_info_set_module_info(module_info, poly_info, poly_info).
+:- mode poly_info_set_module_info(in, in, out) is det.
+
+poly_info_set_module_info(ModuleInfo, PolyInfo0, PolyInfo) :-
PolyInfo0 = poly_info(A, B, C, D, E, F, G, _),
PolyInfo = poly_info(A, B, C, D, E, F, G, ModuleInfo).
[continued in part 2]
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
More information about the developers
mailing list