diff: "superclass search"

David Glen JEFFERY dgj at cs.mu.OZ.AU
Tue May 5 14:44:17 AEST 1998
Previous message: [m-dev.] main as an exported predicate
Next message: [m-dev.] diff: "superclass search"
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
Hi,

Could you please review this, Fergus?
--
Estimated hours taken: 15

Re-implement the part of context reduction which seeks to eliminate a
typeclass constraint by using the fact that one class is a superclass of 
another. This achieves two things:
	- Fixes a bug, in that the new algorithm (correctly) searches the whole
	  superclass relation to find a path from one constraint to
	  another.
	- It makes the algorithm the same as what we put in the type class
	  paper. :-)

compiler/check_typeclass.m:
	Pass the super class table to the context reduction predicate
compiler/hlds_data.m:
	Declare the types which (explicitly) hold the superclass information
compiler/hlds_module.m:
	Store the superclass information explicitly in the module_info, rather
	than just implicitly in the class_table
compiler/make_hlds.m:
	Explicitly construct the superclass information as classes are added.
	This saves re-computing it for each constraint in typecheck.m
compiler/typecheck.m:
	Use the explicit superclass information for context reduction, rather
	than just the class table.

	When reducing the context using superclasses, recursively search the
	whole superclass relation until a match is found. (This is very
	inefficient at this stage, but fixing it won't be hard. I'll leave
	that for another commit, though).

tests/valid/superclass_search.m:
	A test case for this bug fix.

Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/check_typeclass.m,v
retrieving revision 1.5
diff -u -r1.5 check_typeclass.m
--- check_typeclass.m	1998/04/08 15:23:21	1.5
+++ check_typeclass.m	1998/05/05 01:07:02
@@ -446,14 +446,14 @@
 	map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
 
 	module_info_instances(ModuleInfo, InstanceTable),
-	module_info_classes(ModuleInfo, ClassTable),
+	module_info_superclasses(ModuleInfo, SuperClassTable),
 
 	(
 			% Try to reduce the superclass constraints,
 			% using the declared instance constraints
 			% and the usual context reduction rules.
 		typecheck__reduce_context_by_rule_application(InstanceTable, 
-			ClassTable, InstanceConstraints, TypeSubst,
+			SuperClassTable, InstanceConstraints, TypeSubst,
 			InstanceVarSet1, InstanceVarSet2,
 			Proofs0, Proofs1, SuperClasses, 
 			[])
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_data.m,v
retrieving revision 1.22
diff -u -r1.22 hlds_data.m
--- hlds_data.m	1998/03/03 17:34:27	1.22
+++ hlds_data.m	1998/05/05 01:07:02
@@ -756,3 +756,21 @@
 	;	superclass(class_constraint).
 
 %-----------------------------------------------------------------------------%
+
+:- interface.
+
+:- type subclass_details 
+	--->	subclass_details(
+			list(var),		% variables of the superclass
+			class_id,		% name of the subclass
+			list(var),		% variables of the subclass
+			tvarset			% the names of these vars
+		).
+
+:- import_module multi_map.
+
+	% I'm sure there's a very clever way of 
+	% doing this with graphs or relations...
+:- type superclass_table == multi_map(class_id, subclass_details).
+
+%-----------------------------------------------------------------------------%
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_module.m,v
retrieving revision 1.33
diff -u -r1.33 hlds_module.m
--- hlds_module.m	1998/04/27 04:01:07	1.33
+++ hlds_module.m	1998/05/05 01:07:02
@@ -155,6 +155,13 @@
 :- pred module_info_set_instances(module_info, instance_table, module_info).
 :- mode module_info_set_instances(in, in, out) is det.
 
+:- pred module_info_superclasses(module_info, superclass_table).
+:- mode module_info_superclasses(in, out) is det.
+
+:- pred module_info_set_superclasses(module_info, superclass_table,
+	module_info).
+:- mode module_info_set_superclasses(in, in, out) is det.
+
 	% The cell count is used as a unique label number for
 	% constants in the generated C code.
 :- pred module_info_get_cell_count(module_info, int).
@@ -449,6 +456,7 @@
 			cons_table,
 			class_table,
 			instance_table,
+			superclass_table,
 			int		% cell count, passed into code_info
 					% and used to generate unique label
 					% numbers for constant terms in the
@@ -497,11 +505,12 @@
 	map__init(UnusedArgInfo),
 	map__init(ClassTable),
 	map__init(InstanceTable),
+	map__init(SuperClassTable),
 	ModuleSubInfo = module_sub(Name, Globals, [], [], no, 0, 0, [], 
 		[], [], StratPreds, UnusedArgInfo, 0),
 	ModuleInfo = module(ModuleSubInfo, PredicateTable, Requests,
 		UnifyPredMap, ContinuationInfo, Types, Insts, Modes, Ctors,
-		ClassTable, InstanceTable, 0).
+		ClassTable, SuperClassTable, InstanceTable, 0).
 
 %-----------------------------------------------------------------------------%
 
@@ -638,7 +647,8 @@
 % I			cons_table,
 % J			class_table,
 % K			instance_table,
-% L			int		% cell count, passed into code_info
+% L			superclass_table,
+% M			int		% cell count, passed into code_info
 %					% and used to generate unique label
 %					% numbers for constant terms in the
 %					% generated C code
@@ -649,92 +659,99 @@
 	% Various predicates which access the module_info data structure.
 
 module_info_get_sub_info(MI0, A) :-
-	MI0 = module(A, _, _, _, _, _, _, _, _, _, _, _).
+	MI0 = module(A, _, _, _, _, _, _, _, _, _, _, _, _).
 
 module_info_get_predicate_table(MI0, B) :-
-	MI0 = module(_, B, _, _, _, _, _, _, _, _, _, _).
+	MI0 = module(_, B, _, _, _, _, _, _, _, _, _, _, _).
 
 module_info_get_proc_requests(MI0, C) :-
-	MI0 = module(_, _, C, _, _, _, _, _, _, _, _, _).
+	MI0 = module(_, _, C, _, _, _, _, _, _, _, _, _, _).
 
 module_info_get_special_pred_map(MI0, D) :-
-	MI0 = module(_, _, _, D, _, _, _, _, _, _, _, _).
+	MI0 = module(_, _, _, D, _, _, _, _, _, _, _, _, _).
 
 module_info_get_continuation_info(MI0, E) :-
-	MI0 = module(_, _, _, _, E, _, _, _, _, _, _, _).
+	MI0 = module(_, _, _, _, E, _, _, _, _, _, _, _, _).
 
 module_info_types(MI0, F) :-
-	MI0 = module(_, _, _, _, _, F, _, _, _, _, _, _).
+	MI0 = module(_, _, _, _, _, F, _, _, _, _, _, _, _).
 
 module_info_insts(MI0, G) :-
-	MI0 = module(_, _, _, _, _, _, G, _, _, _, _, _).
+	MI0 = module(_, _, _, _, _, _, G, _, _, _, _, _, _).
 
 module_info_modes(MI0, H) :-
-	MI0 = module(_, _, _, _, _, _, _, H, _, _, _, _).
+	MI0 = module(_, _, _, _, _, _, _, H, _, _, _, _, _).
 
 module_info_ctors(MI0, I) :-
-	MI0 = module(_, _, _, _, _, _, _, _, I, _, _, _).
+	MI0 = module(_, _, _, _, _, _, _, _, I, _, _, _, _).
 
 module_info_classes(MI0, J) :-
-	MI0 = module(_, _, _, _, _, _, _, _, _, J, _, _).
+	MI0 = module(_, _, _, _, _, _, _, _, _, J, _, _, _).
 
 module_info_instances(MI0, K) :-
-	MI0 = module(_, _, _, _, _, _, _, _, _, _, K, _).
+	MI0 = module(_, _, _, _, _, _, _, _, _, _, K, _, _).
+
+module_info_superclasses(MI0, L) :-
+	MI0 = module(_, _, _, _, _, _, _, _, _, _, _, L, _).
 
-module_info_get_cell_count(MI0, L) :-
-	MI0 = module(_, _, _, _, _, _, _, _, _, _, _, L).
+module_info_get_cell_count(MI0, M) :-
+	MI0 = module(_, _, _, _, _, _, _, _, _, _, _, _, M).
 
 %-----------------------------------------------------------------------------%
 
 	% Various predicates which modify the module_info data structure.
 
 module_info_set_sub_info(MI0, A, MI) :-
-	MI0 = module(_, B, C, D, E, F, G, H, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(_, B, C, D, E, F, G, H, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_predicate_table(MI0, B, MI) :-
-	MI0 = module(A, _, C, D, E, F, G, H, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, _, C, D, E, F, G, H, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_proc_requests(MI0, C, MI) :-
-	MI0 = module(A, B, _, D, E, F, G, H, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, _, D, E, F, G, H, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_special_pred_map(MI0, D, MI) :-
-	MI0 = module(A, B, C, _, E, F, G, H, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, _, E, F, G, H, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_continuation_info(MI0, E, MI) :-
-	MI0 = module(A, B, C, D, _, F, G, H, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, D, _, F, G, H, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_types(MI0, F, MI) :-
-	MI0 = module(A, B, C, D, E, _, G, H, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, D, E, _, G, H, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_insts(MI0, G, MI) :-
-	MI0 = module(A, B, C, D, E, F, _, H, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, D, E, F, _, H, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_modes(MI0, H, MI) :-
-	MI0 = module(A, B, C, D, E, F, G, _, I, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, D, E, F, G, _, I, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_ctors(MI0, I, MI) :-
-	MI0 = module(A, B, C, D, E, F, G, H, _, J, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, D, E, F, G, H, _, J, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_classes(MI0, J, MI) :-
-	MI0 = module(A, B, C, D, E, F, G, H, I, _, K, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, D, E, F, G, H, I, _, K, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 module_info_set_instances(MI0, K, MI) :-
-	MI0 = module(A, B, C, D, E, F, G, H, I, J, _, L),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+	MI0 = module(A, B, C, D, E, F, G, H, I, J, _, L, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
-module_info_set_cell_count(MI0, L, MI) :-
-	MI0 = module(A, B, C, D, E, F, G, H, I, J, K, _),
-	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L).
+module_info_set_superclasses(MI0, L, MI) :-
+	MI0 = module(A, B, C, D, E, F, G, H, I, J, K, _, M),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
+
+module_info_set_cell_count(MI0, M, MI) :-
+	MI0 = module(A, B, C, D, E, F, G, H, I, J, K, L, _),
+	MI  = module(A, B, C, D, E, F, G, H, I, J, K, L, M).
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.263
diff -u -r1.263 make_hlds.m
--- make_hlds.m	1998/03/04 19:47:34	1.263
+++ make_hlds.m	1998/05/05 01:07:02
@@ -1289,10 +1289,11 @@
 module_add_class_defn(Module0, Constraints, Name, Vars, Interface, VarSet,
 		Context, Status, Module) -->
 	{ module_info_classes(Module0, Classes0) },
+	{ module_info_superclasses(Module0, SuperClasses0) },
 	{ list__length(Vars, ClassArity) },
-	{ Key = class_id(Name, ClassArity) },
+	{ ClassId = class_id(Name, ClassArity) },
 	(
-		{ map__search(Classes0, Key, OldValue) }
+		{ map__search(Classes0, ClassId, OldValue) }
 	->
 		{ OldValue = hlds_class_defn(_, _, _, _, OldContext) },
 		multiple_def_error(Name, ClassArity, "typeclass", 
@@ -1311,13 +1312,33 @@
 		{ list__filter_map(IsYes, PredProcIds0, PredProcIds) },
 		{ Value = hlds_class_defn(Constraints, Vars, PredProcIds, 
 			VarSet, Context) },
-		{ map__det_insert(Classes0, Key, Value, Classes) },
+		{ map__det_insert(Classes0, ClassId, Value, Classes) },
 		{ module_info_set_classes(Module1, Classes, Module2) },
+
+			% insert an entry into the super class table for each
+			% super class of this class
+		{ AddSuper = lambda([Super::in, Ss0::in, Ss::out] is det,
+			(
+				Super = constraint(SuperName, SuperTypes),
+				list__length(SuperTypes, SuperClassArity),
+				term__vars_list(SuperTypes, SuperVars),
+				SuperClassId = class_id(SuperName,
+					SuperClassArity),
+				SubClassDetails = subclass_details(SuperVars,
+					ClassId, Vars, VarSet),
+				multi_map__set(Ss0, SuperClassId,
+					SubClassDetails, Ss)
+			)) },
+		{ list__foldl(AddSuper, Constraints, 
+			SuperClasses0, SuperClasses) },
+		{ module_info_set_superclasses(Module2, 
+			SuperClasses, Module3) },
+
 			% When we find the class declaration, make an
 			% entry for the instances.
-		{ module_info_instances(Module2, Instances0) },
-		{ map__det_insert(Instances0, Key, [], Instances) },
-		{ module_info_set_instances(Module2, Instances, Module) }
+		{ module_info_instances(Module3, Instances0) },
+		{ map__det_insert(Instances0, ClassId, [], Instances) },
+		{ module_info_set_instances(Module3, Instances, Module) }
 	).
 
 :- pred module_add_class_interface(module_info, sym_name, list(var),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.236
diff -u -r1.236 typecheck.m
--- typecheck.m	1998/04/09 18:31:40	1.236
+++ typecheck.m	1998/05/05 04:27:32
@@ -159,7 +159,7 @@
 	% the instance rules or superclass rules, building up proofs for
 	% redundant constraints
 :- pred typecheck__reduce_context_by_rule_application(instance_table,
-	class_table, list(class_constraint), tsubst, tvarset, tvarset, 
+	superclass_table, list(class_constraint), tsubst, tvarset, tvarset, 
 	map(class_constraint, constraint_proof), 
 	map(class_constraint, constraint_proof),
 	list(class_constraint), list(class_constraint)).
@@ -176,7 +176,7 @@
 :- import_module mercury_to_mercury, mode_util, options, getopt, globals.
 :- import_module passes_aux, clause_to_proc, special_pred, inst_match.
 
-:- import_module int, set, string, require, std_util, tree234.
+:- import_module int, set, string, require, std_util, tree234, multi_map.
 :- import_module assoc_list, varset, term_io.
 
 %-----------------------------------------------------------------------------%
@@ -3043,11 +3043,11 @@
 perform_context_reduction(OrigTypeAssignSet, TypeCheckInfo0, TypeCheckInfo) :-
 	typecheck_info_get_module_info(TypeCheckInfo0, ModuleInfo),
 	typecheck_info_get_constraints(TypeCheckInfo0, DeclaredConstraints),
-	module_info_classes(ModuleInfo, ClassTable),
+	module_info_superclasses(ModuleInfo, SuperClassTable),
 	module_info_instances(ModuleInfo, InstanceTable),
 	typecheck_info_get_type_assign_set(TypeCheckInfo0, TypeAssignSet0),
-	list__filter_map(reduce_type_assign_context(ClassTable, InstanceTable,
-			DeclaredConstraints), 
+	list__filter_map(reduce_type_assign_context(SuperClassTable, 
+			InstanceTable, DeclaredConstraints), 
 		TypeAssignSet0, TypeAssignSet),
 	(
 			% Check that this context reduction hasn't eliminated
@@ -3069,11 +3069,11 @@
 			TypeAssignSet, TypeCheckInfo)
 	).
 
-:- pred reduce_type_assign_context(class_table, instance_table,
+:- pred reduce_type_assign_context(superclass_table, instance_table,
 		list(class_constraint), type_assign, type_assign).
 :- mode reduce_type_assign_context(in, in, in, in, out) is semidet.
 
-reduce_type_assign_context(ClassTable, InstanceTable, DeclaredConstraints,
+reduce_type_assign_context(SuperClassTable, InstanceTable, DeclaredConstraints,
 		TypeAssign0, TypeAssign) :-
 	type_assign_get_typeclass_constraints(TypeAssign0, Constraints0),
 	type_assign_get_type_bindings(TypeAssign0, Bindings),
@@ -3081,7 +3081,7 @@
 	type_assign_get_constraint_proofs(TypeAssign0, Proofs0),
 
 	typecheck__reduce_context_by_rule_application(InstanceTable, 
-		ClassTable, DeclaredConstraints,
+		SuperClassTable, DeclaredConstraints,
 		Bindings, Tvarset0, Tvarset, Proofs0, Proofs,
 		Constraints0, Constraints),
 
@@ -3091,16 +3091,16 @@
 	type_assign_set_constraint_proofs(TypeAssign2, Proofs, TypeAssign).
 
 
-typecheck__reduce_context_by_rule_application(InstanceTable, ClassTable, 
+typecheck__reduce_context_by_rule_application(InstanceTable, SuperClassTable, 
 		DeclaredConstraints, Bindings, Tvarset0, Tvarset,
 		Proofs0, Proofs, Constraints0, Constraints) :-
 	apply_rec_subst_to_constraints(Bindings, Constraints0, Constraints1),
 	eliminate_declared_constraints(Constraints1, DeclaredConstraints,
 		Constraints2, Changed1),
-	apply_class_rules(Constraints2, DeclaredConstraints, ClassTable,
-		Tvarset0, Proofs0, Proofs1, Constraints3, Changed2),
-	apply_instance_rules(Constraints3, InstanceTable, 
-		Tvarset0, Tvarset1, Proofs1, Proofs2, Constraints4, Changed3),
+	apply_instance_rules(Constraints2, InstanceTable, 
+		Tvarset0, Tvarset1, Proofs0, Proofs1, Constraints3, Changed2),
+	apply_class_rules(Constraints3, DeclaredConstraints, SuperClassTable,
+		Tvarset0, Proofs1, Proofs2, Constraints4, Changed3),
 	(
 		Changed1 = no, Changed2 = no, Changed3 = no
 	->
@@ -3110,8 +3110,9 @@
 		Proofs = Proofs2
 	;
 		typecheck__reduce_context_by_rule_application(InstanceTable,
-			ClassTable, DeclaredConstraints, Bindings, Tvarset1,
-			Tvarset, Proofs2, Proofs, Constraints4, Constraints)
+			SuperClassTable, DeclaredConstraints, Bindings,
+			Tvarset1, Tvarset, Proofs2, Proofs, 
+			Constraints4, Constraints)
 	).
 
 :- pred eliminate_declared_constraints(list(class_constraint), 
@@ -3240,82 +3241,100 @@
 			Proofs, NewConstraints)
 	).
 
-	% To reduce the context using class declarations, we scan the
-	% declared contexts plus the current inferred context one
-	% constraint at a time.  For each such class constraint, we
-	% check to see if any of its superclasses is also a constraint,
-	% and if so, delete the superclass from the current constraint
-	% list as it is redundant.
+	% To reduce a constraint using class declarations, we search the
+	% superclass relation to find a path from the inferred constraint to
+	% another (declared or inferred) constraint.
 :- pred apply_class_rules(list(class_constraint), list(class_constraint),
-	class_table, tvarset, map(class_constraint, constraint_proof),
+	superclass_table, tvarset, map(class_constraint, constraint_proof),
 	map(class_constraint, constraint_proof), list(class_constraint), bool).
 :- mode apply_class_rules(in, in, in, in, in, out, out, out) is det.
 
-apply_class_rules(Constraints0, DeclaredConstraints, ClassTable, TVarSet, 
-		Proofs0, Proofs, Constraints, Changed) :-
-	list__append(DeclaredConstraints, Constraints0, AllConstraints),
-	apply_class_rules_2(AllConstraints, Constraints0, ClassTable,
-		TVarSet, Proofs0, Proofs, Constraints, Changed).
-
-:- pred apply_class_rules_2(list(class_constraint), list(class_constraint),
-	class_table, tvarset, map(class_constraint, constraint_proof),
-	map(class_constraint, constraint_proof), list(class_constraint), bool).
-:- mode apply_class_rules_2(in, in, in, in, in, out, out, out) is det.
+apply_class_rules([], _, _, _, Proofs, Proofs, [], no).
+apply_class_rules([C|Constraints0], DeclaredConstraints, SuperClassTable,
+		TVarSet, Proofs0, Proofs, Constraints, Changed) :-
+	(
+		eliminate_constraint_by_class_rules(C, DeclaredConstraints,
+			SuperClassTable, TVarSet, Proofs0, Proofs1)
+	->
+		apply_class_rules(Constraints0, DeclaredConstraints,
+			SuperClassTable, TVarSet, Proofs1, Proofs, 
+			Constraints, _),
+		Changed = yes
+	;
+		apply_class_rules(Constraints0, DeclaredConstraints,
+			SuperClassTable, TVarSet, Proofs0, Proofs, 
+			Constraints1, Changed),
+		Constraints = [C|Constraints1]
+	).
 
-	% The first argument is the list of declared or inferred constraints
-	% left to be checked.
-	% The second argument is the list of currently inferred constraints
-	% that have not been rejected. If a redundant constraint is found,
-	% it is deleted from both (if it is still in the first list).
-apply_class_rules_2([], Constraints, _, _, Proofs, Proofs, Constraints, no).
-apply_class_rules_2([C|Cs], Constraints0, ClassTable, TVarSet,
-		Proofs0, Proofs, Constraints, Changed) :-
-	C = constraint(ClassName, Types),
-	list__length(Types, Arity),
-	ClassId = class_id(ClassName, Arity),
-	map__lookup(ClassTable, ClassId, ClassDefn),
-	ClassDefn = hlds_class_defn(ParentClassConstraints0, ClassVars,
-		_ClassInterface, ClassVarset, _TermContext),
-	term__var_list_to_term_list(ClassVars, ClassTypes),
-	varset__merge_subst(TVarSet, ClassVarset, NewTVarSet, RenameSubst),
-	term__apply_rec_substitution_to_list(ClassTypes, RenameSubst,
-		NewClassTypes),
-	apply_rec_subst_to_constraints(RenameSubst, ParentClassConstraints0,
-		ParentClassConstraints),
-	IsRedundant = lambda(
-			[ThisConstraint::in, RenamedConstraint::out] is semidet,
-		(
-			type_list_subsumes(NewClassTypes, Types, Subst),
-			apply_rec_subst_to_constraint(Subst, ThisConstraint, 
-				RenamedConstraint),
-			list__member(RenamedConstraint, Constraints0)
-		)),
-	list__filter_map(IsRedundant, ParentClassConstraints,
-		RedundantConstraints),
+:- pred eliminate_constraint_by_class_rules(class_constraint,
+	list(class_constraint), superclass_table, tvarset, 
+	map(class_constraint, constraint_proof),
+	map(class_constraint, constraint_proof)).
+:- mode eliminate_constraint_by_class_rules(in, in, in, in, in, out) is semidet.
 
-		% Delete the redundant constraints
-	list__delete_elems(Constraints0, RedundantConstraints, Constraints1),
-	list__delete_elems(Cs, RedundantConstraints, NewCs),
-
-		% Remember why the constraints were redundant
-	RecordRedundancy = lambda([ConstraintName::in, TheProofs0::in,
-					TheProofs::out] is det,
-		(
-			map__set(TheProofs0, ConstraintName, superclass(C), 
-				TheProofs)
+eliminate_constraint_by_class_rules(C, DeclaredConstraints, SuperClassTable,
+		TVarSet, Proofs0, Proofs) :-
+	C = constraint(SuperClassName, SuperClassTypes),
+	list__length(SuperClassTypes, SuperClassArity),
+	SuperClassId = class_id(SuperClassName, SuperClassArity),
+	multi_map__search(SuperClassTable, SuperClassId, SubClasses), 
+
+		% Convert all the subclass_details into class_constraints by
+		% doing the appropriate variable renaming and applying the
+		% type variable bindings.
+	SubDetailsToConstraint = lambda([SubClassDetails::in, SubC::out] 
+			is semidet, (
+		SubClassDetails = subclass_details(SuperVars0, SubID,
+			SubVars0, SuperVarset),
+
+			% Rename the variables from the typeclass
+			% declaration into those of the current pred
+		varset__merge_subst(TVarSet, SuperVarset, _NewTVarSet, 
+			RenameSubst),
+		term__var_list_to_term_list(SubVars0, SubVars1),
+		term__apply_substitution_to_list(SubVars1, 
+			RenameSubst, SubVars),
+		term__var_list_to_term_list(SuperVars0, SuperVars1),
+		term__apply_substitution_to_list(SuperVars1,
+			RenameSubst, SuperVars),
+
+			% Work out what the (renamed) vars from the
+			% typeclass declaration are bound to here
+		map__init(Empty),
+		type_unify_list(SuperVars, SuperClassTypes, [],
+			Empty, Bindings),
+		SubID = class_id(SubName, _SubArity),
+		term__apply_substitution_to_list(SubVars, Bindings,
+			SubClassTypes),
+		SubC = constraint(SubName, SubClassTypes)
+	)),
+	list__map(SubDetailsToConstraint, SubClasses, SubClassConstraints),
+
+	(
+			% Do the first level of search
+		FindSub = lambda([TheConstraint::in] is semidet,(
+			list__member(TheConstraint, DeclaredConstraints)
 		)),
-	list__foldl(RecordRedundancy, RedundantConstraints, Proofs0, Proofs1),
-	(
-		RedundantConstraints = [],
-		Changed1 = no
+		list__filter(FindSub, SubClassConstraints, [Sub|_])
+	->
+		map__set(Proofs0, C, superclass(Sub), Proofs)
 	;
-		RedundantConstraints = [_|_],
-		Changed1 = yes
-	),
-
-	apply_class_rules_2(NewCs, Constraints1, ClassTable,
-		NewTVarSet, Proofs1, Proofs, Constraints, Changed2),
-	bool__or(Changed1, Changed2, Changed).
+			% Recursively search the rest of the superclass
+			% relation.
+		SubClassSearch = lambda([Constraint::in, CnstrtAndProof::out] 
+				is semidet, (
+			eliminate_constraint_by_class_rules(Constraint,
+				DeclaredConstraints, SuperClassTable,
+				TVarSet, Proofs0, SubProofs),
+			CnstrtAndProof = Constraint - SubProofs
+		)),
+			% XXX this could (and should) be more efficient. 
+			% (ie. by manually doing a "cut").
+		list__filter_map(SubClassSearch, SubClassConstraints,
+			[NewSub - NewProofs|_]),
+		map__set(NewProofs, C, superclass(NewSub), Proofs)
+	).
 
 %-----------------------------------------------------------------------------%
 




New file: superclass_search.m:
--------------------------------------------------------
:- module superclass_search.

:- interface.

:- typeclass c1(T) where [
	pred p(T::in) is semidet
].

:- typeclass c2(T) <= c1(T) where [
].

:- typeclass c3(T) <= c2(T) where [
].

:- pred test(T) <= c2(T).
:- mode test(in) is semidet.

:- implementation.

test(X) :- p(X).
--


love and cuddles,
dgj
-- 
David Jeffery (dgj at cs.mu.oz.au) |  Marge: Did you just call everyone "chicken"?
MEngSc student,                 |  Homer: Noooo.  I swear on this Bible!
Department of Computer Science  |  Marge: That's not a Bible; that's a book of
University of Melbourne         |         carpet samples!
Australia                       |  Homer: Ooooh... Fuzzy.
Previous message: [m-dev.] main as an exported predicate
Next message: [m-dev.] diff: "superclass search"
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
More information about the developers mailing list