[m-dev.] for review: fix intermodule-optimization bug

[Simon Taylor]

Estimated hours taken: 2

Fix a bug reported by Robert Jeschofnik (rejj at students.cs.mu.oz.au)i
which caused unique mode errors to be reported for clauses in
a `.opt' file, but not in the `.m' file. This was due to the
extra headvar unifications added by writing out the clauses
and reading them back in again creating extra aliasing that the
current mode analyser can't handle.

compiler/intermod.m:
	Strip out the extra unifications for the head variables
	of a clause, replacing the introduced unification with
	the RHS term. This doesn't work for lambda-goal unifications,
	but they shouldn't occur in clause heads too often.

compiler/hlds_out.m:
	In hlds_out__write_clause, allow the arguments of the clause
	head to be terms rather than just variables.

tests/valid/nested_unique_intermod.m:
tests/valid/nested_unique_intermod2.m:
tests/invalid/builtin_int.m:
tests/invalid/builtin_int.err_exp:
	Test case.



Index: compiler/hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.228
diff -u -u -r1.228 hlds_out.m
--- hlds_out.m	1999/10/25 03:48:55	1.228
+++ hlds_out.m	1999/11/02 01:55:31
@@ -142,6 +142,12 @@
 :- mode hlds_out__write_clauses(in, in, in, in, in, in, in, in, in, di, uo)
 	is det.
 
+:- pred hlds_out__write_clause(int, module_info, pred_id, prog_varset, bool,
+		list(prog_term), pred_or_func, clause, maybe_vartypes,
+		io__state, io__state).
+:- mode hlds_out__write_clause(in, in, in, in, in, in, in, in, in, di, uo)
+	is det.
+
 :- pred hlds_out__write_assertion(int, module_info, pred_id, prog_varset, bool,
 		list(prog_var), pred_or_func, clause, maybe_vartypes,
 		io__state, io__state).
@@ -856,22 +862,18 @@
 	(
 		{ Clauses0 = [Clause|Clauses] }
 	->
+		{ term__var_list_to_term_list(HeadVars, HeadTerms) },
 		hlds_out__write_clause(Indent, ModuleInfo, PredId, VarSet,
-			AppendVarnums, HeadVars, PredOrFunc, Clause, TypeQual),
+			AppendVarnums, HeadTerms, PredOrFunc,
+			Clause, TypeQual),
 		hlds_out__write_clauses(Indent, ModuleInfo, PredId, VarSet,
 			AppendVarnums, HeadVars, PredOrFunc, Clauses, TypeQual)
 	;
 		[]
 	).
 
-:- pred hlds_out__write_clause(int, module_info, pred_id, prog_varset, bool,
-		list(prog_var), pred_or_func, clause, maybe_vartypes,
-		io__state, io__state).
-:- mode hlds_out__write_clause(in, in, in, in, in, in, in, in, in, di, uo)
-	is det.
-
 hlds_out__write_clause(Indent, ModuleInfo, PredId, VarSet,
-		AppendVarnums, HeadVars, PredOrFunc, Clause, TypeQual) -->
+		AppendVarnums, HeadTerms, PredOrFunc, Clause, TypeQual) -->
 	{
 		Clause = clause(
 			Modes,
@@ -892,7 +894,7 @@
 		[]
 	),
 	hlds_out__write_clause_head(ModuleInfo, PredId, VarSet, AppendVarnums,
-		HeadVars, PredOrFunc),
+		HeadTerms, PredOrFunc),
 	( { Goal = conj([]) - _GoalInfo } ->
 		io__write_string(".\n")
 	;
@@ -934,26 +936,26 @@
 	).
 
 :- pred hlds_out__write_clause_head(module_info, pred_id, prog_varset, bool,
-		list(prog_var), pred_or_func, io__state, io__state).
+		list(prog_term), pred_or_func, io__state, io__state).
 :- mode hlds_out__write_clause_head(in, in, in, in, in, in, di, uo) is det.
 
 hlds_out__write_clause_head(ModuleInfo, PredId, VarSet, AppendVarnums,
-			HeadVars, PredOrFunc) -->
+			HeadTerms, PredOrFunc) -->
 	{ predicate_name(ModuleInfo, PredId, PredName) },
 	{ predicate_module(ModuleInfo, PredId, ModuleName) },
 	(
 		{ PredOrFunc = function },
-		{ pred_args_to_func_args(HeadVars, FuncArgs, RetVal) },
-		hlds_out__write_qualified_functor(ModuleName,
-			term__atom(PredName), FuncArgs, VarSet,
+		{ pred_args_to_func_args(HeadTerms, FuncArgs, RetVal) },
+		hlds_out__write_qualified_functor_with_term_args(
+			ModuleName, term__atom(PredName), FuncArgs, VarSet,
 			AppendVarnums),
 		io__write_string(" = "),
-		mercury_output_term(term__variable(RetVal), VarSet,
+		mercury_output_term(RetVal, VarSet,
 			AppendVarnums, next_to_graphic_token)
 	;
 		{ PredOrFunc = predicate },
-		hlds_out__write_qualified_functor(ModuleName,
-			term__atom(PredName), HeadVars, VarSet,
+		hlds_out__write_qualified_functor_with_term_args(
+			ModuleName, term__atom(PredName), HeadTerms, VarSet,
 			AppendVarnums)
 	).
 
@@ -1957,6 +1959,19 @@
 	hlds_out__write_functor(Functor, ArgVars, VarSet, AppendVarnums,
 		next_to_graphic_token).
 
+:- pred hlds_out__write_qualified_functor_with_term_args(module_name, const,
+		list(prog_term), prog_varset, bool, io__state, io__state).
+:- mode hlds_out__write_qualified_functor_with_term_args(in, in, in,
+		in, in, di, uo) is det.
+
+hlds_out__write_qualified_functor_with_term_args(ModuleName, Functor,
+		ArgTerms, VarSet, AppendVarNums) -->
+	mercury_output_bracketed_sym_name(ModuleName),
+	io__write_string(":"),
+	{ term__context_init(Context) },
+	mercury_output_term(term__functor(Functor, ArgTerms, Context), VarSet,
+		AppendVarNums, next_to_graphic_token).
+
 hlds_out__write_functor_cons_id(ConsId, ArgVars, VarSet, ModuleInfo,
 		AppendVarnums) -->
 	(
@@ -2859,8 +2874,9 @@
 		hlds_out__write_stack_slots(Indent, StackSlots, VarSet,
 			AppendVarnums),
 		hlds_out__write_indent(Indent),
+		{ term__var_list_to_term_list(HeadVars, HeadTerms) },
 		hlds_out__write_clause_head(ModuleInfo, PredId, VarSet,
-			AppendVarnums, HeadVars, PredOrFunc),
+			AppendVarnums, HeadTerms, PredOrFunc),
 		io__write_string(" :-\n"),
 		hlds_out__write_goal(Goal, ModuleInfo, VarSet, AppendVarnums,
 			Indent1, ".\n")
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.72
diff -u -u -r1.72 intermod.m
--- intermod.m	1999/10/25 03:49:01	1.72
+++ intermod.m	1999/11/08 02:37:04
@@ -1193,12 +1193,111 @@
 		)
 	;
 		% { pred_info_typevarset(PredInfo, TVarSet) },
-		hlds_out__write_clauses(1, ModuleInfo, PredId, VarSet, no,
-			HeadVars, PredOrFunc, Clauses, no)
-		%	HeadVars, Clauses, yes(TVarSet, VarTypes))
+		list__foldl(intermod__write_clause(ModuleInfo, PredId, VarSet,
+			HeadVars, PredOrFunc), Clauses)
 	),
 	intermod__write_preds(ModuleInfo, PredIds).
 
+:- pred intermod__write_clause(module_info::in, pred_id::in, prog_varset::in,
+		list(prog_var)::in, pred_or_func::in, clause::in,
+		io__state::di, io__state::uo) is det.
+
+intermod__write_clause(ModuleInfo, PredId, VarSet, HeadVars,
+		PredOrFunc, Clause0) -->
+	{ strip_headvar_unifications(HeadVars, Clause0,
+		ClauseHeadVars, Clause) },
+	hlds_out__write_clause(1, ModuleInfo, PredId, VarSet, no,
+		ClauseHeadVars, PredOrFunc, Clause, no).
+
+	% Strip the `Headvar__n = Term' unifications from each clause,
+	% except if the `Term' is a lambda expression.
+	%
+	% At least two problems occur if this is not done:
+	% - in some cases where nested unique modes were accepted by
+	% 	mode analysis, the extra aliasing added by the extra level
+	%	of headvar unifications caused mode analysis to report
+	% 	an error (ground expected unique), when analysing the
+	% 	clauses read in from `.opt' files.
+	% - only HeadVar unifications may be reordered with impure goals,
+	%	so a mode error results for the second level of headvar
+	% 	unifications added when the clauses are read in again from
+	%	the `.opt' file. Clauses containing impure goals are not
+	%	written to the `.opt' file for this reason.
+:- pred strip_headvar_unifications(list(prog_var)::in,
+		clause::in, list(prog_term)::out, clause::out) is det.
+
+strip_headvar_unifications(HeadVars, clause(ProcIds, Goal0, Context),
+		HeadTerms, clause(ProcIds, Goal, Context)) :-
+	Goal0 = _ - GoalInfo0,
+	goal_to_conj_list(Goal0, Goals0),
+	map__init(HeadVarMap0),
+	(
+		strip_headvar_unifications_from_goal_list(Goals0, HeadVars,
+			[], Goals, HeadVarMap0, HeadVarMap)
+	->
+		list__map(
+		    (pred(HeadVar0::in, HeadTerm::out) is det :-
+			( map__search(HeadVarMap, HeadVar0, HeadTerm0) ->
+				HeadTerm = HeadTerm0
+			;
+				HeadTerm = term__variable(HeadVar0)
+			)
+		    ), HeadVars, HeadTerms),
+		conj_list_to_goal(Goals, GoalInfo0, Goal)
+	;
+		term__var_list_to_term_list(HeadVars, HeadTerms),
+		Goal = Goal0
+	).
+
+:- pred strip_headvar_unifications_from_goal_list(list(hlds_goal)::in,
+		list(prog_var)::in, list(hlds_goal)::in, list(hlds_goal)::out,
+		map(prog_var, prog_term)::in,
+		map(prog_var, prog_term)::out) is semidet.
+
+strip_headvar_unifications_from_goal_list([], _, RevGoals, Goals,
+		HeadVarMap, HeadVarMap) :-
+	list__reverse(RevGoals, Goals).
+strip_headvar_unifications_from_goal_list([Goal | Goals0], HeadVars,
+		RevGoals0, Goals, HeadVarMap0, HeadVarMap) :-
+	(
+		Goal = unify(LHSVar, RHS, _, _, _) - _,
+		list__member(LHSVar, HeadVars),
+		(
+			RHS = var(RHSVar),
+			RHSTerm = term__variable(RHSVar)
+		;
+			RHS = functor(ConsId, Args),
+			term__context_init(Context),
+			(
+				ConsId = int_const(Int),
+				RHSTerm = term__functor(term__integer(Int),
+						[], Context)
+			;
+				ConsId = float_const(Float),
+				RHSTerm = term__functor(term__float(Float),
+						[], Context)
+			;
+				ConsId = string_const(String),
+				RHSTerm = term__functor(term__string(String),
+						[], Context)
+			;
+				ConsId = cons(SymName, _),
+				term__var_list_to_term_list(Args, ArgTerms),
+				construct_qualified_term(SymName, ArgTerms,
+					RHSTerm)
+			)
+		)
+	->
+		% Don't strip the headvar unifications if one of the
+		% headvars appears twice. This should probably never happen.
+		map__insert(HeadVarMap0, LHSVar, RHSTerm, HeadVarMap1),
+		RevGoals1 = RevGoals0
+	;
+		HeadVarMap1 = HeadVarMap0,
+		RevGoals1 = [Goal | RevGoals0]
+	),
+	strip_headvar_unifications_from_goal_list(Goals0, HeadVars,
+		RevGoals1, Goals, HeadVarMap1, HeadVarMap).
 
 :- pred intermod__write_pragmas(pred_info::in,
 		io__state::di, io__state::uo) is det.
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/valid/Mmakefile,v
retrieving revision 1.45
diff -u -u -r1.45 Mmakefile
--- Mmakefile	1999/10/26 23:24:43	1.45
+++ Mmakefile	1999/11/08 01:56:41
@@ -62,6 +62,7 @@
 	int64.m \
 	intermod_impure.m \
 	intermod_lambda.m \
+	intermod_nested_uniq.m \
 	intermod_quote.m \
 	intermod_test.m \
 	ite_to_disj.m \
@@ -182,6 +183,8 @@
 MCFLAGS-intermod_impure2	= --intermodule-optimization
 MCFLAGS-intermod_lambda		= --intermodule-optimization
 MCFLAGS-intermod_lambda2	= --intermodule-optimization
+MCFLAGS-intermod_nested_uniq	= --intermodule-optimization
+MCFLAGS-intermod_nested_uniq2	= --intermodule-optimization
 MCFLAGS-intermod_quote		= --intermodule-optimization
 MCFLAGS-intermod_quote2		= --intermodule-optimization
 MCFLAGS-intermod_test		= --intermodule-optimization
Index: tests/valid/intermod_nested_uniq.m
===================================================================
RCS file: intermod_nested_uniq.m
diff -N intermod_nested_uniq.m
--- /dev/null	Mon Nov  8 14:05:00 1999
+++ intermod_nested_uniq.m	Mon Nov  8 12:55:57 1999
@@ -0,0 +1,21 @@
+%-----------------------------------------------------------------------------%
+:- module intermod_nested_uniq.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+%-----------------------------------------------------------------------------%
+
+:- import_module intermod_nested_uniq2.
+
+main -->
+	{ init(1, 1, Matrix) },
+	{ lookup(1, 1, Matrix, _) }.
+
Index: tests/valid/intermod_nested_uniq2.m
===================================================================
RCS file: intermod_nested_uniq2.m
diff -N intermod_nested_uniq2.m
--- /dev/null	Mon Nov  8 14:05:00 1999
+++ intermod_nested_uniq2.m	Mon Nov  8 12:55:57 1999
@@ -0,0 +1,45 @@
+%-----------------------------------------------------------------------------%
+:- module intermod_nested_uniq2.
+
+:- interface.
+
+:- import_module array.
+
+:- inst uniq_f_matrix == unique(f_matrix(ground, ground, uniq_array)).
+
+:- mode f_matrix_di == di(uniq_f_matrix).
+:- mode f_matrix_uo == out(uniq_f_matrix).
+:- mode f_matrix_ui == in(uniq_f_matrix).
+
+:- type f_matrix.
+
+:- pred init(int, int, f_matrix).
+:- mode init(in, in, f_matrix_uo) is det.
+
+:- pred lookup(int, int, f_matrix, float).
+:- mode lookup(in, in, f_matrix_ui, out) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module array, float, int.
+
+:- type f_matrix --->
+	f_matrix(
+		 int,		% M
+		 int,		% N
+		 array(float)	% the elements of the matrix
+		).
+
+%-----------------------------------------------------------------------------%
+
+init(M, N, Matrix) :-
+	array__init(M * N, 0.0, Array),
+	Matrix = f_matrix(M, N, Array).
+
+% Lookup element (I, J) in the f_matrix.
+% If (I, J) is not a valid index to the matrix, the behaviour is undefined
+lookup(I, J, f_matrix(_M, N, Array), Elem) :-
+	array__lookup(Array, (I * N) + J, Elem).
+
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------