[m-dev.] For review: Add implementation of reference types (global heap)

[Warwick Harvey]

Here's the updated diffs, as requested...


Estimated hours taken: 60 (plus whatever pets spent when he wrote the
original version of this)

This change adds a new extras directory, "references".  This directory
contains two impure reference type modules and a module that allows scoped
non-backtrackable update, along with examples of using them and tests.
These modules are intended to be useful when HAL is retargetted to Mercury,
for implementing global variables (backtracking and non-backtracking), and
may also be useful for the debugger.

In order to implement these features, a new memory zone "global heap" was
added to the runtime system, for a heap which is not reclaimed on failure,
along with a pair of functions for copying terms to this heap.

runtime/mercury_deep_copy.c:
runtime/mercury_deep_copy.h:
	Added two functions, MR_make_permanent() and
	MR_make_partially_permanent(), which essentially do a deep copy of a
	term to the global heap.
	(In conservative GC grades, these functions actually do nothing).

runtime/mercury_memory.c:
runtime/mercury_memory.h:
	Added declarations and initialisation of the global_heap_zone, as
	well as its corresponding heap pointer global_hp.

runtime/mercury_wrapper.c:
runtime/mercury_wrapper.h:
	Added declarations and initialisation of the size and zone_size of
	the global_heap.

New files:

extras/references/Mmakefile:
	Mmakefile for building and testing these modules.

extras/references/README:
	Description of contents of this directory.

extras/references/global.m:
	A wrapper module for building a library containing the nb_reference,
	reference and scoped_update modules.

extras/references/nb_reference.m:
	Implements references which are not backtracked on failure.

extras/references/reference.m:
	Implements references which *are* backtracked on failure.

extras/references/scoped_update.m:
	Allows nested scoping of non-backtracking references.

extras/references/samples/Mmakefile:
extras/references/samples/max_of.m:
extras/references/samples/max_test.exp:
extras/references/samples/max_test.m:
	An example of using a non-backtracking reference (to find the
	maximum of the solutions generated by a predicate), with tests.

extras/references/tests/Mmakefile:
extras/references/tests/ref_test.exp:
extras/references/tests/ref_test.m:
	Some tests of references (backtracking and non-backtracking) and
	scoping.


Index: runtime/mercury_deep_copy.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy.c,v
retrieving revision 1.7
diff -u -r1.7 mercury_deep_copy.c
--- mercury_deep_copy.c	1998/06/02 05:34:24	1.7
+++ mercury_deep_copy.c	1998/06/09 06:48:37
@@ -11,6 +11,7 @@
 #include "mercury_imp.h"
 #include "mercury_deep_copy.h"
 #include "mercury_type_info.h"
+#include "mercury_memory.h"
 
 #define in_range(X)	((X) >= lower_limit && (X) <= upper_limit)
 
@@ -345,3 +346,56 @@
 		return type_info;
 	}
 }
+
+
+
+Word
+MR_make_permanent(Word term, Word *type_info)
+{
+	return MR_make_long_lived(term, type_info, NULL);
+}
+
+#define swap(val1, val2, type) \
+	do { \
+		type swap_tmp; \
+		swap_tmp = (val1); \
+		(val1) = (val2); \
+		(val2) = swap_tmp; \
+	} while (0)
+
+Word
+MR_make_long_lived(Word term, Word *type_info, Word *lower_limit)
+{
+#ifdef CONSERVATIVE_GC
+	return term;
+#else	/* not CONSERVATIVE_GC */
+	Word result;
+	MemoryZone *tmp_heap_zone;
+	Word *tmp_hp;
+
+	restore_transient_registers();	/* Because we play with MR_hp */
+
+	if (lower_limit < heap_zone->bottom || lower_limit > heap_zone->top) {
+		lower_limit = heap_zone->bottom;
+	}
+
+	/* temporarily swap the heap with the global heap */
+	swap(heap_zone, global_heap_zone, MemoryZone *);
+	swap(MR_hp, global_hp, Word *);
+
+	/* copy values from the heap to the global heap */
+	save_transient_registers();
+	result = deep_copy(term, type_info, lower_limit,
+			global_heap_zone->top);
+	restore_transient_registers();
+
+	/* swap the heap and global heap back again */
+	swap(heap_zone, global_heap_zone, MemoryZone *);
+	swap(MR_hp, global_hp, Word *);
+
+	save_transient_registers();	/* Because we played with MR_hp */
+
+	return result;
+#endif	/* not CONSERVATIVE_GC */
+}
+
Index: runtime/mercury_deep_copy.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy.h,v
retrieving revision 1.3
diff -u -r1.3 mercury_deep_copy.h
--- mercury_deep_copy.h	1998/05/15 07:09:14	1.3
+++ mercury_deep_copy.h	1998/06/09 06:48:37
@@ -63,4 +63,32 @@
 Word deep_copy(Word data, Word *type_info, Word *lower_limit, 
 	Word *upper_limit);
 
+/* MR_make_permanent:
+**
+**	Returns a copy of term that can be accessed safely even after
+**	Mercury execution has backtracked past the point at which the
+**	term was allocated.
+**
+**	As with deep_copy(), save_transient_registers() and
+**	restore_transient_registers() need to be used around this function.
+*/
+
+Word MR_make_permanent(Word term, Word *type_info);
+
+/* MR_make_long_lived:
+**
+**	This is the same as MR_make_permanent, except that if limit is an
+**	address on the heap, parts of term that are "older" than limit will
+**	not be copied.  This is useful when you know that the permanent copy
+**	of term will not be accessed after the heap pointer has backtracked
+**	beyond limit.  Naturally, this always occurs when the permanent term
+**	is to be stored in *limit.
+**
+**	I'd like to describe the limit argument without referring to the
+**	"heap," but don't see how to.
+*/
+
+Word MR_make_long_lived(Word term, Word *type_info,
+	Word *lower_limit);
+
 #endif /* not MERCURY_DEEP_COPY_H */
Index: runtime/mercury_memory.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_memory.c,v
retrieving revision 1.8
diff -u -r1.8 mercury_memory.c
--- mercury_memory.c	1998/05/14 06:35:07	1.8
+++ mercury_memory.c	1998/06/09 06:48:37
@@ -110,6 +110,8 @@
 #ifndef CONSERVATIVE_GC
   MemoryZone *heap_zone;
   MemoryZone *solutions_heap_zone;
+  MemoryZone *global_heap_zone;
+  Word *global_hp;
 #endif
 #ifdef	MR_LOWLEVEL_DEBUG
   MemoryZone *dumpstack_zone;
@@ -135,12 +137,16 @@
 	heap_size	    = 0;
 	solutions_heap_zone_size = 0;
 	solutions_heap_size = 0;
+	global_heap_zone_size = 0;
+	global_heap_size    = 0;
 #else
 	heap_zone_size      = round_up(heap_zone_size * 1024, unit);
 	heap_size           = round_up(heap_size * 1024, unit);
 	solutions_heap_zone_size = round_up(solutions_heap_zone_size * 1024, 
 		unit);
 	solutions_heap_size = round_up(solutions_heap_size * 1024, unit);
+	global_heap_zone_size = round_up(global_heap_zone_size * 1024, unit);
+	global_heap_size    = round_up(global_heap_size * 1024, unit);
 #endif
 
 	detstack_size       = round_up(detstack_size * 1024, unit);
@@ -168,6 +174,9 @@
 	if (solutions_heap_zone_size >= solutions_heap_size) {
 		solutions_heap_zone_size = unit;
 	}
+	if (global_heap_zone_size >= global_heap_size) {
+		global_heap_zone_size = unit;
+	}
 #endif
 
 	if (detstack_zone_size >= detstack_size) {
@@ -207,6 +216,10 @@
 	restore_transient_registers();
 	MR_sol_hp = solutions_heap_zone->min;
 	save_transient_registers();
+
+	global_heap_zone = create_zone("global_heap", 1, global_heap_size,
+		next_offset(), global_heap_zone_size, default_handler);
+	global_hp = global_heap_zone->min;
 
 #endif
 
Index: runtime/mercury_memory.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_memory.h,v
retrieving revision 1.5
diff -u -r1.5 mercury_memory.h
--- mercury_memory.h	1998/05/08 02:53:32	1.5
+++ mercury_memory.h	1998/06/09 06:48:37
@@ -25,6 +25,8 @@
 #ifndef CONSERVATIVE_GC
 extern MemoryZone	*heap_zone;
 extern MemoryZone	*solutions_heap_zone;
+extern MemoryZone	*global_heap_zone;
+extern Word		*global_hp;
 #endif
 
 #ifdef	MR_LOWLEVEL_DEBUG
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.11
diff -u -r1.11 mercury_wrapper.c
--- mercury_wrapper.c	1998/05/16 07:28:38	1.11
+++ mercury_wrapper.c	1998/06/09 06:48:38
@@ -49,6 +49,7 @@
 size_t		detstack_size =  	2048;
 size_t		nondstack_size =  	128;
 size_t		solutions_heap_size =	1024;
+size_t		global_heap_size =	1024;
 size_t		trail_size =		128;
 
 /* size of the redzones at the end of data areas, in kilobytes */
@@ -57,6 +58,7 @@
 size_t		detstack_zone_size =	16;
 size_t		nondstack_zone_size =	16;
 size_t		solutions_heap_zone_size = 16;
+size_t		global_heap_zone_size =	16;
 size_t		trail_zone_size =	16;
 
 /* primary cache size to optimize for, in kilobytes */
Index: runtime/mercury_wrapper.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.h,v
retrieving revision 1.7
diff -u -r1.7 mercury_wrapper.h
--- mercury_wrapper.h	1998/04/08 11:34:17	1.7
+++ mercury_wrapper.h	1998/06/09 06:48:38
@@ -80,6 +80,7 @@
 extern	size_t		nondstack_size;
 extern	size_t		solutions_heap_size;
 extern	size_t		trail_size;
+extern	size_t		global_heap_size;
 
 /* sizes of the red zones */
 extern	size_t		heap_zone_size;
@@ -87,6 +88,7 @@
 extern	size_t		nondstack_zone_size;
 extern	size_t		solutions_heap_zone_size;
 extern	size_t		trail_zone_size;
+extern	size_t		global_heap_zone_size;
 
 /* size of the primary cache */
 extern	size_t		pcache_size;

::::::::::::::
extras/references/Mmakefile
::::::::::::::
#----------------------------------------------------------------------------
-#
# Copyright (C) 1997-1998 The University of Melbourne.
# This file may only be copied under the terms of the GNU Library General
# Public License - see the file COPYING.LIB in the Mercury distribution.
#----------------------------------------------------------------------------
-#

GRADEFLAGS += --use-trail

depend: global.depend
	cd samples && mmake $(MMAKEFLAGS) GRADEFLAGS="$(GRADEFLAGS)" depend
	cd tests && mmake $(MMAKEFLAGS) GRADEFLAGS="$(GRADEFLAGS)" depend

check: libglobal
	cd samples && mmake $(MMAKEFLAGS) GRADEFLAGS="$(GRADEFLAGS)" check
	cd tests && mmake $(MMAKEFLAGS) GRADEFLAGS="$(GRADEFLAGS)" check

clean: clean_subdirs

.PHONY: clean_subdirs
clean_subdirs:
	cd samples && mmake $(MMAKEFLAGS) clean
	cd tests && mmake $(MMAKEFLAGS) clean

realclean: realclean_subdirs

.PHONY: realclean_subdirs
realclean_subdirs:
	cd samples && mmake $(MMAKEFLAGS) realclean
	cd tests && mmake $(MMAKEFLAGS) realclean

# We need this to use shared libraries on Linux
#ML = ml --mercury-libs shared

::::::::::::::
extras/references/README
::::::::::::::
This directory contains two impure reference type modules, and a
module that allows scoped non-backtrackable update, plus two
example modules using these types.  These serve as an example of
impure coding.  Generally this sort of coding is not necessary, and it
can be quite tedious and error-prone, but occasionally it may permit
greater efficiency than using pure Mercury code, or may permit you to
write in Mercury what you would otherwise have to write in C.  See
section 12.2 of the Mercury Language References Manual for more
information on impurity.

This directory contains

	reference.m		a backtrackable reference types
	nb_reference.m		a non-backtrackable reference types

	scoped_update.m		scoping for non-backtrackable updates

	global.m		a wrapper module used for building a
				library containing the above modules

The samples directory contains

	max_of.m		an example of non-backtrackable references
	test_max.m		test case for max_of.m

The tests directory contains

	test_refs.m		tests of reference.m, nb_reference.m
				and scoped_update.m

::::::::::::::
extras/references/global.m
::::::::::::::
:- module global.
:- import_module reference, nb_reference, scoped_update.
::::::::::::::
extras/references/nb_reference.m
::::::::::::::
%----------------------------------------------------------------------------
-%
% Copyright (C) 1998 University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%----------------------------------------------------------------------------
-%
%
% File      : nb_reference.m
% Authors   : pets (Peter Schachte)
% Stability : low
% Purpose   : A non-backtrackably modifiable storage type
%
%  This module provides impure code for manipulating a non-backtrackable
%  reference type.  The basic idea is that you allocate a reference and pass
%  it through your code, and each time you dereference it you get the value
%  most recently assigned to it, even if the assignment has been backtracked
%  over.  This gives you a way to communicate information between disjunctive
%  alternatives in your code.
%
%  Because assignments to nb_references need to survive backtracking, every
%  term assigned to a nb_reference must be fully copied in some compiler
%  grades.  This means that nb_references may be somewhat expensive to use 
for
%  large terms.  However, dereferencing an nb_reference does not need to copy
%  the term, so it is very efficient.  Furthermore, if (part of) a new value
%  being assigned to a nb_reference was itself (part of) an nb_reference, 
that
%  part will not need to be copied.  For example, if you use nb_references to
%  build up a long list of terms one at a time, each time you add a new term
%  to the list it will need to be copied, but the old value will have already
%  been copied so it will not need to be copied again.
%
%  One further issue arises due to the copying of terms.  Because copied 
terms
%  are not reclaimed on failure, the only way they can be reclaimed is 
through
%  garbage collection.  If you use nb_references in a grade without garbage
%  collection, they will never be reclaimed.

:- module nb_reference.
:- interface.

%  A non-backtrackably destructively modifiable reference type
:- type nb_reference(T).

%  Create a new nb_reference given a term for it to reference.
:- impure pred new_nb_reference(T::in, nb_reference(T)::out) is det.

%  Get the value currently referred to by a nb_reference.
:- semipure pred value(nb_reference(T)::in, T::out) is det.

%  (non-backtrackably) modify a nb_reference to refer to a new object.
:- impure pred update(nb_reference(T)::in, T::in) is det.


:- implementation.

%  This type is not really used.  I'd rather define this as c_pointer, but
%  there's a bug in the Mercury compiler that makes that not work.
:- type nb_reference(T) ---> nb_reference(c_pointer).

:- pragma c_header_code("#include ""mercury_deep_copy.h""").

:- pragma inline(new_nb_reference/2).
:- pragma c_code(new_nb_reference(X::in, Ref::out), will_not_call_mercury, "
	incr_hp(Ref, 1);
	save_transient_registers();
	*(Word *)Ref = MR_make_long_lived(X, (Word *) TypeInfo_for_T,
			(Word *) Ref);
	restore_transient_registers();
").

:- pragma inline(value/2).
:- pragma c_code(value(Ref::in, X::out), will_not_call_mercury, "
	X = *(Word *) Ref;
").

:- pragma inline(update/2).
:- pragma c_code(update(Ref::in, X::in), will_not_call_mercury, "
	save_transient_registers();
	*(Word *)Ref = MR_make_long_lived(X, (Word *) TypeInfo_for_T,
			(Word *) Ref);
	restore_transient_registers();
").

::::::::::::::
extras/references/reference.m
::::::::::::::
%----------------------------------------------------------------------------
-%
% Copyright (C) 1998 University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%----------------------------------------------------------------------------
-%
%
% File      : reference.m
% Authors   : pets (Peter Schachte)
% Stability : low
% Purpose   : A backtrackably modifiable storage type
%
%  This module defines a type which is, in essence, a ``box'' into which you
%  can put any term, and later destructively replace the contents with
%  something else.  The store module in the standard library provides a clean
%  way to do exactly the same thing; the difference is that the reference
%  module allows you to do it without threading a store through your code.  
The
%  price for this convenience is that you must mark all predicates that 
create
%  or modify a reference, and all the predicates that call them, and so on, 
as
%  impure.  This is probably more inconvenient than just threading the store
%  through your code, so this module should probably only be used in
%  exceptional circumstances.
%
%  This module is implemented using the trailing features described in the
%  "Trailing" subsection of the "C interface" section of the "Pragmas" 
chapter
%  of the Mercury Language Reference Manual.  This means that in order to use
%  this module, you *must* compile with the --use-trail switch.  The easiest
%  way to do this is to include the line
%
%	GRADEFLAGS=--use-trail
%
%  in your Mmakefile.

:- module reference.
:- interface.

%  A backtrackably destructively modifiable reference type.
:- type reference(T).

%  Create a new reference given a term for it to (initially) refer to.
:- impure pred new_reference(T::in, reference(T)::out) is det.

%  Get the value currently referred to by a reference.
:- semipure pred value(reference(T)::in, T::out) is det.

%  (backtrackably) modify a reference to refer to a new object.
:- impure pred update(reference(T)::in, T::in) is det.


:- implementation.

%  This type is not really used.  I'd rather define this as c_pointer, but
%  there's a bug in the Mercury compiler that makes that not work.
:- type reference(T) ---> reference(c_pointer).

:- pragma c_header_code("#include ""mercury_trail.h""").
:- pragma c_header_code("
	typedef struct {
		void *value;
		MR_ChoicepointId id;
	} Reference, *RefPtr;
").

:- pragma inline(new_reference/2).
:- pragma c_code(new_reference(X::in, Ref::out), will_not_call_mercury, "
	incr_hp(Ref, (sizeof(Reference) + sizeof(Word) - 1) / sizeof(Word));
	((RefPtr)Ref)->value = (void *)X;
	((RefPtr)Ref)->id = MR_current_choicepoint_id();
").

:- pragma inline(value/2).
:- pragma c_code(value(Ref::in, X::out), will_not_call_mercury, "
	X = (Word) ((RefPtr)Ref)->value;
").

:- pragma inline(update/2).
:- pragma c_code(update(Ref::in, X::in), will_not_call_mercury, "
	RefPtr ref = (RefPtr) Ref;
	if (ref->id != MR_current_choicepoint_id()) {
		MR_trail_current_value((Word*)(&ref->value));
		MR_trail_current_value((Word*)(&ref->id));
		ref->id = MR_current_choicepoint_id();
	}
	ref->value = (void *)X;
").

::::::::::::::
extras/references/scoped_update.m
::::::::::::::
%----------------------------------------------------------------------------
-%
% Copyright (C) 1998 University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%----------------------------------------------------------------------------
-%
%
% File      : scoped_update.m
% Authors   : pets (Peter Schachte)
% Stability : low
% Purpose   : Support for scoping of non-backtrackable changes
%
%  This module, together with `references.m', provide a way of implementing
%  dynamically scoped global variables.
%
%  Occasionally one wants to use impose some scoping on non-backtrackable
%  changes to some memory.  That is, one wants to implicitly give a specified
%  memory location two possibly different values:  the value it has inside a
%  certain scope, and the value it has outside.  Thus after a certain goal
%  completes, one wants to reset a memory location to have the value it had
%  on entry.  However, if a subsequent goal should fail forcing re-entry of
%  the scope, the value should be reset to what it was on leaving the scope.
%  When the scope is eventually left, whether by success or failure, the
%  memory should again have its "outside the scope" value.
%
%  This code implements this functionality.  Ideally, this would be
%  implemented as a higher-order predicate whose arguments are a memory
%  location and a closure specifying the scope.  Unfortunately, the closure
%  would always be impure (since if it doesn't destructively change the
%  memory location there is no point in using the scoping construct), and
%  Mercury doesn't allow impure closures.
%
%  Therefore, this is implemented as matching enter_update_scope and
%  exit_update_scope predicates.  Care must be taken to ensure that these are
%  always called in pairs.
%
%  Note that scoped update can be implemented for backtrackable references, 
or
%  memory that is backtrackably updated, by simply getting the value before
%  entering the scope and reseting it to that value on leaving the scope.
%  Backtracking will take care of the rest automatically.  It is only for
%  non-backtrackable updates that this module becomes necessary.
%
%  This module is implemented using the trailing features described in the
%  "Trailing" subsection of the "C interface" section of the "Pragmas" 
chapter
%  of the Mercury Language Reference Manual.  This means that in order to use
%  this module, you *must* compile with the --use-trail switch.  The easiest
%  way to do this is to include the line
%
%	GRADEFLAGS=--use-trail
%
%  in your Mmakefile.

:- module scoped_update.
:- interface.

:- type scoped_update_handle.

:- impure pred enter_scope(T::in, scoped_update_handle::muo) is det.
:- impure pred exit_scope(scoped_update_handle::mdi) is det.


:- implementation.

:- pragma c_header_code("
#include <stdio.h>

#include ""mercury_trail.h""

/*
**  To handle the scoping, we use a ScopeHandle data structure, which
**  holds both the value inside and outside the scope.  Then we have
**  four functions to handle entering and leaving the scope both
**  forwards (on success) and backwards (on failure).  The user only
**  needs to think about the forwards versions; the backwards
**  functions are installed as function trail entries, and so are
**  automatically called at the right time.
*/

typedef struct {
	Word *var;
	Word insideval;
	Word outsideval;
} *ScopeHandle;

void ME_enter_scope_failing(ScopeHandle handle, MR_untrail_reason reason);
void ME_exit_scope_failing(ScopeHandle handle, MR_untrail_reason reason);


#ifdef ME_DEBUG_SCOPE
#define show_handle(msg, handle) \
	printf(""%s <%5d, in: %5d, out: %5d\n"", msg, *(int *)handle->var, \
			(int) handle->insideval, (int) handle->outsideval)
#define untrail_msg(msg) \
	printf(msg)
#else
#define show_handle(msg, handle)
#define untrail_msg(msg)
#endif
").


:- pragma c_code("
void
ME_enter_scope_failing(ScopeHandle handle, MR_untrail_reason reason)
{
	switch (reason) {
		case MR_exception:
		case MR_undo:
			untrail_msg(""ME_enter_scope_failing: ""
					""exception/undo\n"");
			show_handle(""=> fail back into scope.  old:  "",
					handle);
			handle->outsideval = *handle->var;
			*handle->var = handle->insideval;
			show_handle(""=>                        new:  "",
					handle);
			break;
		default:
			untrail_msg(""ME_enter_scope_failing: default\n"");
			break;
	}
}


void ME_exit_scope_failing(ScopeHandle handle, MR_untrail_reason reason) {
	switch (reason) {
		case MR_exception:
		case MR_undo:
			untrail_msg(""ME_exit_scope_failing: ""
					""exception/undo\n"");
			show_handle(""<= fail back out of scope.  old:  "",
					handle);
			*handle->var = handle->outsideval;
			show_handle(""<=                          new:  "",
					handle);
			break;
		case MR_commit:
		case MR_solve:
			untrail_msg(""ME_exit_scope_failing: commit/solve\n"");
			/* This *may* help GC collect more garbage */
			handle->var = (Word *)0;
			handle->outsideval = handle->insideval = (Word)0;
			break;
		default:
			untrail_msg(""ME_exit_scope_failing: default\n"");
			/* we may need to do something if reason == MR_gc */
			break;
	}
}

").

:- type scoped_update_handle == c_pointer.

:- pragma c_code(enter_scope(Ptr::in, Scoped_update_handle::muo),
		will_not_call_mercury, "
	Word rec;
	ScopeHandle handle;

	incr_hp(rec, (sizeof(*handle) + sizeof(Word) - 1) / sizeof(Word));
	handle = (ScopeHandle) rec;
	handle->var = (Word *)Ptr;
	handle->insideval = handle->outsideval = *(Word *)Ptr;
	MR_trail_function(ME_exit_scope_failing, handle);

	show_handle("">> enter scope:  "", handle);

	Scoped_update_handle = (Word) handle;
").

:- pragma c_code(exit_scope(Handle::mdi), will_not_call_mercury, "
	ScopeHandle handle = (ScopeHandle) Handle;

	show_handle(""<< exit scope.  old:  "", handle);
	handle->insideval = *handle->var;
	*handle->var = handle->outsideval;
	MR_trail_function(ME_enter_scope_failing, handle);
	show_handle(""                new:  "", handle);
").


::::::::::::::
extras/references/samples/Mmakefile
::::::::::::::
#----------------------------------------------------------------------------
-#
# Copyright (C) 1997-1998 The University of Melbourne.
# This file may only be copied under the terms of the GNU Library General
# Public License - see the file COPYING.LIB in the Mercury distribution.
#----------------------------------------------------------------------------
-#

MAIN_TARGET = all

# We need to use a grade with trailing
GRADEFLAGS += --use-trail

MGNUCFLAGS= -I..

# Link in the reference library from ..
MCFLAGS += -I.. $(EXTRA_MCFLAGS)
MLFLAGS += -R`pwd`/.. -L.. $(EXTRA_MLFLAGS)
MLLIBS = -lglobal $(EXTRA_MLLIBS)
VPATH = ..:$(MMAKE_VPATH)
C2INITFLAGS = ../global.init
%_init.c: $(C2INITFLAGS)

# We need the following to use shared libraries on Linux
#MGNUCFLAGS += -DPIC_REG
#MLFLAGS += --shared

#MLFLAGS += --static

#----------------------------------------------------------------------------
-#

PROGS	=	max_test

DEPENDS =	$(PROGS:%=%.depend)
CS	=	$(PROGS:%=%.c)
RESS	=	$(PROGS:%=%.res)

#----------------------------------------------------------------------------
-#

$(PROGS): 

%.out: %
	./$< > $@ 2>&1;

%.res: %.exp %.out
	diff -c $*.exp $*.out > $@

#----------------------------------------------------------------------------
-#

.PHONY: depend
depend: $(DEPENDS)

.PHONY: all
all: $(PROGS)

.PHONY: check
check: $(RESS)

.PHONY: cs
cs: $(CS)

.PHONY: clean
clean:
	rm -f *.out *.res

#----------------------------------------------------------------------------
-#
::::::::::::::
extras/references/samples/max_of.m
::::::::::::::
%----------------------------------------------------------------------------
-%
% Copyright (C) 1998 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.
%----------------------------------------------------------------------------
-%
% 
% File      : max_of.m
% Authors   : pets (Peter Schachte)
% Stability : low
% Purpose   : demonstration of nb_reference type
%
%  This module defines a predicate max_of/2 that is equivalent to
%
%	max_of(Pred, Max) :-
%		unsorted_solutions(Pred, List),
%		List = [First|Rest],
%		foldl((pred(X,Y,Z) is det :- max(X,Y,Z)), Rest, First, Max).
%
%   but which is potentially more efficient, because it avoids building a
%   list of solutions.

:- module max_of.
:- interface.

:- pred max_of(pred(int), int).
:- mode max_of(pred(out) is nondet, out) is semidet.
:- mode max_of(pred(out) is multi, out) is det.

:- implementation.

:- import_module nb_reference.
:- import_module int, bool.

%  This implementation uses two non-backtrackable references, one to keep
%  track of whether or not we've had any solutions, and the other to store 
the
%  max "so far."  For each solution we find, if it's the first, we set the 
max
%  so far to it, and we record that we've had some solutions.  If not the
%  first solution, then we update the max if the new solution is larger than
%  the max so far.  When we've found all the solutions, we make sure we've
%  found at least one solution, and then return the max so far as the result.
%
%  There is one difficulty implementing this predicate.  When the Pred
%  argument is a multi closure, we want max_of to be det.  But when Pred is
%  nondet, we must check to make sure than we have had any solutions; if not,
%  max_of/2 must fail.  Unfortunately, the Mercury compiler can't determine
%  that when Pred is multi, the test will always succeed, so the determinacy
%  checker complains that max_of/2 in that mode is actually semidet.  We work
%  around that with the min_solutions/1 predicate, which is implemented with
%  C code.  This allows us to have different code for different modes, which
%  allows us to work around the problem.  It would be much more convenient if
%  Mercury allowed us to have different code for different modes of a
%  predicate implemented in Mercury.


:- pragma promise_pure(max_of/2).

max_of(Pred, Max) :-
	impure new_nb_reference(no, Someref),
	impure new_nb_reference(0, Maxref),
	(
		Pred(Value),
		semipure value(Someref, Some),
		( Some = no ->
			impure update(Someref, yes),
			impure update(Maxref, Value)
		;
			semipure value(Maxref, Prev),
			( Value > Prev ->
				impure update(Maxref, Value)
			;
				true
			)
		),
		fail
	;   
		impure min_solutions(Pred, MinSolutions),
		(
			MinSolutions = 1
		;
			semipure value(Someref, yes)
		),
		semipure value(Maxref, Max)
	).


:- impure pred min_solutions(pred(T), int).
:- mode min_solutions(pred(out) is nondet, out(bound(0))) is det.
:- mode min_solutions(pred(out) is multi, out(bound(1))) is det.

:- pragma c_code(
	min_solutions(_Pred::(pred(out) is nondet), Res::out(bound(0))),
		will_not_call_mercury, "Res = 0;").
:- pragma c_code(
	min_solutions(_Pred::(pred(out) is multi), Res::out(bound(1))),
		will_not_call_mercury, "Res = 1;").

::::::::::::::
extras/references/samples/max_test.exp
::::::::::::::
The biggest small square mod 29 is 28
::::::::::::::
extras/references/samples/max_test.m
::::::::::::::
%----------------------------------------------------------------------------
-%
% Copyright (C) 1998 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.
%----------------------------------------------------------------------------
-%
% 
% File      : max_test.m
% Authors   : pets (Peter Schachte)
% Purpose   : test the max_of module
%

:- module max_test.
:- interface.

:- import_module io.

:- pred main(io__state::di, io__state::uo) is det.

:- implementation.

:- import_module max_of.
:- import_module int.

main -->
	( { max_of(square_mod_29, Max) } ->
		write_string("The biggest small square mod 29 is "),
		write_int(Max),
		write_string("\n")
	;
		write_string("square_mod_29 failed!\n")
	).

:- pred square_mod_29(int).
:- mode square_mod_29(out) is nondet.

square_mod_29((I*I) mod 29) :-
	between(I, 1, 100).


:- pred between(int, int, int).
:- mode between(out, in, in) is nondet.

between(I, Low, High) :-
	Low =< High,
	(
		I = Low
	;
		between(I, Low+1, High)
	).


::::::::::::::
extras/references/tests/Mmakefile
::::::::::::::
#----------------------------------------------------------------------------
-#
# Copyright (C) 1997-1998 The University of Melbourne.
# This file may only be copied under the terms of the GNU Library General
# Public License - see the file COPYING.LIB in the Mercury distribution.
#----------------------------------------------------------------------------
-#

MAIN_TARGET = all

# We need to use a grade with trailing
GRADEFLAGS += --use-trail

MGNUCFLAGS= -I..

# Link in the reference library from ..
MCFLAGS += -I.. $(EXTRA_MCFLAGS)
MLFLAGS += -R`pwd`/.. -L.. $(EXTRA_MLFLAGS)
MLLIBS = -lglobal $(EXTRA_MLLIBS)
VPATH = ..:$(MMAKE_VPATH)
C2INITFLAGS = ../global.init
%_init.c: $(C2INITFLAGS)

# We need the following to use shared libraries on Linux
#MGNUCFLAGS += -DPIC_REG
#MLFLAGS += --shared

#MLFLAGS += --static

#----------------------------------------------------------------------------
-#

PROGS	=	ref_test

DEPENDS =	$(PROGS:%=%.depend)
CS	=	$(PROGS:%=%.c)
RESS	=	$(PROGS:%=%.res)

#----------------------------------------------------------------------------
-#

$(PROGS): ../libglobal.a

%.out: %
	./$< > $@ 2>&1;

%.res: %.exp %.out
	diff -c $*.exp $*.out > $@

#----------------------------------------------------------------------------
-#

.PHONY: depend
depend: $(DEPENDS)

.PHONY: all
all: $(PROGS)

.PHONY: check
check: $(RESS)

.PHONY: cs
cs: $(CS)

.PHONY: clean
clean:
	rm -f *.out *.res

#----------------------------------------------------------------------------
-#
::::::::::::::
extras/references/tests/ref_test.exp
::::::::::::::
42
42
7
7
before scope ref = 0; reset to 1
inside scope ref = 1; reset to 11
after scope ref = 1; reset to 101
inside scope ref = 11; reset to 31
after scope ref = 101; reset to 201
inside scope ref = 31; reset to 61
after scope ref = 201; reset to 301
before scope ref = 301; reset to 303
inside scope ref = 303; reset to 313
after scope ref = 303; reset to 503
inside scope ref = 313; reset to 333
after scope ref = 503; reset to 703
inside scope ref = 333; reset to 363
after scope ref = 703; reset to 903
before scope ref = 903; reset to 906
inside scope ref = 906; reset to 916
after scope ref = 906; reset to 1206
inside scope ref = 916; reset to 936
after scope ref = 1206; reset to 1506
inside scope ref = 936; reset to 966
after scope ref = 1506; reset to 1806
outside scope ref = 1806; reset to 0
inside 1 scope ref = 0; reset to 1
inside 2 scope ref = 1; reset to 2
inside 1 scope ref = 1; reset to 3
outside scope ref = 0; reset to 4
3
7
::::::::::::::
extras/references/tests/ref_test.m
::::::::::::::
%----------------------------------------------------------------------------
-%
% Copyright (C) 1998 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.
%----------------------------------------------------------------------------
-%
% 
% File      : ref_test.m
% Authors   : pets (Peter Schachte)
% Purpose   : test of reference types
%

:- module ref_test.
:- interface.
:- import_module io.

:- impure pred main(io__state::di, io__state::uo) is det.

:- implementation.

:- import_module int.
:- import_module reference, nb_reference, scoped_update.

main -->
	{ impure new_reference(3,X) },
	{ impure new_nb_reference(3,Y) },
	(
		{ impure update(X, 42) },
		{ impure update(Y, 42) },
		{ semipure value(X,V1) },
		{ semipure value(Y,W1) },
		print(V1),
		nl,
		print(W1),
		nl,
		{same(X, X1)},
		{same(Y, Y1)},
		{ impure update(X1, 7) },
		{ impure update(Y1, 7) },
		{ semipure value(X, V2) },
		{ semipure value(Y, W2) },
		print(V2),
		nl,
		print(W2),
		nl,
		{ impure scope_test }
	;
		{ impure scope_test2 }
	;
		{ semipure value(X, V3) },
		print(V3),
		nl,
		{ semipure value(Y, W3) },
		print(W3),
		nl
	).


%  Here is an example of using references to implement non-backtrackable
%  global variables.  We implement global variables with a function that
%  returns a reference.

:- pragma c_header_code("extern Integer globalvar;").
:- pragma c_code("Integer globalvar = 0;").

:- func globalvar = nb_reference(int).
:- pragma inline(globalvar/0).
:- pragma c_code(globalvar = (Ref::out), will_not_call_mercury, "
	Ref = (Word) &globalvar;
").


%  Here is an example of using the scoped_update module.  This effectively
%  creates two versions of globalvar:  one between the enter_scope/
%  exit_scope pair, and one outside it.

:- impure pred scope_test is failure.

scope_test :-
	small_int(I),
	semipure value(globalvar, V0),
	impure update(globalvar, V0+I),
	impure scope_test_message("before", V0, V0+I),
	impure enter_scope(globalvar, Handle),
	small_int(J),
	semipure value(globalvar, V1),
	impure scope_test_message("inside", V1, V1+(J*10)),
	impure update(globalvar, V1+(J*10)),
	impure exit_scope(Handle),
	semipure value(globalvar, V2),
	impure update(globalvar, V2+(I*100)),
	impure scope_test_message("after", V2, V2+(I*100)),
	fail.

%  This predicate checks nested enter/exit scope calls.

:- impure pred scope_test2 is failure.

scope_test2 :-
	semipure value(globalvar, V0),
	impure update(globalvar, 0),
	impure scope_test_message("outside", V0, 0),
	impure enter_scope(globalvar, Handle1),
	semipure value(globalvar, V1),
	impure update(globalvar, 1),
	impure scope_test_message("inside 1", V1, 1),
	impure enter_scope(globalvar, Handle2),
	semipure value(globalvar, V2),
	impure update(globalvar, 2),
	impure scope_test_message("inside 2", V2, 2),
	impure exit_scope(Handle2),
	semipure value(globalvar, V3),
	impure update(globalvar, 3),
	impure scope_test_message("inside 1", V3, 3),
	impure exit_scope(Handle1),
	semipure value(globalvar, V4),
	impure update(globalvar, 4),
	impure scope_test_message("outside", V4, 4),
	fail.


:- pred same(T, T).
:- mode same(in, in) is semidet.
:- mode same(in, out) is det.
:- mode same(out, in) is det.

same(X,X).


:- pred small_int(int::out) is multi.

small_int(1).
small_int(2).
small_int(3).

:- impure pred scope_test_message(string::in, int::in, int::in) is det.

:- pragma c_header_code("
#include <stdio.h>
").

:- pragma c_code(scope_test_message(Prefix::in, Old::in, New::in),
		will_not_call_mercury, "
	printf(""%s scope ref = %d; reset to %d\n"", (char *)Prefix,
			(int)Old, (int)New);
").