[m-dev.] diff: fix bug with trail tickets and --trace shallow

[Fergus Henderson]

Estimated hours taken: 2

compiler/code_gen.m:
	Fix a bug reported by Warwick Harvey: the code that we
	generated for procedures compiled with `--trace shallow'
	was allocating ticket counters conditionally
	(iff MR_trace_from_full was true on entry),
	but was deallocating them unconditionally.
	The fix was to only deallocate them if they were allocated.

Workspace: /home/pgrad/fjh/ws/hg3
Index: compiler/code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.89
diff -u -d -r1.89 code_gen.m
--- compiler/code_gen.m	2000/11/23 04:32:28	1.89
+++ compiler/code_gen.m	2000/12/11 10:36:58
@@ -72,9 +72,10 @@
 :- import_module call_gen, unify_gen, ite_gen, switch_gen, disj_gen.
 :- import_module par_conj_gen, pragma_c_gen, commit_gen.
 :- import_module continuation_info, trace, trace_params.
-:- import_module code_aux, code_util, middle_rec, passes_aux, llds_out.
+:- import_module code_aux, code_util, middle_rec, llds_out.
 
 % Misc compiler modules
+:- import_module builtin_ops, passes_aux.
 :- import_module globals, options.
 
 % Standard library modules
@@ -575,13 +576,34 @@
 			MaybeFailExternalInfo = no,
 			TraceFailCode = empty
 		},
-		{ TraceSlotInfo ^ slot_trail = yes(_) ->
-			DiscardTraceTicketCode = node([
-				discard_ticket - "discard retry ticket"
-			])
+		( { TraceSlotInfo ^ slot_trail = yes(_) } ->
+			( { TraceSlotInfo ^ slot_from_full =
+				yes(FromFullSlot) }
+			->
+				%
+				% Generate code which discards the ticket
+				% only if it was allocated, i.e. only if
+				% MR_trace_from_full was true on entry.
+				%
+				{ FromFullSlotLval =
+					llds__stack_slot_num_to_lval(
+						model_non, FromFullSlot) },
+				code_info__get_next_label(SkipLabel),
+				{ DiscardTraceTicketCode = node([
+					if_val(unop(not,
+						lval(FromFullSlotLval)),
+						label(SkipLabel)) - "",
+					discard_ticket - "discard retry ticket",
+					label(SkipLabel) - ""
+				]) }
+			;
+				{ DiscardTraceTicketCode = node([
+					discard_ticket - "discard retry ticket"
+				]) }
+			)
 		;
-			DiscardTraceTicketCode = empty
-		},
+			{ DiscardTraceTicketCode = empty }
+		),
 		{ FailCode = node([
 			goto(do_fail) - "fail after fail trace port"
 		]) },
@@ -838,21 +860,43 @@
 				decr_sp(TotalSlots) - "Deallocate stack frame"
 			])
 		},
-		{
-			TraceSlotInfo ^ slot_trail = yes(_),
-			CodeModel \= model_non
+		(
+			{ TraceSlotInfo ^ slot_trail = yes(_) },
+			{ CodeModel \= model_non }
 		->
-			PruneTraceTicketCode = node([
-				prune_ticket - "prune retry ticket"
-			])
+			(
+				{ TraceSlotInfo ^ slot_from_full =
+					yes(FromFullSlot) }
+			->
+				%
+				% Generate code which prunes the ticket
+				% only if it was allocated, i.e. only if
+				% MR_trace_from_full was true on entry.
+				%
+				{ FromFullSlotLval =
+					llds__stack_slot_num_to_lval(
+						CodeModel, FromFullSlot) },
+				code_info__get_next_label(SkipLabel),
+				{ PruneTraceTicketCode = node([
+					if_val(unop(not,
+						lval(FromFullSlotLval)),
+						label(SkipLabel)) - "",
+					prune_ticket - "prune retry ticket",
+					label(SkipLabel) - ""
+				]) }
+			;
+				{ PruneTraceTicketCode = node([
+					prune_ticket - "prune retry ticket"
+				]) }
+			)
 		;
-			PruneTraceTicketCode = empty
-		},
+			{ PruneTraceTicketCode = empty }
+		),
 
 		{ RestoreDeallocCode =
 			tree(RestoreSuccipCode,
-			tree(DeallocCode,
-			     PruneTraceTicketCode))
+			tree(PruneTraceTicketCode,
+			     DeallocCode))
 		},
 
 		code_info__get_maybe_trace_info(MaybeTraceInfo),

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