[m-rev.] diff: more polymorphism cleanup

Zoltan Somogyi zs at cs.mu.OZ.AU
Thu Nov 27 10:13:26 AEDT 2003
Previous message: [m-rev.] diff: mtags: use perl -w
Next message: [m-rev.] diff: remove unnecessary duplicated prototypes
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
compiler/polymorphism.m:
	Split a predicate with a 200-line definition into three.

	Fix some formatting issues.

	There is no change in algorithms.

cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.247
diff -u -b -r1.247 polymorphism.m
--- compiler/polymorphism.m	31 Oct 2003 03:27:27 -0000	1.247
+++ compiler/polymorphism.m	26 Nov 2003 21:01:52 -0000
@@ -1237,14 +1237,14 @@
 	%
 	% with
 	%
-	%       X = lambda [A1::in, A2::out] (list__append(Y, A1, A2))
+	%       X = (pred(A1::in, A2::out) is ... :- list__append(Y, A1, A2))
 	%
 	% We do this because it makes two things easier.
-	% Firstly, mode analysis needs to check that the lambda-goal doesn't
+	% First, mode analysis needs to check that the lambda-goal doesn't
 	% bind any non-local variables (e.g. `Y' in above example).
 	% This would require a bit of moderately tricky special-case code
 	% if we didn't expand them here.
-	% Secondly, this pass (polymorphism.m) is a lot easier
+	% Second, this pass (polymorphism.m) is a lot easier
 	% if we don't have to handle higher-order pred consts.
 	% If it turns out that the predicate was non-polymorphic,
 	% lambda.m will turn the lambda expression back into a
@@ -2114,8 +2114,6 @@
 
 polymorphism__make_typeclass_info_from_proof(Constraint, Seen, Proof,
 		ExistQVars, Context, MaybeVar, !ExtraGoals, !Info) :-
-	!.Info = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
-		TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
 	Constraint = constraint(ClassName, ConstrainedTypes),
 	list__length(ConstrainedTypes, ClassArity),
 	ClassId = class_id(ClassName, ClassArity),
@@ -2123,15 +2121,38 @@
 			% We have to construct the typeclass_info
 			% using an instance declaration
 		Proof = apply_instance(InstanceNum),
+		polymorphism__make_typeclass_info_from_instance(Constraint,
+			Seen, ClassId, InstanceNum, ExistQVars, Context,
+			MaybeVar, !ExtraGoals, !Info)
+	;
+		% XXX MR_Dictionary should have MR_Dictionaries for superclass
+			% We have to extract the typeclass_info from
+			% another one
+		Proof = superclass(SubClassConstraint),
+		polymorphism__make_typeclass_info_from_subclass(Constraint,
+			Seen, ClassId, SubClassConstraint, ExistQVars, Context,
+			MaybeVar, !ExtraGoals, !Info)
+	).
+
+:- pred polymorphism__make_typeclass_info_from_instance(class_constraint::in,
+	list(class_constraint)::in, class_id::in, int::in, existq_tvars::in,
+	prog_context::in, maybe(prog_var)::out,
+	list(hlds_goal)::in, list(hlds_goal)::out,
+	poly_info::in, poly_info::out) is det.
+
+polymorphism__make_typeclass_info_from_instance(Constraint, Seen,
+		ClassId, InstanceNum, ExistQVars, Context, MaybeVar,
+		!ExtraGoals, !Info) :-
+	Constraint = constraint(_ClassName, ConstrainedTypes),
+	!.Info = poly_info(_VarSet0, _VarTypes0, TypeVarSet, _TypeInfoMap0,
+		_TypeClassInfoMap0, Proofs, _PredName, ModuleInfo),
 
 		module_info_instances(ModuleInfo, InstanceTable),
 		map__lookup(InstanceTable, ClassId, InstanceList),
-		list__index1_det(InstanceList, InstanceNum,
-			ProofInstanceDefn),
+	list__index1_det(InstanceList, InstanceNum, ProofInstanceDefn),
 
-		ProofInstanceDefn = hlds_instance_defn(_, _, _,
-			InstanceConstraints0, InstanceTypes0, _, _,
-			InstanceTVarset, SuperClassProofs0),
+	ProofInstanceDefn = hlds_instance_defn(_, _, _, InstanceConstraints0,
+		InstanceTypes0, _, _, InstanceTVarset, SuperClassProofs0),
 
 		term__vars_list(InstanceTypes0, InstanceTvars),
 		get_unconstrained_tvars(InstanceTvars,
@@ -2146,27 +2167,23 @@
 			_NewTVarset, RenameSubst),
 		term__apply_substitution_to_list(InstanceTypes0,
 			RenameSubst, InstanceTypes),
-		type_list_subsumes_det(InstanceTypes, ConstrainedTypes,
-			InstanceSubst),
+	type_list_subsumes_det(InstanceTypes, ConstrainedTypes, InstanceSubst),
 		apply_subst_to_constraint_list(RenameSubst,
 			InstanceConstraints0, InstanceConstraints1),
 		apply_rec_subst_to_constraint_list(InstanceSubst,
 			InstanceConstraints1, InstanceConstraints2),
 		% XXX document diamond as guess
-		InstanceConstraints =
-			InstanceConstraints2 `list__delete_elems` Seen,
+	InstanceConstraints = InstanceConstraints2 `list__delete_elems` Seen,
 		apply_subst_to_constraint_proofs(RenameSubst,
 			SuperClassProofs0, SuperClassProofs1),
 		apply_rec_subst_to_constraint_proofs(InstanceSubst,
 			SuperClassProofs1, SuperClassProofs2),
 
-		term__var_list_to_term_list(UnconstrainedTvars0,
-			UnconstrainedTypes0),
-		term__apply_substitution_to_list(UnconstrainedTypes0,
-			RenameSubst, UnconstrainedTypes1),
-		term__apply_rec_substitution_to_list(
-			UnconstrainedTypes1, InstanceSubst,
-			UnconstrainedTypes),
+	term__var_list_to_term_list(UnconstrainedTvars0, UnconstrainedTypes0),
+	term__apply_substitution_to_list(UnconstrainedTypes0, RenameSubst,
+		UnconstrainedTypes1),
+	term__apply_rec_substitution_to_list(UnconstrainedTypes1,
+		InstanceSubst, UnconstrainedTypes),
 
 			% XXX why name of output?
 		map__overlay(Proofs, SuperClassProofs2, SuperClassProofs),
@@ -2177,9 +2194,8 @@
 		polymorphism__make_type_info_vars(ConstrainedTypes, Context,
 			InstanceExtraTypeInfoVars, TypeInfoGoals, !Info),
 
-			% Make the typeclass_infos for the
-			% constraints from the context of the
-			% instance decl.
+		% Make the typeclass_infos for the constraints from the
+		% context of the instance decl.
 		polymorphism__make_typeclass_info_vars_2(InstanceConstraints,
 			Seen, ExistQVars, Context, [],
 			InstanceExtraTypeClassInfoVars0, !ExtraGoals, !Info),
@@ -2211,37 +2227,35 @@
 			RevUnconstrainedTypeInfoGoals),
 
 		list__condense([RevUnconstrainedTypeInfoGoals, NewGoals,
-			!.ExtraGoals, RevTypeInfoGoals], !:ExtraGoals)
-	;
-		% XXX MR_Dictionary should have MR_Dictionaries for superclass
-			% We have to extract the typeclass_info from
-			% another one
-		Proof = superclass(SubClassConstraint),
+		!.ExtraGoals, RevTypeInfoGoals], !:ExtraGoals).
 
-			% First create a variable to hold the new
-			% typeclass_info
-		unqualify_name(ClassName, ClassNameString),
-		polymorphism__new_typeclass_info_var(Constraint,
-			ClassNameString, Var, VarSet0, VarSet1,
-			VarTypes0, VarTypes1),
+:- pred polymorphism__make_typeclass_info_from_subclass(class_constraint::in,
+	list(class_constraint)::in, class_id::in, class_constraint::in,
+	existq_tvars::in, prog_context::in, maybe(prog_var)::out,
+	list(hlds_goal)::in, list(hlds_goal)::out,
+	poly_info::in, poly_info::out) is det.
 
+polymorphism__make_typeclass_info_from_subclass(Constraint,
+		Seen, ClassId, SubClassConstraint, ExistQVars, Context,
+		MaybeVar, !ExtraGoals, !Info) :-
+	!.Info = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
+		TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
+	ClassId = class_id(ClassName, _ClassArity),
+	% First create a variable to hold the new typeclass_info.
+	unqualify_name(ClassName, ClassNameString),
+	polymorphism__new_typeclass_info_var(Constraint, ClassNameString,
+		Var, VarSet0, VarSet1, VarTypes0, VarTypes1),
 		MaybeVar = yes(Var),
-
 			% Then work out where to extract it from
-		SubClassConstraint =
-			constraint(SubClassName, SubClassTypes),
+	SubClassConstraint = constraint(SubClassName, SubClassTypes),
 		list__length(SubClassTypes, SubClassArity),
 		SubClassId = class_id(SubClassName, SubClassArity),
-
-		!:Info = poly_info(VarSet1, VarTypes1, TypeVarSet,
-			TypeInfoMap0, TypeClassInfoMap0, Proofs,
-			PredName, ModuleInfo),
+	!:Info = poly_info(VarSet1, VarTypes1, TypeVarSet, TypeInfoMap0,
+		TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
 
 			% Make the typeclass_info for the subclass
-		polymorphism__make_typeclass_info_var(
-			SubClassConstraint, Seen,
-			ExistQVars, Context,
-			!ExtraGoals, !Info, MaybeSubClassVar),
+	polymorphism__make_typeclass_info_var(SubClassConstraint, Seen,
+		ExistQVars, Context, !ExtraGoals, !Info, MaybeSubClassVar),
 		( MaybeSubClassVar = yes(SubClassVar0) ->
 			SubClassVar = SubClassVar0
 		;
@@ -2254,12 +2268,11 @@
 		SubClassDefn = hlds_class_defn(_, SuperClasses0,
 			SubClassVars, _, _, _, _),
 
-			% Work out which superclass typeclass_info to
-			% take
-		map__from_corresponding_lists(SubClassVars,
-			SubClassTypes, SubTypeSubst),
-		apply_subst_to_constraint_list(SubTypeSubst,
-			SuperClasses0, SuperClasses),
+	% Work out which superclass typeclass_info to take.
+	map__from_corresponding_lists(SubClassVars, SubClassTypes,
+		SubTypeSubst),
+	apply_subst_to_constraint_list(SubTypeSubst, SuperClasses0,
+		SuperClasses),
 		(
 			list__nth_member_search(SuperClasses, Constraint,
 				SuperClassIndex0)
@@ -2268,32 +2281,25 @@
 		;
 				% We shouldn't have got this far if
 				% the constraints were not satisfied
-			error("polymorphism.m: constraint " ++
-				"not in constraint list")
+		error("polymorphism.m: constraint not in constraint list")
 		),
 
 		poly_info_get_varset(!.Info, VarSet2),
 		poly_info_get_var_types(!.Info, VarTypes2),
-		make_int_const_construction(SuperClassIndex,
-			yes("SuperClassIndex"), IndexGoal, IndexVar,
-			VarTypes2, VarTypes, VarSet2, VarSet),
+	make_int_const_construction(SuperClassIndex, yes("SuperClassIndex"),
+		IndexGoal, IndexVar, VarTypes2, VarTypes, VarSet2, VarSet),
 		poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
 
-			% We extract the superclass typeclass_info by
-			% inserting a call to
-			% superclass_from_typeclass_info in
-			% private_builtin.
-			% Note that superclass_from_typeclass_info
-			% does not need extra type_info arguments
-			% even though its declaration is polymorphic.
+	% We extract the superclass typeclass_info by inserting a call
+	% to superclass_from_typeclass_info in private_builtin.
+	% Note that superclass_from_typeclass_info does not need
+	% extra type_info arguments even though its declaration
+	% is polymorphic.
 		goal_util__generate_simple_call(mercury_private_builtin_module,
 			"superclass_from_typeclass_info", predicate,
 			[SubClassVar, IndexVar, Var], only_mode, det, no,
 			[], ModuleInfo, term__context_init, SuperClassGoal),
-
-			% Add it to the accumulator
-		!:ExtraGoals = [SuperClassGoal, IndexGoal | !.ExtraGoals]
-	).
+	!:ExtraGoals = [SuperClassGoal, IndexGoal | !.ExtraGoals].
 
 :- pred polymorphism__construct_typeclass_info(list(prog_var)::in,
 	list(prog_var)::in, list(prog_var)::in, class_id::in,
@@ -2580,18 +2586,17 @@
 		TypeInfoLocn = TypeInfoLocn0
 	;
 		%
-		% Otherwise, we need to create a new type_info
-		% variable, and set the location for this type
-		% variable to be that type_info variable.
-		%
-		% This is wrong if the type variable is one of
-		% the existentially quantified variables of a called
-		% predicate and the variable occurs in an existential
-		% type-class constraint. In that case the type-info
-		% will be stored in the typeclass_info variable produced
-		% by the predicate, not in a type_info variable.
-		% make_typeclass_info_headvar will fix this up when
-		% the typeclass_info is created.
+		% Otherwise, we need to create a new type_info variable, and
+		% set the location for this type variable to be that
+		% type_info variable.
+		%
+		% This is wrong if the type variable is one of the
+		% existentially quantified variables of a called predicate
+		% and the variable occurs in an existential type-class
+		% constraint. In that case the type-info will be stored
+		% in the typeclass_info variable produced by the predicate,
+		% not in a type_info variable. make_typeclass_info_headvar
+		% will fix this up when the typeclass_info is created.
 		%
 		type_util__var(Type, TypeVar),
 		polymorphism__new_type_info_var(Type, type_info, Var, !Info),
@@ -2669,8 +2674,7 @@
 			ArityGoal, ArityVar, !VarTypes, !VarSet),
 		polymorphism__init_type_info_var(Type,
 			[TypeCtorVar, ArityVar | ArgTypeInfoVars],
-			no, Var, TypeInfoGoal,
-			!VarSet, !VarTypes),
+			no, Var, TypeInfoGoal, !VarSet, !VarTypes),
 		list__append([ArityGoal |  ArgTypeInfoGoals], [TypeInfoGoal],
 			ExtraGoals1),
 		list__append(ExtraGoals0, ExtraGoals1, ExtraGoals)
@@ -2950,9 +2954,8 @@
 	% Create 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)::in, list(prog_var)::out,
-	poly_info::in, poly_info::out) is det.
+:- pred polymorphism__make_typeclass_info_head_vars(list(class_constraint)::in,
+	list(prog_var)::out, poly_info::in, poly_info::out) is det.
 
 polymorphism__make_typeclass_info_head_vars(Constraints, ExtraHeadVars,
 		!Info) :-
@@ -2974,18 +2977,18 @@
 
 		Constraint = constraint(ClassName0, ClassTypes),
 
-			% Work out how many superclass the class has
+			% Work out how many superclasses the class has.
 		list__length(ClassTypes, ClassArity),
 		ClassId = class_id(ClassName0, ClassArity),
 		module_info_classes(ModuleInfo, ClassTable),
 		map__lookup(ClassTable, ClassId, ClassDefn),
-		ClassDefn = hlds_class_defn(_, SuperClasses, _, _, _, _, _),
+		SuperClasses = ClassDefn ^ class_supers,
 		list__length(SuperClasses, NumSuperClasses),
 
 		unqualify_name(ClassName0, ClassName),
 
 			% Make a new variable to contain the dictionary for
-			% this typeclass constraint
+			% this typeclass constraint.
 		polymorphism__new_typeclass_info_var(Constraint, ClassName,
 			ExtraHeadVar, VarSet0, VarSet1, VarTypes0, VarTypes1),
 
@@ -2994,7 +2997,7 @@
 			% info.
 
 			% The first type_info will be just after the superclass
-			% infos
+			% infos.
 		First = NumSuperClasses + 1,
 		term__vars_list(ClassTypes, ClassTypeVars0),
 		MakeIndex = (pred(Elem0::in, Elem::out,
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing java
cvs diff: Diffing java/library
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
Previous message: [m-rev.] diff: mtags: use perl -w
Next message: [m-rev.] diff: remove unnecessary duplicated prototypes
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
More information about the reviews mailing list