[m-rev.] for review: fix purity problems

[Simon Taylor]

Estimated hours taken: 2
Branches: main

Fix bugs in the handling of impurity which broke `solutions/2'
in grade asm_fast when compiled with `--optimize-duplicate-calls'.

compiler/purity.m:
	Fix the handling of `foreign_proc' goals. Previously they
	were always assumed to be pure. Now they have the purity
	of the predicate they implement.

compiler/inlining.m:
	Compare the purity of the old and new goals when
	checking whether purity checking needs to be rerun,
	rather than just checking for `promise_pure' markers.

compiler/options.m:
	Re-enable `--optimize-duplicate-calls'.
	
tests/hard_coded/Mmakefile:
tests/hard_coded/impure_foreign.{m,exp}:
	Test case.

Index: compiler/inlining.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inlining.m,v
retrieving revision 1.103
diff -u -u -r1.103 inlining.m
--- compiler/inlining.m	10 Aug 2001 14:51:58 -0000	1.103
+++ compiler/inlining.m	13 Dec 2001 13:49:24 -0000
@@ -584,11 +584,9 @@
 			Requantify = yes
 		),
 
-		pred_info_get_markers(PredInfo, CalleeMarkers),
 		(
-			( check_marker(CalleeMarkers, promised_pure)
-			; check_marker(CalleeMarkers, promised_semipure)
-			)
+			infer_goal_info_purity(GoalInfo0, Purity),
+			infer_goal_info_purity(GoalInfo, Purity)
 		->
 			PurityChanged = yes
 		;
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.349
diff -u -u -r1.349 options.m
--- compiler/options.m	14 Dec 2001 01:29:07 -0000	1.349
+++ compiler/options.m	14 Dec 2001 01:42:35 -0000
@@ -1732,11 +1732,7 @@
 	common_struct		-	bool(yes),
 	user_guided_type_specialization
 				-	bool(yes),
-% XXX optimize_duplicate_calls is broken -- it ignores impurity.
-% It currently screws up builtin_aggregate, which leads to failures
-% of most test cases using solutions/2 (e.g. general/commit_bug)
-% in grade asm_fast. It should be reenabled when we have fixed that bug.
-%	optimize_duplicate_calls -	bool(yes),
+	optimize_duplicate_calls -	bool(yes),
 	simple_neg		-	bool(yes),
 
 	optimize_rl		-	bool(yes),
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.39
diff -u -u -r1.39 purity.m
--- compiler/purity.m	13 Dec 2001 09:06:05 -0000	1.39
+++ compiler/purity.m	14 Dec 2001 14:39:08 -0000
@@ -431,44 +431,30 @@
 puritycheck_pred(PredId, PredInfo0, PredInfo, ModuleInfo, NumErrors) -->
 	{ pred_info_get_purity(PredInfo0, DeclPurity) } ,
 	{ pred_info_get_promised_purity(PredInfo0, PromisedPurity) },
-		% XXX we should remove this test when we have bootstrapped
-		% the changes requires to make foreign_proc impure by default
-	( { pred_info_get_goal_type(PredInfo0, pragmas) } ->
-		{ WorstPurity = (impure) },
-			% This is where we assume pragma foreign_proc is
-			% pure.
-		{ Purity = (pure) },
-		{ PredInfo = PredInfo0 },
-		{ NumErrors0 = 0 }
-	;   
-		{ pred_info_clauses_info(PredInfo0, ClausesInfo0) },
-		{ pred_info_procids(PredInfo0, ProcIds) },
-		{ clauses_info_clauses(ClausesInfo0, Clauses0) },
-		{ clauses_info_vartypes(ClausesInfo0, VarTypes0) },
-		{ clauses_info_varset(ClausesInfo0, VarSet0) },
-		{ RunPostTypecheck = yes },
-		{ PurityInfo0 = purity_info(ModuleInfo, RunPostTypecheck,
-			PredInfo0, VarTypes0, VarSet0, []) },
-		{ compute_purity(Clauses0, Clauses, ProcIds, pure, Purity,
-			PurityInfo0, PurityInfo) },
-		{ PurityInfo = purity_info(_, _, PredInfo1,
-			VarTypes, VarSet, RevMessages) },
-		{ clauses_info_set_vartypes(ClausesInfo0,
-			VarTypes, ClausesInfo1) },
-		{ clauses_info_set_varset(ClausesInfo1,
-			VarSet, ClausesInfo2) },
-		{ Messages = list__reverse(RevMessages) },
-		list__foldl(report_post_typecheck_message(ModuleInfo),
-			Messages),
-		{ NumErrors0 = list__length(
-				list__filter((pred(error(_)::in) is semidet),
-				Messages)) },
-		{ clauses_info_set_clauses(ClausesInfo2, Clauses,
-				ClausesInfo) },
-		{ pred_info_set_clauses_info(PredInfo1, ClausesInfo,
-				PredInfo) },
-		{ WorstPurity = Purity }
-	),
+  
+	{ pred_info_clauses_info(PredInfo0, ClausesInfo0) },
+	{ pred_info_procids(PredInfo0, ProcIds) },
+	{ clauses_info_clauses(ClausesInfo0, Clauses0) },
+	{ clauses_info_vartypes(ClausesInfo0, VarTypes0) },
+	{ clauses_info_varset(ClausesInfo0, VarSet0) },
+	{ RunPostTypecheck = yes },
+	{ PurityInfo0 = purity_info(ModuleInfo, RunPostTypecheck,
+		PredInfo0, VarTypes0, VarSet0, []) },
+	{ pred_info_get_goal_type(PredInfo0, GoalType) },
+	{ compute_purity(GoalType, Clauses0, Clauses, ProcIds, pure, Purity,
+		PurityInfo0, PurityInfo) },
+	{ PurityInfo = purity_info(_, _, PredInfo1,
+		VarTypes, VarSet, RevMessages) },
+	{ clauses_info_set_vartypes(ClausesInfo0, VarTypes, ClausesInfo1) },
+	{ clauses_info_set_varset(ClausesInfo1, VarSet, ClausesInfo2) },
+	{ Messages = list__reverse(RevMessages) },
+	list__foldl(report_post_typecheck_message(ModuleInfo), Messages),
+	{ NumErrors0 = list__length(
+			list__filter((pred(error(_)::in) is semidet),
+			Messages)) },
+	{ clauses_info_set_clauses(ClausesInfo2, Clauses, ClausesInfo) },
+	{ pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo) },
+	{ WorstPurity = Purity },
 	{ perform_pred_purity_checks(PredInfo, Purity, DeclPurity,
 		PromisedPurity, PurityCheckResult) },
 	( { PurityCheckResult = inconsistent_promise },
@@ -565,20 +551,24 @@
 
 % Infer the purity of a single (non-pragma c_code) predicate
 
-:- pred compute_purity(list(clause), list(clause), list(proc_id),
+:- pred compute_purity(goal_type, list(clause), list(clause), list(proc_id),
 	purity, purity, purity_info, purity_info).
-:- mode compute_purity(in, out, in, in, out, in, out) is det.
+:- mode compute_purity(in, in, out, in, in, out, in, out) is det.
 
-compute_purity([], [], _, Purity, Purity) --> [].
-compute_purity([Clause0|Clauses0], [Clause|Clauses], ProcIds,
+compute_purity(_, [], [], _, Purity, Purity) --> [].
+compute_purity(GoalType, [Clause0|Clauses0], [Clause|Clauses], ProcIds,
 		Purity0, Purity) -->
 	{ Clause0 = clause(Ids, Body0 - Info0, Lang, Context) },
 	compute_expr_purity(Body0, Body, Info0, no, Bodypurity0),
 	% If this clause doesn't apply to all modes of this procedure,
 	% i.e. the procedure has different clauses for different modes,
 	% then we must treat it as impure.
+	% XXX Currently `:- pragma foreign_proc' procedures are
+	% assumed to be pure. This will change.
 	{
-		applies_to_all_modes(Clause0, ProcIds)
+		( applies_to_all_modes(Clause0, ProcIds)
+		; GoalType = pragmas
+		)
 	->
 		Clausepurity = (pure)
 	;
@@ -588,7 +578,7 @@
 	{ add_goal_info_purity_feature(Info0, Bodypurity, Info) },
 	{ worst_purity(Purity0, Bodypurity, Purity1) },
 	{ Clause = clause(Ids, Body - Info, Lang, Context) },
-	compute_purity(Clauses0, Clauses, ProcIds, Purity1, Purity).
+	compute_purity(GoalType, Clauses0, Clauses, ProcIds, Purity1, Purity).
 
 :- pred applies_to_all_modes(clause::in, list(proc_id)::in) is semidet.
 
@@ -785,8 +775,24 @@
 	{ worst_purity(Purity1, Purity2, Purity12) },
 	{ worst_purity(Purity12, Purity3, Purity) }.
 compute_expr_purity(Ccode, Ccode, _, _, Purity) -->
-	{ Ccode = foreign_proc(Attributes,_,_,_,_,_,_) },
-	{ purity(Attributes, Purity) }.
+	{ Ccode = foreign_proc(Attributes, PredId, _,_,_,_,_) },
+	{ purity(Attributes, AttributesPurity) },
+
+	%
+	% If there were no purity attributes, the purity of the goal
+	% is the purity of the predicate.
+	% XXX Currently the default purity is `pure'. Eventually it
+	% should default to `impure', and require promises for any
+	% other purity levels, i.e. Purity = AttributesPurity.
+	%
+	ModuleInfo =^ module_info,
+	{ AttributesPurity = (pure) ->
+		module_info_pred_info(ModuleInfo, PredId, PredInfo),
+		pred_info_get_purity(PredInfo, Purity)
+	;
+		Purity = AttributesPurity
+	}.
+
 compute_expr_purity(shorthand(_), _, _, _, _) -->
 	% these should have been expanded out by now
 	{ error("compute_expr_purity: unexpected shorthand") }.
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.136
diff -u -u -r1.136 Mmakefile
--- tests/hard_coded/Mmakefile	6 Dec 2001 10:16:43 -0000	1.136
+++ tests/hard_coded/Mmakefile	12 Dec 2001 15:52:20 -0000
@@ -73,6 +73,7 @@
 	ho_solns \
 	ho_univ_to_type \
 	impossible_unify \
+	impure_foreign \
 	impure_prune \
 	integer_test \
 	intermod_c_code \
@@ -229,6 +230,7 @@
 MCFLAGS-ho_order	=	--optimize-higher-order
 MCFLAGS-ho_order2	=	--optimize-higher-order
 MCFLAGS-no_fully_strict	=	--no-fully-strict
+MCFLAGS-impure_foreign	=	--optimize-duplicate-calls
 MCFLAGS-intermod_c_code =	--intermodule-optimization
 MCFLAGS-intermod_c_code2 =	--intermodule-optimization
 MCFLAGS-intermod_multimode =	--intermodule-optimization
Index: tests/hard_coded/impure_foreign.exp
===================================================================
RCS file: tests/hard_coded/impure_foreign.exp
diff -N tests/hard_coded/impure_foreign.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/impure_foreign.exp	13 Dec 2001 15:16:19 -0000
@@ -0,0 +1,2 @@
+1
+4
Index: tests/hard_coded/impure_foreign.m
===================================================================
RCS file: tests/hard_coded/impure_foreign.m
diff -N tests/hard_coded/impure_foreign.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/impure_foreign.m	13 Dec 2001 15:15:23 -0000
@@ -0,0 +1,62 @@
+:- module impure_foreign.
+
+:- interface.
+
+:- import_module io.
+
+:- impure pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module require.
+
+main -->
+		% Inlining this call forces recomputation
+		% of purity for main/2 (because of the
+		% `:- pragma promise_pure').
+		% In some versions of this compiler, this
+		% recomputation would erroneously infer
+		% that the inlined calls to incr/1 below
+		% were `pure'. Duplicate call elimination
+		% would then remove all but one of them.
+	{ unsafe_get(Val0) },
+
+	io__write_int(Val0),
+	io__nl,
+
+	{ impure incr(_) },
+	{ impure incr(_) },
+	{ impure incr(_) },
+	{ semipure get(Val) },
+	io__write_int(Val),
+	io__nl.
+
+:- pragma foreign_decl("C",
+"
+	int counter;
+").
+
+:- pragma foreign_code("C",
+"
+	int counter = 1;
+").
+
+:- impure pred incr(int::out) is det.
+
+incr(_::out) :- error("incr/1 called for language other than C").
+
+:- pragma foreign_proc("C", incr(Val::out), [will_not_call_mercury],
+			"counter++; Val = counter;").
+
+:- semipure pred get(int::out) is det.
+
+get(_::out) :- error("get/1 called for language other than C").
+
+:- pragma foreign_proc("C", get(Val::out),
+		[will_not_call_mercury, promise_semipure],
+		"Val = counter").
+	
+:- pred unsafe_get(int::out) is det.
+:- pragma promise_pure(unsafe_get/1).
+
+unsafe_get(X) :- semipure get(X).
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------