[m-rev.] for review: fix mode-specific clauses bug

[Simon Taylor]

Estimated hours taken: 0.5
Branches: main

compiler/hlds_out.m:
	When writing a mode-specific clause in a `.opt' file, get the modes
	of the procedure using proc_info_declared_argmodes rather than
	proc_info_argmodes. This is necessary because the test in
	make_hlds.m to work out whether a clause matches a mode declaration
	uses syntactic equality on the modes, but the modes returned by
	proc_info_argmodes may have been expanded by
	propagate_types_into_modes.

compiler/intermod.m:
	Tell hlds_out.m to use the declared modes when writing clauses.

tests/hard_coded/multimode.m:
tests/hard_coded/multimode_main.exp:
	Test case.

Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.268
diff -u -u -r1.268 hlds_out.m
--- compiler/hlds_out.m	2001/08/12 08:16:24	1.268
+++ compiler/hlds_out.m	2001/08/17 06:14:58
@@ -147,16 +147,21 @@
 :- pred hlds_out__write_hlds(int, module_info, io__state, io__state).
 :- mode hlds_out__write_hlds(in, in, di, uo) is det.
 
+	% hlds_out__write_clause(Indent, ModuleInfo, PredId, VarSet,
+	%	AppendVarNums, HeadVars, PredOrFunc, Clauses, MaybeVarTypes).
 :- pred hlds_out__write_clauses(int, module_info, pred_id, prog_varset, bool,
 		list(prog_var), pred_or_func, list(clause), maybe_vartypes,
 		io__state, io__state).
 :- mode hlds_out__write_clauses(in, in, in, in, in, in, in, in, in, di, uo)
 	is det.
 
+	% hlds_out__write_clause(Indent, ModuleInfo, PredId, VarSet,
+	%	AppendVarNums, HeadTerms, PredOrFunc, Clause,
+	%	UseDeclaredModes, MaybeVarTypes).
 :- pred hlds_out__write_clause(int, module_info, pred_id, prog_varset, bool,
-		list(prog_term), pred_or_func, clause, maybe_vartypes,
+		list(prog_term), pred_or_func, clause, bool, maybe_vartypes,
 		io__state, io__state).
-:- mode hlds_out__write_clause(in, in, in, in, in, in, in, in, in, di, uo)
+:- mode hlds_out__write_clause(in, 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,
@@ -933,9 +938,10 @@
 		{ Clauses0 = [Clause|Clauses] }
 	->
 		{ term__var_list_to_term_list(HeadVars, HeadTerms) },
+		{ UseDeclaredModes = no },
 		hlds_out__write_clause(Indent, ModuleInfo, PredId, VarSet,
 			AppendVarnums, HeadTerms, PredOrFunc,
-			Clause, TypeQual),
+			Clause, UseDeclaredModes, TypeQual),
 		hlds_out__write_clauses(Indent, ModuleInfo, PredId, VarSet,
 			AppendVarnums, HeadVars, PredOrFunc, Clauses, TypeQual)
 	;
@@ -943,7 +949,8 @@
 	).
 
 hlds_out__write_clause(Indent, ModuleInfo, PredId, VarSet,
-		AppendVarnums, HeadTerms, PredOrFunc, Clause, TypeQual) -->
+		AppendVarnums, HeadTerms, PredOrFunc, Clause,
+		UseDeclaredModes, TypeQual) -->
 	{
 		Clause = clause(
 			Modes,
@@ -984,7 +991,7 @@
 		% than a compiler abort during the dumping process.
 		hlds_out__write_annotated_clause_heads(ModuleInfo, Context,
 			PredId, Modes, VarSet, AppendVarnums, HeadTerms,
-			PredOrFunc)
+			PredOrFunc, UseDeclaredModes)
 	),
 	( { Goal = conj([]) - _GoalInfo } ->
 		io__write_string(".\n")
@@ -996,29 +1003,53 @@
 
 :- pred hlds_out__write_annotated_clause_heads(module_info::in,
 	term__context::in, pred_id::in, list(proc_id)::in, prog_varset::in,
-	bool::in, list(prog_term)::in, pred_or_func::in,
+	bool::in, list(prog_term)::in, pred_or_func::in, bool::in,
 	io__state::di, io__state::uo) is det.
 
-hlds_out__write_annotated_clause_heads(_, _, _, [], _, _, _, _) --> [].
+hlds_out__write_annotated_clause_heads(_, _, _, [], _, _, _, _, _) --> [].
 hlds_out__write_annotated_clause_heads(ModuleInfo, Context, PredId,
 		[ProcId | ProcIds], VarSet, AppendVarnums, HeadTerms,
-		PredOrFunc) -->
+		PredOrFunc, UseDeclaredModes) -->
 	hlds_out__write_annotated_clause_head(ModuleInfo, Context, PredId,
-		ProcId, VarSet, AppendVarnums, HeadTerms, PredOrFunc),
+		ProcId, VarSet, AppendVarnums, HeadTerms,
+		PredOrFunc, UseDeclaredModes),
 	hlds_out__write_annotated_clause_heads(ModuleInfo, Context, PredId,
-		ProcIds, VarSet, AppendVarnums, HeadTerms, PredOrFunc).
+		ProcIds, VarSet, AppendVarnums, HeadTerms,
+		PredOrFunc, UseDeclaredModes).
 
 :- pred hlds_out__write_annotated_clause_head(module_info::in,
 	term__context::in, pred_id::in, proc_id::in, prog_varset::in,
-	bool::in, list(prog_term)::in, pred_or_func::in,
+	bool::in, list(prog_term)::in, pred_or_func::in, bool::in,
 	io__state::di, io__state::uo) is det.
 
 hlds_out__write_annotated_clause_head(ModuleInfo, Context, PredId, ProcId,
-		VarSet, AppendVarnums, HeadTerms, PredOrFunc) -->
+		VarSet, AppendVarnums, HeadTerms,
+		PredOrFunc, UseDeclaredModes) -->
 	{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
 	{ pred_info_procedures(PredInfo, Procedures) },
 	( { map__search(Procedures, ProcId, ProcInfo) } ->
-		{ proc_info_argmodes(ProcInfo, ArgModes) },
+		%
+		% When writing `.opt' files, use the declared
+		% argument modes so that the modes are guaranteed
+		% to be syntactically identical to those in the
+		% original program. The test in make_hlds.m to
+		% check whether a clause matches a procedure 
+		% tests for syntactic identity (roughly).
+		% The modes returned by proc_info_argmodes may have
+		% been slightly expanded by propagate_types_into_modes.
+		%
+		% We can't use the declared argument modes when writing
+		% HLDS dumps because the modes of the type-infos will
+		% not have been added, so the call to
+		% assoc_list__from_corresponding_lists below
+		% will abort. `.opt' files are written before
+		% the polymorphism pass.
+		%
+		{ UseDeclaredModes = yes ->
+			proc_info_declared_argmodes(ProcInfo, ArgModes)
+		;
+			proc_info_argmodes(ProcInfo, ArgModes)
+		},
 		{ assoc_list__from_corresponding_lists(HeadTerms, ArgModes, 
 			AnnotatedPairs) },
 		{ AnnotatedHeadTerms = list__map(add_mode_qualifier(Context),
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.106
diff -u -u -r1.106 intermod.m
--- compiler/intermod.m	2001/08/12 08:13:09	1.106
+++ compiler/intermod.m	2001/08/17 05:12:38
@@ -1437,8 +1437,11 @@
 	% where the added arguments for a DCG pred expression
 	% are named the same as variables in the enclosing clause.
 	{ AppendVarNums = yes },
+	{ ForIntermod = yes },
+	{ MaybeVarTypes = no },
 	hlds_out__write_clause(1, ModuleInfo, PredId, VarSet, AppendVarNums,
-		ClauseHeadVars, PredOrFunc, Clause, no).
+		ClauseHeadVars, PredOrFunc, Clause, ForIntermod,
+		MaybeVarTypes).
 
 intermod__write_clause(ModuleInfo, PredId, VarSet, _HeadVars,
 		PredOrFunc, SymName, Clause) -->
Index: tests/hard_coded/intermod_multimode.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/intermod_multimode.m,v
retrieving revision 1.1
diff -u -u -r1.1 intermod_multimode.m
--- tests/hard_coded/intermod_multimode.m	2001/05/27 09:57:58	1.1
+++ tests/hard_coded/intermod_multimode.m	2001/08/17 05:22:50
@@ -29,6 +29,24 @@
 
 :- impure pred puts(string::in) is det.
 
+:- type determinism
+	--->	det
+	;	semidet
+	;	cc_multi
+	;	cc_nondet
+	;	multi
+	;	nondet
+	;	erroneous
+	;	failure.
+
+:- pred get_determinism(pred(T), determinism).
+:- mode get_determinism(pred(out) is det,     out(bound(det)))     is det.
+:- mode get_determinism(pred(out) is semidet, out(bound(semidet))) is det.
+:- mode get_determinism(pred(out) is multi, out(bound(multi)))     is det.
+:- mode get_determinism(pred(out) is nondet, out(bound(nondet)))   is det.
+:- mode get_determinism(pred(out) is cc_multi, out(bound(cc_multi))) is det.
+:- mode get_determinism(pred(out) is cc_nondet, out(bound(cc_nondet))) is det.
+
 :- implementation.
 
 func0 = ("func0 = out" :: out).
@@ -65,3 +83,12 @@
 	impure puts("test2(out, out)").
 
 :- pragma c_code(puts(S::in), [will_not_call_mercury], "puts(S)").
+
+:- pragma promise_pure(get_determinism/2).
+get_determinism(_Pred::(pred(out) is det), det::out(bound(det))).
+get_determinism(_Pred::(pred(out) is semidet), semidet::out(bound(semidet))).
+get_determinism(_Pred::(pred(out) is cc_multi), cc_multi::out(bound(cc_multi))).
+get_determinism(_Pred::(pred(out) is cc_nondet), cc_nondet::out(bound(cc_nondet))).
+get_determinism(_Pred::(pred(out) is multi), multi::out(bound(multi))).
+get_determinism(_Pred::(pred(out) is nondet), nondet::out(bound(nondet))).
+
Index: tests/hard_coded/intermod_multimode_main.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/intermod_multimode_main.exp,v
retrieving revision 1.1
diff -u -u -r1.1 intermod_multimode_main.exp
--- tests/hard_coded/intermod_multimode_main.exp	2001/05/27 09:57:58	1.1
+++ tests/hard_coded/intermod_multimode_main.exp	2001/08/17 05:26:09
@@ -12,3 +12,4 @@
 test2(in, out)
 test2(out, in)
 test2(out, out)
+semidet
Index: tests/hard_coded/intermod_multimode_main.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/intermod_multimode_main.m,v
retrieving revision 1.1
diff -u -u -r1.1 intermod_multimode_main.m
--- tests/hard_coded/intermod_multimode_main.m	2001/05/27 09:57:58	1.1
+++ tests/hard_coded/intermod_multimode_main.m	2001/08/17 05:25:21
@@ -31,5 +31,9 @@
 	{ impure test2(In, In) },
 	{ impure test2(In, _Out11) },
 	{ impure test2(_Out12, In) },
-	{ impure test2(_Out13, _Out14) }.
+	{ impure test2(_Out13, _Out14) },
+	
+	{ get_determinism((pred(1::out) is semidet), Det) },
+	io__write(Det),
+	io__nl.
 
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------