tabling I/O for retry

[Fergus Henderson]

This is just proof-of-concept at the moment.
I won't commit it until I've fixed the XXXs below.

--------------------

Estimated hours taken: 4

A first go at implementing "retry" in mdb for procedures that do I/O
by memoizing the results of all the I/O operations.
XXX This should all be enabled by an option; it should not be the default.
XXX The option should be part of the mangled grade.

compiler/trace.m:
	Ensure that old clobbered values of the io__state are retained
	if tracing is enabled, so that we can do `retry' in IO code.

runtime/mercury_wrapper.h:
runtime/mercury_wrapper.c:
	Declare & define a new variable MR_io_counter.

compiler/export.m:
	Initialize the io__state on entry to Mercury code,
	by incrementing the MR_io_counter.

compiler/pragma_c_gen.m:
	Update the io__state at every call to C code.
	by incrementing the MR_io_counter.

compiler/table_gen.m:
	Table all pragma_c_code procedures that do I/O,
	so that doing `retry' in IO code actually works.
	Ensure that io__state values are tabled
	as if they were ints (since they are, now).
	[Hmm, would it be better to just change the
	definition of `io__state' in library/io.m?

Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.26
diff -u -r1.26 export.m
--- export.m	1998/11/20 04:07:35	1.26
+++ export.m	1999/03/01 20:45:21
@@ -94,7 +94,7 @@
 	E = pragma_exported_proc(PredId, ProcId, C_Function),
 	get_export_info(Preds, PredId, ProcId, C_RetType,
 		_DeclareReturnVal, _FailureAction, _SuccessAction,
-		HeadArgInfoTypes),
+		HeadArgInfoTypes, _ExcludedHeadArgInfoTypes),
 	get_argument_declarations(HeadArgInfoTypes, no, ArgDecls),
 	C_ExportDecl = c_export_decl(C_RetType, C_Function, ArgDecls),
 	export__get_c_export_decls_2(Preds, ExportedProcs, C_ExportDecls0),
@@ -173,12 +173,13 @@
 	E = pragma_exported_proc(PredId, ProcId, C_Function),
 	get_export_info(Preds, PredId, ProcId,
 		C_RetType, MaybeDeclareRetval, MaybeFail, MaybeSucceed,
-		ArgInfoTypes),
+		ArgInfoTypes, ExcludedArgInfoTypes),
 	get_argument_declarations(ArgInfoTypes, yes, ArgDecls),
 
 		% work out which arguments are input, and which are output,
 		% and copy to/from the mercury registers.
 	get_input_args(ArgInfoTypes, 0, InputArgs),
+	get_excluded_input_args(ExcludedArgInfoTypes, ExcludedInputArgs),
 	copy_output_args(ArgInfoTypes, 0, OutputArgs),
 	
 	code_util__make_proc_label(Module, PredId, ProcId, ProcLabel),
@@ -195,6 +196,7 @@
 				"\tsave_regs_to_mem(c_regs);\n", 
 				"\trestore_registers();\n", 
 				InputArgs,
+				ExcludedInputArgs,
 				"\tsave_transient_registers();\n",
 				"\t{\n\tDeclare_entry(",
 				ProcLabelString,
@@ -222,11 +224,12 @@
 	%	for a given procedure.
 :- pred get_export_info(pred_table, pred_id, proc_id,
 			string, string, string, string,
-			assoc_list(arg_info, type)).
-:- mode get_export_info(in, in, in, out, out, out, out, out) is det.
+			assoc_list(arg_info, type), assoc_list(arg_info, type)).
+:- mode get_export_info(in, in, in, out, out, out, out, out, out) is det.
 
 get_export_info(Preds, PredId, ProcId, C_RetType,
-		MaybeDeclareRetval, MaybeFail, MaybeSucceed, ArgInfoTypes) :-
+		MaybeDeclareRetval, MaybeFail, MaybeSucceed,
+		ArgInfoTypes, ExcludedArgInfoTypes) :-
 	map__lookup(Preds, PredId, PredInfo),
 	pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
 	pred_info_procedures(PredInfo, ProcTable),
@@ -290,7 +293,8 @@
 		MaybeSucceed = "",
 		ArgInfoTypes2 = ArgInfoTypes0
 	),
-	list__filter(export__include_arg, ArgInfoTypes2, ArgInfoTypes).
+	list__filter(export__include_arg, ArgInfoTypes2, ArgInfoTypes,
+		ExcludedArgInfoTypes).
 
 	% export__include_arg(ArgInfoType):
 	%	Succeeds iff the specified argument should be included in
@@ -379,6 +383,29 @@
 		InputArg = ""
 	),
 	get_input_args(ATs, Num, TheRest),
+	string__append(InputArg, TheRest, Result).
+
+:- pred get_excluded_input_args(assoc_list(arg_info, type), string).
+:- mode get_excluded_input_args(in, out) is det.
+
+get_excluded_input_args([], "").
+get_excluded_input_args([AT|ATs], Result) :-
+	AT = ArgInfo - _Type,
+	ArgInfo = arg_info(ArgLoc, Mode),
+	(
+		Mode = top_in,
+		argloc_to_string(ArgLoc, ArgLocString),
+		string__append_list(
+			["\t", ArgLocString, " = ++MR_io_counter;\n" ],
+			InputArg)
+	;
+		Mode = top_out,
+		InputArg = ""
+	;
+		Mode = top_unused,
+		InputArg = ""
+	),
+	get_excluded_input_args(ATs, TheRest),
 	string__append(InputArg, TheRest, Result).
 
 :- pred copy_output_args(assoc_list(arg_info, type), int, string).
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.26
diff -u -r1.26 pragma_c_gen.m
--- pragma_c_gen.m	1999/01/27 08:34:30	1.26
+++ pragma_c_gen.m	1999/03/01 20:47:01
@@ -39,6 +39,8 @@
 :- implementation.
 
 :- import_module hlds_module, hlds_pred, call_gen, llds_out, trace, tree.
+:- import_module export.
+
 :- import_module options, globals.
 :- import_module bool, string, int, assoc_list, set, map, require.
 
@@ -1002,6 +1004,10 @@
 	code_info__release_reg(Reg),
 	code_info__set_var_location(Var, Reg),
 	{
+		export__exclude_argument_type(OrigType)
+	->
+		Outputs = [pragma_c_output(Reg, OrigType, "(++MR_io_counter)")]
+	;
 		var_is_not_singleton(MaybeName, Name)
 	->
 		Outputs = [pragma_c_output(Reg, OrigType, Name) | Outputs0]
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.6
diff -u -r1.6 table_gen.m
--- table_gen.m	1998/11/24 03:57:20	1.6
+++ table_gen.m	1999/03/01 22:41:10
@@ -172,6 +172,8 @@
 :- import_module hlds_module, hlds_goal, hlds_data, (inst), inst_match.
 :- import_module globals, options, passes_aux, prog_data, mode_util, type_util.
 :- import_module code_util, quantification, modes, purity, prog_util.
+:- import_module export.
+
 :- import_module term, varset.
 :- import_module bool, list, set, map, require, std_util, int.
 :- import_module assoc_list, string, llds.
@@ -214,7 +216,23 @@
 	pred_info_procedures(PredInfo, ProcTable),
 	map__lookup(ProcTable, ProcId, ProcInfo),
 
-	proc_info_eval_method(ProcInfo, EvalMethod),
+	proc_info_eval_method(ProcInfo, EvalMethod0),
+	(
+		EvalMethod0 = eval_normal,
+		proc_info_goal(ProcInfo, Goal),
+		% XXX the following check is not robust
+		Goal = pragma_c_code(_, _, _, _, _, _, _) - _,
+		% XXX check debugging enabled
+		pred_info_arg_types(PredInfo, ArgTypes),
+		some [Type] (
+			list__member(Type, ArgTypes),
+			export__exclude_argument_type(Type)
+		)
+	->
+		EvalMethod = eval_memo
+	;
+		EvalMethod = EvalMethod0
+	),
 
 	(
 		EvalMethod \= eval_normal
@@ -707,7 +725,7 @@
 		VarTypes, VarSet0, VarSet, [Goal|RestGoals]) :-
 	map__lookup(VarTypes0, Var, VarType),
 
-	classify_type(VarType, Module, TypeCat),
+	table_gen_classify_type(VarType, Module, TypeCat),
 	gen_lookup_call_for_type(TypeCat, VarType, TableVar0, Var,
 		Module, VarTypes0, VarTypes1, VarSet0, VarSet1, TableVar1,
 		Goal),
@@ -897,7 +915,7 @@
 		VarSet0, VarSet1, OffsetVar, OffsetUnifyGoal),
 
 	map__lookup(VarTypes1, Var, VarType),
-	classify_type(VarType, Module, TypeCat),
+	table_gen_classify_type(VarType, Module, TypeCat),
 
 	gen_save_call_for_type(TypeCat, VarType, TableVar, Var, OffsetVar,
 		Module, CallGoal),
@@ -910,7 +928,7 @@
 		prog_var, module_info, hlds_goal).
 :- mode gen_save_call_for_type(in, in, in, in, in, in, out) is det.
 
-gen_save_call_for_type(TypeCat, _Type, TableVar, Var, OffsetVar, Module,
+gen_save_call_for_type(TypeCat, Type, TableVar, Var, OffsetVar, Module,
 		Goal) :-
 	(
 		not_builtin_type(TypeCat)
@@ -988,7 +1006,7 @@
 		VarSet0, VarSet1, OffsetVar, OffsetUnifyGoal),
 
 	map__lookup(VarTypes1, Var, VarType),
-	classify_type(VarType, Module, TypeCat),
+	table_gen_classify_type(VarType, Module, TypeCat),
 
 	gen_restore_call_for_type(TypeCat, VarType, TableVar, Var, OffsetVar,
 		Module, CallGoal),
@@ -1001,7 +1019,7 @@
 		prog_var, module_info, hlds_goal).
 :- mode gen_restore_call_for_type(in, in, in, in, in, in, out) is det.
 
-gen_restore_call_for_type(TypeCat, _Type, TableVar, Var, OffsetVar, Module,
+gen_restore_call_for_type(TypeCat, Type, TableVar, Var, OffsetVar, Module,
 		Goal) :-
 	(
 		not_builtin_type(TypeCat)
@@ -1247,6 +1265,15 @@
 	goal_info_get_instmap_delta(GoalInfo, IMD0),
 	create_instmap_delta(Rest, IMD1),
 	instmap_delta_apply_instmap_delta(IMD0, IMD1, IMD).
+
+:- pred table_gen_classify_type(type, module_info, builtin_type).
+table_gen_classify_type(VarType, ModuleInfo, TypeCat) :-
+	% treat io__state etc. the same as int
+	( export__exclude_argument_type(VarType) ->
+		TypeCat = int_type
+	;
+		classify_type(VarType, ModuleInfo, TypeCat)
+	).
 
 :- pred not_builtin_type(builtin_type).
 :- mode not_builtin_type(in) is semidet.
Index: compiler/trace.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/trace.m,v
retrieving revision 1.18
diff -u -r1.18 trace.m
--- trace.m	1998/12/14 16:05:10	1.18
+++ trace.m	1999/03/01 22:04:40
@@ -143,7 +143,7 @@
 :- implementation.
 
 :- import_module continuation_info, type_util, llds_out, tree, varset.
-:- import_module (inst), instmap, inst_match, mode_util, options.
+:- import_module (inst), instmap, inst_match, mode_util, options, export.
 :- import_module list, bool, int, string, map, std_util, require.
 
 	% The redo port is not included in this type; see the comment
@@ -199,10 +199,11 @@
 	proc_info_headvars(ProcInfo, HeadVars),
 	proc_info_argmodes(ProcInfo, Modes),
 	proc_info_arg_info(ProcInfo, ArgInfos),
+	proc_info_vartypes(ProcInfo, VarTypes),
 	mode_list_get_final_insts(Modes, ModuleInfo, Insts),
 	(
 		trace__build_fail_vars(HeadVars, Insts, ArgInfos,
-			ModuleInfo, FailVarsList)
+			VarTypes, ModuleInfo, FailVarsList)
 	->
 		set__list_to_set(FailVarsList, FailVars)
 	;
@@ -579,16 +580,23 @@
 %-----------------------------------------------------------------------------%
 
 :- pred trace__build_fail_vars(list(prog_var)::in, list(inst)::in,
-	list(arg_info)::in, module_info::in, list(prog_var)::out) is semidet.
+	list(arg_info)::in, map(prog_var, type)::in, module_info::in,
+	list(prog_var)::out) is semidet.
 
-trace__build_fail_vars([], [], [], _, []).
+trace__build_fail_vars([], [], [], _, _, []).
 trace__build_fail_vars([Var | Vars], [Inst | Insts], [Info | Infos],
-		ModuleInfo, FailVars) :-
-	trace__build_fail_vars(Vars, Insts, Infos, ModuleInfo, FailVars0),
+		VarTypes, ModuleInfo, FailVars) :-
+	trace__build_fail_vars(Vars, Insts, Infos, VarTypes, ModuleInfo,
+		FailVars0),
 	Info = arg_info(_Loc, ArgMode),
 	(
 		ArgMode = top_in,
-		\+ inst_is_clobbered(ModuleInfo, Inst)
+		( inst_is_clobbered(ModuleInfo, Inst) ->
+			map__lookup(VarTypes, Var, Type),
+			export__exclude_argument_type(Type)
+		;
+			true
+		)
 	->
 		FailVars = [Var | FailVars0]
 	;
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.31
diff -u -r1.31 mercury_wrapper.c
--- mercury_wrapper.c	1999/02/04 10:53:00	1.31
+++ mercury_wrapper.c	1999/03/01 21:06:13
@@ -106,6 +106,8 @@
 
 bool		MR_profiling = TRUE;
 
+Word		MR_io_counter = 1000;
+
 /*
 ** EXTERNAL DEPENDENCIES
 **
Index: runtime/mercury_wrapper.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.h,v
retrieving revision 1.17
diff -u -r1.17 mercury_wrapper.h
--- mercury_wrapper.h	1999/02/04 10:52:58	1.17
+++ mercury_wrapper.h	1999/03/01 21:05:39
@@ -140,4 +140,6 @@
 
 extern  bool MR_profiling;
 
+extern  Word MR_io_counter;
+
 #endif /* not MERCURY_WRAPPER_H */
-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "Binaries may die
WWW: <http://www.cs.mu.oz.au/~fjh>  |   but source code lives forever"
PGP: finger fjh at 128.250.37.3        |     -- leaked Microsoft memo.