[m-rev.] for review: heap reclamation on failure for MLDS back-end

[Fergus Henderson]

Estimated hours taken: 3
Branches: main

Implement heap reclamation on failure for the MLDS back-end.

library/private_builtin.m:
	Add impure procedures for saving and restoring the heap pointer.

compiler/add_heap_ops.m:
	New file, similar to add_trail_ops.m.
	An HLDS->HLDS transformation to add heap reclamation operations.

compiler/mercury_compile.m:
	Call the new pass.

compiler/notes/compiler_design.html:
	Mention the new pass.

Workspace: /home/earth/fjh/ws-earth3/mercury
Index: compiler/add_heap_ops.m
===================================================================
RCS file: compiler/add_heap_ops.m
diff -N compiler/add_heap_ops.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/add_heap_ops.m	22 Nov 2001 15:10:08 -0000
@@ -0,0 +1,355 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2000-2001 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% Author: fjh.
+%
+% This module is an HLDS-to-HLDS transformation that inserts code to
+% handle heap reclamation on backtracking, by saving and restoring
+% the values of the heap pointer.
+% The transformation involves adding calls to impure
+% predicates defined in library/private_builtin.m, which in turn call
+% the MR_mark_hp() and MR_restore_hp() macros defined in
+% runtime/mercury_heap.h.
+%
+% This pass is currently only used for the MLDS back-end.
+% For some reason (perhaps efficiency?? or more likely just historical?),
+% the LLDS back-end inserts the heap operations as it is generating
+% LLDS code, rather than via an HLDS to HLDS transformation.
+%
+% This module is very similar to add_trail_ops.m.
+%
+%-----------------------------------------------------------------------------%
+
+% XXX check goal_infos for correctness
+
+%-----------------------------------------------------------------------------%
+
+:- module add_heap_ops.
+:- interface.
+:- import_module hlds_pred, hlds_module.
+
+:- pred add_heap_ops(proc_info::in, module_info::in, proc_info::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module prog_data, prog_util, (inst).
+:- import_module hlds_goal, hlds_data, quantification, modules, type_util.
+:- import_module instmap.
+
+:- import_module bool, string.
+:- import_module assoc_list, list, map, set, varset, std_util, require, term.
+
+
+%
+% As we traverse the goal, we add new variables to hold the
+% saved values of the heap pointer.
+% So we need to thread a varset and a vartypes mapping through,
+% to record the names and types of the new variables.
+%
+% We also keep the module_info around, so that we can use
+% the predicate table that it contains to lookup the pred_ids
+% for the builtin procedures that we insert calls to.
+% We do not update the module_info as we're traversing the goal.
+%
+
+:- type heap_ops_info --->
+	heap_ops_info(
+		varset :: prog_varset,
+		var_types :: vartypes,
+		module_info :: module_info
+	).
+
+add_heap_ops(Proc0, ModuleInfo0, Proc) :-
+	proc_info_goal(Proc0, Goal0),
+	proc_info_varset(Proc0, VarSet0),
+	proc_info_vartypes(Proc0, VarTypes0),
+	TrailOpsInfo0 = heap_ops_info(VarSet0, VarTypes0, ModuleInfo0),
+	goal_add_heap_ops(Goal0, Goal, TrailOpsInfo0, TrailOpsInfo),
+	TrailOpsInfo = heap_ops_info(VarSet, VarTypes, _),
+	proc_info_set_goal(Proc0, Goal, Proc1),
+	proc_info_set_varset(Proc1, VarSet, Proc2),
+	proc_info_set_vartypes(Proc2, VarTypes, Proc3),
+	% The code below does not maintain the non-local variables,
+	% so we need to requantify.
+	% XXX it would be more efficient to maintain them
+	%     rather than recomputing them every time.
+	requantify_proc(Proc3, Proc).
+
+:- pred goal_add_heap_ops(hlds_goal::in, hlds_goal::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+
+goal_add_heap_ops(GoalExpr0 - GoalInfo, Goal) -->
+	goal_expr_add_heap_ops(GoalExpr0, GoalInfo, Goal).
+
+:- pred goal_expr_add_heap_ops(hlds_goal_expr::in, hlds_goal_info::in,
+		hlds_goal::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+
+goal_expr_add_heap_ops(conj(Goals0), GI, conj(Goals) - GI) -->
+	conj_add_heap_ops(Goals0, Goals).
+
+goal_expr_add_heap_ops(par_conj(Goals0, SM), GI, par_conj(Goals, SM) - GI) -->
+	conj_add_heap_ops(Goals0, Goals).
+
+goal_expr_add_heap_ops(disj([], B), GI, disj([], B) - GI) --> [].
+
+goal_expr_add_heap_ops(disj(Goals0, B), GoalInfo, Goal - GoalInfo) -->
+	{ Goals0 = [_|_] },
+
+	{ goal_info_get_context(GoalInfo, Context) },
+
+	%
+	% Save the heap pointer so that we can
+	% restore it on back-tracking.
+	%
+	new_saved_hp_var(SavedHeapPointerVar),
+	gen_mark_hp(SavedHeapPointerVar, Context, MarkHeapPointerGoal),
+	disj_add_heap_ops(Goals0, yes, SavedHeapPointerVar, Goals),
+	{ Goal = conj([MarkHeapPointerGoal, disj(Goals, B) - GoalInfo]) }.
+
+goal_expr_add_heap_ops(switch(A, B, Cases0, D), GI,
+		switch(A, B, Cases, D) - GI) -->
+	cases_add_heap_ops(Cases0, Cases).
+
+goal_expr_add_heap_ops(not(InnerGoal), OuterGoalInfo, Goal) -->
+	%
+	% We handle negations by converting them into if-then-elses:
+	%	not(G)  ===>  (if G then fail else true)
+	%
+	{ goal_info_get_context(OuterGoalInfo, Context) },
+	{ InnerGoal = _ - InnerGoalInfo },
+	{ goal_info_get_determinism(InnerGoalInfo, Determinism) },
+	{ determinism_components(Determinism, _CanFail, NumSolns) },
+	{ true_goal(Context, True) },
+	{ fail_goal(Context, Fail) },
+	{ map__init(SM) },
+	{ NumSolns = at_most_zero ->
+		% The "then" part of the if-then-else will be unreachable,
+		% but to preserve the invariants that the MLDS back-end
+		% relies on, we need to make sure that it can't fail.
+		% So we use `true' rather than `fail' for the "then" part.
+		NewOuterGoal = if_then_else([], InnerGoal, True, True, SM)
+	;
+		NewOuterGoal = if_then_else([], InnerGoal, Fail, True, SM)
+	},
+	goal_expr_add_heap_ops(NewOuterGoal, OuterGoalInfo, Goal).
+
+goal_expr_add_heap_ops(some(A, B, Goal0), GoalInfo,
+		some(A, B, Goal) - GoalInfo) -->
+	goal_add_heap_ops(Goal0, Goal).
+
+goal_expr_add_heap_ops(if_then_else(A, Cond0, Then0, Else0, E), GoalInfo,
+		Goal - GoalInfo) -->
+	goal_add_heap_ops(Cond0, Cond),
+	goal_add_heap_ops(Then0, Then),
+	goal_add_heap_ops(Else0, Else1),
+	%
+	% Save the heap pointer so that we can
+	% restore it if the condition fails.
+	%
+	new_saved_hp_var(SavedHeapPointerVar),
+	{ goal_info_get_context(GoalInfo, Context) },
+	gen_mark_hp(SavedHeapPointerVar, Context, MarkHeapPointerGoal),
+	%
+	% Generate code to restore the heap pointer,
+	% and insert that code at the start of the Else branch.
+	%
+	gen_restore_hp(SavedHeapPointerVar, Context, RestoreHeapPointerGoal),
+	{ Else1 = _ - Else1GoalInfo },
+	{ Else = conj([RestoreHeapPointerGoal, Else1]) - Else1GoalInfo },
+	{ IfThenElse = if_then_else(A, Cond, Then, Else, E) - GoalInfo },
+	{ Goal = conj([MarkHeapPointerGoal, IfThenElse]) }.
+
+
+goal_expr_add_heap_ops(call(A,B,C,D,E,F), GI, call(A,B,C,D,E,F) - GI) --> [].
+
+goal_expr_add_heap_ops(generic_call(A,B,C,D), GI, generic_call(A,B,C,D) - GI)
+	--> [].
+
+goal_expr_add_heap_ops(unify(A,B,C,D,E), GI, unify(A,B,C,D,E) - GI) --> [].
+
+goal_expr_add_heap_ops(PragmaForeign, GoalInfo, Goal) -->
+	{ PragmaForeign = foreign_proc(_,_,_,_,_,_,Impl) },
+	( { Impl = nondet(_,_,_,_,_,_,_,_,_) } ->
+		% XXX Implementing heap reclamation for nondet pragma
+		% foreign_code via transformation is difficult,
+		% because there's nowhere in the HLDS pragma_foreign_code
+		% goal where we can insert the heap reclamation operations.
+		% For now, we don't support this.
+		% Instead, we just generate a call to a procedure which
+		% will at runtime call error/1 with an appropriate
+		% "Sorry, not implemented" error message.
+		ModuleInfo =^ module_info,
+		{ goal_info_get_context(GoalInfo, Context) },
+		{ generate_call("reclaim_heap_nondet_pragma_foreign_code",
+			[], det, no, [], ModuleInfo, Context,
+			SorryNotImplementedCode) },
+		{ Goal = SorryNotImplementedCode }
+	;
+		{ Goal = PragmaForeign - GoalInfo }
+	).
+
+goal_expr_add_heap_ops(shorthand(_), _, _) -->
+	% these should have been expanded out by now
+	{ error("goal_expr_add_heap_ops: unexpected shorthand") }.
+
+:- pred conj_add_heap_ops(hlds_goals::in, hlds_goals::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+conj_add_heap_ops(Goals0, Goals) -->
+	list__map_foldl(goal_add_heap_ops, Goals0, Goals).
+	
+:- pred disj_add_heap_ops(hlds_goals::in, bool::in, prog_var::in,
+		hlds_goals::out, heap_ops_info::in, heap_ops_info::out) is det.
+
+disj_add_heap_ops([], _, _, []) --> [].
+disj_add_heap_ops([Goal0 | Goals0], IsFirstBranch, 
+		SavedHeapPointerVar, [Goal | Goals]) -->
+	{ Goal0 = _ - GoalInfo0 },
+	{ goal_info_get_context(GoalInfo0, Context) },
+	%
+	% First reset the heap pointer to
+	% undo the effects of any earlier branches
+	%
+	( { IsFirstBranch = yes } ->
+		{ UndoList = [] }
+	;
+		gen_restore_hp(SavedHeapPointerVar, Context,
+			RestoreHeapPointerGoal),
+		{ UndoList = [RestoreHeapPointerGoal] }
+	),
+	%
+	% Then execute the disjunct goal
+	%
+	goal_add_heap_ops(Goal0, Goal1),
+	%
+	% Package up the stuff we built earlier.
+	%
+	{ Goal1 = _ - GoalInfo1 },
+	{ conj_list_to_goal(UndoList ++ [Goal1], GoalInfo1, Goal) },
+
+	% Recursively handle the remaining disjuncts
+	disj_add_heap_ops(Goals0, no, SavedHeapPointerVar, Goals).
+
+:- pred cases_add_heap_ops(list(case)::in, list(case)::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+cases_add_heap_ops([], []) --> [].
+cases_add_heap_ops([Case0 | Cases0], [Case | Cases]) -->
+	{ Case0 = case(ConsId, Goal0) },
+	{ Case = case(ConsId, Goal) },
+	goal_add_heap_ops(Goal0, Goal),
+	cases_add_heap_ops(Cases0, Cases).
+
+%-----------------------------------------------------------------------------%
+
+:- pred gen_mark_hp(prog_var::in, prog_context::in, hlds_goal::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+
+gen_mark_hp(SavedHeapPointerVar, Context, MarkHeapPointerGoal) -->
+	ModuleInfo =^ module_info,
+	{ generate_call("mark_hp", [SavedHeapPointerVar],
+		det, yes(impure),
+		[SavedHeapPointerVar - ground_inst],
+		ModuleInfo, Context, MarkHeapPointerGoal) }.
+
+:- pred gen_restore_hp(prog_var::in, prog_context::in, hlds_goal::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+
+gen_restore_hp(SavedHeapPointerVar, Context, RestoreHeapPointerGoal) -->
+	ModuleInfo =^ module_info,
+	{ generate_call("restore_hp", [SavedHeapPointerVar],
+		det, yes(impure), [],
+		ModuleInfo, Context, RestoreHeapPointerGoal) }.
+
+:- func ground_inst = (inst).
+ground_inst = ground(unique, none).
+
+%-----------------------------------------------------------------------------%
+
+:- pred new_saved_hp_var(prog_var::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+
+new_saved_hp_var(Var) -->
+	new_var("HeapPointer", heap_pointer_type, Var).
+	
+:- pred new_var(string::in, (type)::in, prog_var::out,
+		heap_ops_info::in, heap_ops_info::out) is det.
+
+new_var(Name, Type, Var, TOI0, TOI) :-
+	VarSet0 = TOI0 ^ varset,
+	VarTypes0 = TOI0 ^ var_types,
+	varset__new_named_var(VarSet0, Name, Var, VarSet),
+	map__det_insert(VarTypes0, Var, Type, VarTypes),
+	TOI = ((TOI0 ^ varset := VarSet)
+		     ^ var_types := VarTypes).
+
+%-----------------------------------------------------------------------------%
+
+:- func heap_pointer_type = (type).
+heap_pointer_type = c_pointer_type.
+
+%-----------------------------------------------------------------------------%
+
+% XXX copied from table_gen.m
+
+:- pred generate_call(string::in, list(prog_var)::in, determinism::in,
+	maybe(goal_feature)::in, assoc_list(prog_var, inst)::in,
+	module_info::in, term__context::in, hlds_goal::out) is det.
+
+generate_call(PredName, Args, Detism, MaybeFeature, InstMap, Module, Context,
+		CallGoal) :-
+	list__length(Args, Arity),
+	mercury_private_builtin_module(BuiltinModule),
+	module_info_get_predicate_table(Module, PredTable),
+	(
+		predicate_table_search_pred_m_n_a(PredTable,
+			BuiltinModule, PredName, Arity,
+			[PredId0])
+	->
+		PredId = PredId0
+	;
+		string__int_to_string(Arity, ArityS),
+		string__append_list(["can't locate ", PredName,
+			"/", ArityS], ErrorMessage),
+		error(ErrorMessage)
+	),
+	module_info_pred_info(Module, PredId, PredInfo),
+	(
+		pred_info_procids(PredInfo, [ProcId0])
+	->
+		ProcId = ProcId0
+	;
+		string__int_to_string(Arity, ArityS),
+		string__append_list(["too many modes for pred ",
+			PredName, "/", ArityS], ErrorMessage),
+		error(ErrorMessage)
+
+	),
+	Call = call(PredId, ProcId, Args, not_builtin, no,
+		qualified(BuiltinModule, PredName)),
+	set__init(NonLocals0),
+	set__insert_list(NonLocals0, Args, NonLocals),
+	determinism_components(Detism, _CanFail, NumSolns),
+	(
+		NumSolns = at_most_zero
+	->
+		instmap_delta_init_unreachable(InstMapDelta)
+	;
+		instmap_delta_from_assoc_list(InstMap, InstMapDelta)
+	),
+	goal_info_init(NonLocals, InstMapDelta, Detism, CallGoalInfo0),
+	goal_info_set_context(CallGoalInfo0, Context, CallGoalInfo1),
+	(
+		MaybeFeature = yes(Feature),
+		goal_info_add_feature(CallGoalInfo1, Feature, CallGoalInfo)
+	;
+		MaybeFeature = no,
+		CallGoalInfo = CallGoalInfo1
+	),
+	CallGoal = Call - CallGoalInfo.
+
+%-----------------------------------------------------------------------------%
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.224
diff -u -d -r1.224 mercury_compile.m
--- compiler/mercury_compile.m	9 Nov 2001 18:20:48 -0000	1.224
+++ compiler/mercury_compile.m	22 Nov 2001 14:09:31 -0000
@@ -57,7 +57,7 @@
 :- import_module bytecode_gen, bytecode.
 
 	% the MLDS back-end
-:- import_module add_trail_ops.			% HLDS -> HLDS
+:- import_module add_trail_ops, add_heap_ops.	% HLDS -> HLDS
 :- import_module mark_static_terms.		% HLDS -> HLDS
 :- import_module mlds.				% MLDS data structure
 :- import_module ml_code_gen, rtti_to_mlds.	% HLDS/RTTI -> MLDS
@@ -2330,6 +2330,40 @@
 		{ HLDS = HLDS0 }
 	).
 
+:- pred mercury_compile__maybe_add_heap_ops(module_info, bool, bool,
+		module_info, io__state, io__state).
+:- mode mercury_compile__maybe_add_heap_ops(in, in, in, out, di, uo)
+		is det.
+
+mercury_compile__maybe_add_heap_ops(HLDS0, Verbose, Stats, HLDS) -->
+	globals__io_get_gc_method(GC),
+	globals__io_lookup_bool_option(reclaim_heap_on_semidet_failure,
+		SemidetReclaim),
+	globals__io_lookup_bool_option(reclaim_heap_on_nondet_failure,
+		NondetReclaim),
+	( { GC = conservative } ->
+		% we can't do heap reclamation with conservative GC
+		{ HLDS = HLDS0 }
+	; { SemidetReclaim = no, NondetReclaim = no } ->
+		{ HLDS = HLDS0 }
+	; { SemidetReclaim = yes, NondetReclaim = yes } ->
+		maybe_write_string(Verbose,
+			"% Adding heap reclamation operations...\n"),
+		maybe_flush_output(Verbose),
+		process_all_nonimported_procs(update_proc(add_heap_ops),
+			HLDS0, HLDS),
+		maybe_write_string(Verbose, "% done.\n"),
+		maybe_report_stats(Stats)
+	;
+		io__write_strings([
+			"Sorry, not implemented: `--high-level-code' and\n",
+			"`--(no-)reclaim-heap-on-{semidet/nondet}-failure'.\n",
+			"Use `--(no-)reclaim-heap-on-failure' instead.\n"
+		]),
+		io__set_exit_status(1),
+		{ HLDS = HLDS0 }
+	).
+
 %-----------------------------------------------------------------------------%
 
 :- pred mercury_compile__maybe_write_dependency_graph(module_info, bool, bool,
@@ -3190,7 +3224,11 @@
 		HLDS55),
 	mercury_compile__maybe_dump_hlds(HLDS55, "55", "add_trail_ops"),
 
-	mercury_compile__maybe_mark_static_terms(HLDS55, Verbose, Stats,
+	mercury_compile__maybe_add_heap_ops(HLDS55, Verbose, Stats,
+		HLDS57),
+	mercury_compile__maybe_dump_hlds(HLDS57, "57", "add_heap_ops"),
+
+	mercury_compile__maybe_mark_static_terms(HLDS57, Verbose, Stats,
 		HLDS60),
 	mercury_compile__maybe_dump_hlds(HLDS60, "60", "mark_static"),
 
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.66
diff -u -d -r1.66 compiler_design.html
--- compiler/notes/compiler_design.html	11 Aug 2001 14:09:51 -0000	1.66
+++ compiler/notes/compiler_design.html	22 Nov 2001 13:17:30 -0000
@@ -897,6 +897,8 @@
      resumes after backtracking, and whenever we do a commit.
      The trail operations are represented as (and implemented as)
      calls to impure procedures defined in library/private_builtin.m. 
+<li> add_heap_ops.m is very similar to add_trail_ops.m;
+     it inserts code to do heap reclamation on backtracking.
 </ul>
 
 <h4> 4b. MLDS code generation </h4>
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.82
diff -u -d -r1.82 private_builtin.m
--- library/private_builtin.m	24 Oct 2001 07:43:17 -0000	1.82
+++ library/private_builtin.m	22 Nov 2001 13:43:13 -0000
@@ -1006,7 +1006,77 @@
 		"Sorry, not implemented:\n",
 		"for the MLDS back-end (`--high-level-code')\n",
 		"nondet `pragma c_code' or `pragma foreign_code'\n",
-		"is not supported when trailing (`--use_trail') is enabled."
+		"is not supported when trailing (`--use-trail') is enabled."
+	]),
+	error(Msg).
+
+%-----------------------------------------------------------------------------%
+
+	% This section of the module contains predicates that are used
+	% by the MLDS back-end, to implement heap reclamation on failure.
+	% (The LLDS back-end does not use these; instead it inserts
+	% the corresponding LLDS instructions directly during code
+	% generation.)
+	% These predicates should not be used by user programs directly.
+
+:- interface.
+
+:- type heap_pointer == c_pointer.
+
+	% For documentation, see the corresponding LLDS instructions
+	% in compiler/llds.m.  See also compiler/notes/trailing.html.
+
+:- impure pred mark_hp(heap_pointer::out) is det.
+:- impure pred restore_hp(heap_pointer::in) is det.
+
+	% XXX currently we don't support nondet pragma
+	% foreign_code when trailing is enabled.
+	% Instead we generate code which calls this procedure,
+	% which will call error/1 with an appropriate message.
+:- pred reclaim_heap_nondet_pragma_foreign_code is erroneous.
+
+	% N.B. interface continued below.
+
+:- implementation.
+
+:- pragma foreign_proc("C", mark_hp(SavedHeapPointer::out),
+	[will_not_call_mercury, thread_safe],
+"
+#ifndef MR_CONSERVATIVE_GC
+	MR_mark_hp(SavedHeapPointer);
+#else
+	/* We can't do heap reclamation with conservative GC. */
+	SavedHeapPointer = 0;
+#endif
+").
+
+:- pragma foreign_proc("C", restore_hp(SavedHeapPointer::in),
+	[will_not_call_mercury, thread_safe],
+"
+#ifndef MR_CONSERVATIVE_GC
+	MR_restore_hp(SavedHeapPointer);
+#endif
+").
+
+:- pragma foreign_proc("MC++", mark_hp(SavedHeapPointer::out),
+	[will_not_call_mercury, thread_safe],
+"
+	/* We can't do heap reclamation on failure in the .NET back-end. */
+	SavedHeapPointer = 0;
+").
+
+:- pragma foreign_proc("MC++", restore_hp(SavedHeapPointer::in),
+	[will_not_call_mercury, thread_safe],
+"
+	/* We can't do heap reclamation on failure in the .NET back-end. */
+").
+
+reclaim_heap_nondet_pragma_foreign_code :-
+	Msg = string__append_list([
+		"Sorry, not implemented:\n",
+		"for the MLDS back-end (`--high-level-code')\n",
+		"nondet `pragma c_code' or `pragma foreign_code'\n",
+		"is not supported when `--reclaim-heap-on-failure' is enabled."
 	]),
 	error(Msg).
 
 

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
The University of Melbourne         |  of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh>  |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------