[m-dev.] for review: default modes for higher-order func insts

[David Overton]

Hi,

This diff implements Ralph's suggestion which was discussed on
mercury-developers last week.

I still think it requires further consideration before committing
since it changes the language in a non-backwards-compatible way.
For those of us in Melbourne, perhaps we can disuss this in the
meeting this afternoon.


David

----

Estimated hours taken: 3
Branches: main

Implement a change to the mode system suggested by Ralph Becket to make use of
higher order functions a bit easier.

During mode checking of higher order calls, if the variable being called has a
higher-order function type, but only a ground inst with no higher-order
information, assume that it has the default function modes.

Also, when doing anything that might cause a variable's inst to lose higher
order mode information, report a mode error if the variable has a non-standard
higher order function mode.  Situations where this may occur are at call sites,
exit sites and when merging insts at the end of a branched goal.

Note that because of this restriction, this change is not backwards compatible.

compiler/inst_util.m:
	Define some predicates to check for and produce pred_inst_infos for
	default function modes.
	In 'inst_merge', ensure that higher order inst information is not lost
	from non-standard function insts.

compiler/inst_match.m:
	In 'inst_matches_initial' and 'inst_matches_final', ensure that higher
	order inst information is not lost from non-standard function insts.
	Also allow 'inst_matches_{initial,final,binding}' to succeed
	where the first inst is a standard function inst and the
	second is ground.

compiler/modecheck_call.m:
	In 'modecheck_higher_order_call', if the variable to be called has no
	pred_inst_info, but the correct higher-order function type, assume it
	has the default function modes. 

tests/hard_coded/Mmakefile:
tests/hard_coded/ho_func_default_inst.m:
tests/hard_coded/ho_func_default_inst.exp:
tests/invalid/Mmakefile:
tests/invalid/ho_default_func_1.m:
tests/invalid/ho_default_func_1.err_exp:
tests/invalid/ho_default_func_2.m:
tests/invalid/ho_default_func_2.err_exp:
	Add some test cases.

Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.46
diff -u -r1.46 inst_match.m
--- compiler/inst_match.m	13 Oct 2000 13:55:28 -0000	1.46
+++ compiler/inst_match.m	3 Aug 2001 00:10:24 -0000
@@ -369,7 +369,10 @@
 	Uniq = mostly_unique,
 	bound_inst_list_is_ground(List, Info^module_info),
 	bound_inst_list_is_mostly_unique(List, Info^module_info).
-inst_matches_initial_3(ground(UniqA, _PredInst), any(UniqB), _, I, I) :-
+inst_matches_initial_3(ground(UniqA, GroundInstInfoA), any(UniqB), _,
+		Info, Info) :-
+	\+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoA,
+		Info^module_info),
 	unique_matches_initial(UniqA, UniqB).
 inst_matches_initial_3(ground(_Uniq, _PredInst), free, _, I, I).
 inst_matches_initial_3(ground(UniqA, GII_A), bound(UniqB, ListB), MaybeType,
@@ -532,7 +535,15 @@
 		uniqueness, maybe(type), inst_match_info, inst_match_info).
 :- mode ground_inst_info_matches_initial(in, in, in, in, in, out) is semidet.
 
-ground_inst_info_matches_initial(_, none, _, _) --> [].
+ground_inst_info_matches_initial(GroundInstInfoA, none, _, _) -->
+	ModuleInfo =^ module_info,
+	{ \+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoA,
+		ModuleInfo) }.
+ground_inst_info_matches_initial(none, higher_order(PredInstB), _, Type) -->
+	{ PredInstB = pred_inst_info(function, ArgModes, _Det) },
+	{ Arity = list__length(ArgModes) },
+	{ PredInstA = pred_inst_info_standard_func_mode(Arity) },
+	pred_inst_matches_initial(PredInstA, PredInstB, Type).
 ground_inst_info_matches_initial(higher_order(PredInstA),
 		higher_order(PredInstB), _, Type) -->
 	pred_inst_matches_initial(PredInstA, PredInstB, Type).
@@ -833,10 +844,15 @@
 	unique_matches_final(UniqA, UniqB),
 	bound_inst_list_is_ground(ListA, Info^module_info),
 	bound_inst_list_matches_uniq(ListA, UniqB, Info^module_info).
-inst_matches_final_3(ground(UniqA, _), any(UniqB), _, I, I) :-
-	unique_matches_final(UniqA, UniqB).
-inst_matches_final_3(ground(UniqA, _), bound(UniqB, ListB), MaybeType,
+inst_matches_final_3(ground(UniqA, GroundInstInfoA), any(UniqB), _,
 		Info, Info) :-
+	\+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoA,
+		Info^module_info),
+	unique_matches_final(UniqA, UniqB).
+inst_matches_final_3(ground(UniqA, GroundInstInfoA), bound(UniqB, ListB),
+		MaybeType, Info, Info) :-
+	\+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoA,
+		Info^module_info),
 	unique_matches_final(UniqA, UniqB),
 	bound_inst_list_is_ground(ListB, Info^module_info),
 	uniq_matches_bound_inst_list(UniqA, ListB, Info^module_info),
@@ -869,7 +885,15 @@
 		maybe(type), inst_match_info, inst_match_info).
 :- mode ground_inst_info_matches_final(in, in, in, in, out) is semidet.
 
-ground_inst_info_matches_final(_, none, _) --> [].
+ground_inst_info_matches_final(GroundInstInfoA, none, _) -->
+	ModuleInfo =^ module_info,
+	{ \+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoA,
+		ModuleInfo) }.
+ground_inst_info_matches_final(none, higher_order(PredInstB), Type) -->
+	{ PredInstB = pred_inst_info(function, ArgModes, _Det) },
+	{ Arity = list__length(ArgModes) },
+	{ PredInstA = pred_inst_info_standard_func_mode(Arity) },
+	pred_inst_matches_2(PredInstA, PredInstB, Type).
 ground_inst_info_matches_final(higher_order(PredInstA),
 		higher_order(PredInstB), MaybeType) -->
 	pred_inst_matches_2(PredInstA, PredInstB, MaybeType).
@@ -984,6 +1008,12 @@
 :- mode ground_inst_info_matches_binding(in, in, in, in) is semidet.
 
 ground_inst_info_matches_binding(_, none, _, _).
+ground_inst_info_matches_binding(none, higher_order(PredInstB), MaybeType,
+		ModuleInfo) :-
+	PredInstB = pred_inst_info(function, ArgModes, _Det),
+	Arity = list__length(ArgModes),
+	PredInstA = pred_inst_info_standard_func_mode(Arity),
+	pred_inst_matches_1(PredInstA, PredInstB, MaybeType, ModuleInfo).
 ground_inst_info_matches_binding(higher_order(PredInstA),
 		higher_order(PredInstB), MaybeType, ModuleInfo) :-
 	pred_inst_matches_1(PredInstA, PredInstB, MaybeType, ModuleInfo).
Index: compiler/inst_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inst_util.m,v
retrieving revision 1.16
diff -u -r1.16 inst_util.m
--- compiler/inst_util.m	30 Mar 2001 06:04:22 -0000	1.16
+++ compiler/inst_util.m	2 Aug 2001 15:05:03 -0000
@@ -98,6 +98,25 @@
 	%       the same in both.
 
 %-----------------------------------------------------------------------------%
+
+	% Succeed iff the first argument is a function pred_inst_info
+	% with non-standard mode.
+
+:- pred pred_inst_info_is_nonstandard_func_mode(pred_inst_info, module_info).
+:- mode pred_inst_info_is_nonstandard_func_mode(in, in) is semidet.
+
+	% Succeed iff the first argument is a function ground_inst_info
+	% with non-standard mode.
+
+:- pred ground_inst_info_is_nonstandard_func_mode(ground_inst_info,
+			module_info).
+:- mode ground_inst_info_is_nonstandard_func_mode(in, in) is semidet.
+
+
+	% Return the standard mode for a function of the given arity.
+
+:- func pred_inst_info_standard_func_mode(arity) = pred_inst_info.
+
 %-----------------------------------------------------------------------------%
 
 :- implementation.
@@ -1413,6 +1432,13 @@
 		; pred_inst_matches(PredB, PredA, ModuleInfo) ->
 			GroundInstInfo = higher_order(PredA)
 		;
+			% If either is a function inst with non-standard
+			% modes, don't allow the higher-order
+			% information to be lost.
+			\+ pred_inst_info_is_nonstandard_func_mode(PredA,
+				ModuleInfo),
+			\+ pred_inst_info_is_nonstandard_func_mode(PredB,
+				ModuleInfo),
 			GroundInstInfo = none
 		)
 	;       
@@ -1421,6 +1447,10 @@
 	->
 		GroundInstInfo = constrained_inst_var(V)
 	;
+		\+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoA,
+			ModuleInfo),
+		\+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoB,
+			ModuleInfo),
 		GroundInstInfo = none
 	),
 	merge_uniq(UniqA, UniqB, Uniq).
@@ -1566,4 +1596,22 @@
 	).
 
 %-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+pred_inst_info_is_nonstandard_func_mode(PredInstInfo, ModuleInfo) :-
+	PredInstInfo = pred_inst_info(function, ArgModes, _),
+	Arity = list__length(ArgModes),
+	\+ pred_inst_matches(pred_inst_info_standard_func_mode(Arity),
+		PredInstInfo, ModuleInfo).
+
+ground_inst_info_is_nonstandard_func_mode(GroundInstInfo, ModuleInfo) :-
+	GroundInstInfo = higher_order(PredInstInfo),
+	pred_inst_info_is_nonstandard_func_mode(PredInstInfo, ModuleInfo).
+
+pred_inst_info_standard_func_mode(Arity) =
+		pred_inst_info(function, ArgModes, det) :-
+	in_mode(InMode),
+	out_mode(OutMode),
+	ArgModes = list__duplicate(Arity - 1, InMode) ++ [OutMode].
+
 %-----------------------------------------------------------------------------%
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.38
diff -u -r1.38 modecheck_call.m
--- compiler/modecheck_call.m	17 Jan 2001 01:42:04 -0000	1.38
+++ compiler/modecheck_call.m	2 Aug 2001 15:25:10 -0000
@@ -69,7 +69,7 @@
 %-----------------------------------------------------------------------------%
 
 :- implementation.
-:- import_module hlds_data, instmap, prog_data, (inst).
+:- import_module hlds_data, instmap, prog_data, (inst), inst_util, type_util.
 :- import_module mode_info, mode_debug, modes, mode_util, mode_errors.
 :- import_module clause_to_proc, inst_match.
 :- import_module det_report, unify_proc.
@@ -87,7 +87,20 @@
 	inst_expand(ModuleInfo0, PredVarInst0, PredVarInst),
 	list__length(Args0, Arity),
 	(
-		PredVarInst = ground(_Uniq, higher_order(PredInstInfo)),
+		PredVarInst = ground(_Uniq, GroundInstInfo),
+		(
+			GroundInstInfo = higher_order(PredInstInfo)
+		;
+			% If PredVar has no higher-order inst
+			% information, but is a function type, then
+			% assume the default function mode.
+			GroundInstInfo = none,
+			mode_info_get_var_types(ModeInfo0, VarTypes),
+			map__lookup(VarTypes, PredVar, Type),
+			type_is_higher_order(Type, function, _, ArgTypes),
+			PredInstInfo = pred_inst_info_standard_func_mode(
+					list__length(ArgTypes))
+		),
 		PredInstInfo = pred_inst_info(PredOrFunc, Modes0, Det0),
 		list__length(Modes0, Arity)
 	->
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.124
diff -u -r1.124 Mmakefile
--- tests/hard_coded/Mmakefile	1 Aug 2001 00:31:39 -0000	1.124
+++ tests/hard_coded/Mmakefile	3 Aug 2001 00:18:09 -0000
@@ -62,6 +62,7 @@
 	higher_order_syntax \
 	higher_order_syntax2 \
 	higher_order_type_manip \
+	ho_func_default_inst \
 	ho_func_reg \
 	ho_order \
 	ho_order2 \
Index: tests/hard_coded/ho_func_default_inst.exp
===================================================================
RCS file: tests/hard_coded/ho_func_default_inst.exp
diff -N tests/hard_coded/ho_func_default_inst.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/ho_func_default_inst.exp	3 Aug 2001 00:18:47 -0000
@@ -0,0 +1,2 @@
+hello
+world
Index: tests/hard_coded/ho_func_default_inst.m
===================================================================
RCS file: tests/hard_coded/ho_func_default_inst.m
diff -N tests/hard_coded/ho_func_default_inst.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/ho_func_default_inst.m	3 Aug 2001 00:17:04 -0000
@@ -0,0 +1,43 @@
+% This test checks that a higher order func type with inst ground is 
+% able to be treated as a though it has the default function mode.
+
+:- module ho_func_default_inst.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module map.
+
+main -->
+	{ Map = map },
+	{ F1 = Map ^ det_elem(1) },
+	{ F2 = Map ^ det_elem(2) },
+	io__write_string(F1(1)),
+	io__nl,
+	write_func(F2).
+
+:- type t == (func(int) = string).
+
+:- func map = map(int, t).
+
+map = (map__init ^ elem(1) := hello) ^ elem(2) := world.
+
+:- pred write_func(t, io, io) is det.
+:- mode write_func(func(in) = out is det, di, uo) is det.
+
+write_func(F) -->
+	io__write_string(F(1)),
+	io__nl.
+
+:- func hello(int) = string.
+
+hello(_) = "hello".
+	
+:- func world(int) = string.
+
+world(_) = "world".
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.92
diff -u -r1.92 Mmakefile
--- tests/invalid/Mmakefile	10 Jul 2001 10:45:35 -0000	1.92
+++ tests/invalid/Mmakefile	3 Aug 2001 01:09:58 -0000
@@ -18,6 +18,7 @@
 	aditi_update_errors.m \
 	aditi_update_mode_errors.m \
 	duplicate_instance_2.m \
+	ho_default_func_2.m \
 	imported_mode.m \
 	partial_implied_mode.m \
 	test_nested.m \
@@ -45,6 +46,7 @@
 	field_syntax_error.m \
 	func_errors.m \
 	funcs_as_preds.m \
+	ho_default_func_1.m \
 	ho_type_mode_bug.m \
 	ho_unique_error.m \
 	impure_method_impl.m \
Index: tests/invalid/ho_default_func_1.err_exp
===================================================================
RCS file: tests/invalid/ho_default_func_1.err_exp
diff -N tests/invalid/ho_default_func_1.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_default_func_1.err_exp	3 Aug 2001 01:04:38 -0000
@@ -0,0 +1,6 @@
+ho_default_func_1.m:029: In clause for `baz(in, out)':
+ho_default_func_1.m:029:   in call to function `std_util:univ/1':
+ho_default_func_1.m:029:   mode error: arguments `TypeInfo_13, V_7, V_6'
+ho_default_func_1.m:029:   have insts `unique(private_builtin:type_info(unique(<type_ctor_info for :func/0>), unique(2), unique(<type_ctor_info for :int/0>), unique(<type_ctor_info for :int/0>))), /* unique */(func((free -> ground)) = (ground -> ground) is det), free',
+ho_default_func_1.m:029:   which does not match any of the modes for function `std_util:univ/1'.
+For more information, try recompiling with `-E'.
Index: tests/invalid/ho_default_func_1.m
===================================================================
RCS file: tests/invalid/ho_default_func_1.m
diff -N tests/invalid/ho_default_func_1.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_default_func_1.m	3 Aug 2001 01:00:42 -0000
@@ -0,0 +1,34 @@
+% Compiling this module should generate an error message since
+% it tries to cast a non-standard func inst to ground.
+
+:- module ho_default_func_1.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+:- import_module int, std_util.
+
+main -->
+	{ baz(foo, F) },
+	io__write_int(F(42)), nl.
+
+:- func foo(int) = int.
+foo(X) = X + 1.
+
+:- func bar(int) = int.
+:- mode bar(out) = in is det.
+bar(X) = X + 1.
+
+:- pred baz(T::in, T::out) is det.
+baz(X, Y) :-
+	( univ_to_type(univ(bar), Y0) ->
+		Y = Y0
+	;
+		Y = X
+	).
+
Index: tests/invalid/ho_default_func_2.err_exp
===================================================================
RCS file: tests/invalid/ho_default_func_2.err_exp
diff -N tests/invalid/ho_default_func_2.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_default_func_2.err_exp	3 Aug 2001 01:05:44 -0000
@@ -0,0 +1,5 @@
+ho_default_func_2.m:038: In clause for `baz(out)':
+ho_default_func_2.m:038:   in argument 1 of call to function `ho_default_func_2:id:mkid/1':
+ho_default_func_2.m:038:   mode error: variable `V_2' has instantiatedness `/* unique */(func((free -> ground)) = (ground -> ground) is det)',
+ho_default_func_2.m:038:   expected instantiatedness was `ground'.
+For more information, try recompiling with `-E'.
Index: tests/invalid/ho_default_func_2.m
===================================================================
RCS file: tests/invalid/ho_default_func_2.m
diff -N tests/invalid/ho_default_func_2.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_default_func_2.m	3 Aug 2001 01:04:58 -0000
@@ -0,0 +1,53 @@
+% Compiling this module should generate an error message since
+% it tries to cast a non-standard func inst to ground.
+
+:- module ho_default_func_2.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+:- import_module ho_default_func_2__sub.
+:- import_module ho_default_func_2__id.
+
+:- import_module int, std_util.
+
+main -->
+	{ baz(IdF), eq(getval(IdF), F) },
+	do_io(F).
+
+:- func foo(int) = int.
+foo(X) = X + 1.
+
+:- func bar(int) = int.
+:- mode bar(out) = in is det.
+bar(X) = X + 1.
+
+:- module sub.
+:- interface.
+:- type t.
+:- pred baz(id(t)::out) is det.
+:- pred eq(t::in, t::out) is det.
+:- pred do_io(t::in, io__state::di, io__state::uo) is det.
+:- implementation.
+:- type t == (func(int) = int).
+baz(mkid(bar)).
+eq(X,X).
+do_io(F) --> io__write_int(F(42)), nl.
+:- end_module sub.
+
+:- module id.
+:- interface.
+:- type id(T).
+:- func mkid(T) = id(T).
+:- func getval(id(T)) = T.
+:- implementation.
+:- type id(T) ---> id(T).
+mkid(X) = id(X).
+getval(id(X)) = X.
+:- end_module id.
+
-- 
David Overton      Department of Computer Science & Software Engineering
PhD Student        The University of Melbourne, Victoria 3010, Australia
+61 3 8344 9159    http://www.cs.mu.oz.au/~dmo
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------