for review: Add implementation of reference types, plus examples
Peter Schachte
pets at cs.mu.OZ.AU
Tue Jan 27 15:41:36 AEDT 1998
Add implementation of reference types, plus examples
Created new directory extras/references containing an implementation
of backtrackable and non-backtrackable reference types, plus some
examples and a module allowing scoping of non-backtrackable updates to
memory. Here's an excerpt the README:
reference.m a backtrackable reference types
nb_reference.m a non-backtrackable reference types
scoped_update.m scoping for non-backtrackable updates
max_of.m an example of non-backtrackable references
maxtest.m test case for max_of.m
reftest.m tests of reference.m, nb_reference.m
and scoped_update.m
Mmakefile a makefile for all of this
Estimated hours taken: 24
extras/references/Mmakefile
extras/references/README
extras/references/max_of.m
extras/references/maxtest.m
extras/references/nb_reference.m
extras/references/reference.m
extras/references/reftest.m
extras/references/scoped_update.m
see above
New File: extras/references/Mmakefile
===================================================================
EXES = reftest maxtest
DEPS = $(addsuffix .depend,$(EXES))
MAIN_TARGET = all
GRADEFLAGS=--use-trail
depend: $(DEPS)
all: $(EXES)
New File: 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.
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
max_of.m an example of non-backtrackable references
maxtest.m test case for max_of.m
reftest.m tests of reference.m, nb_reference.m
and scoped_update.m
Mmakefile a makefile for all of this
New File: extras/references/max_of.m
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1997 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 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;").
New File: extras/references/maxtest.m
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1997 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 : maxtest.m
% Authors : pets (Peter Schachte)
% Stability : low
% Purpose : test the max_of module
%
:- module maxtest.
:- 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)
).
New File: extras/references/nb_reference.m
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1995 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 : 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.
%
% Note 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 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.
:- type nb_reference(T) == c_pointer.
:- pragma inline(new_nb_reference/2).
:- pragma c_code(new_nb_reference(X::in, Ref::out), will_not_call_mercury, "
incr_hp(Ref, 1);
*(Word *)Ref = nb_copy(X, TypeInfo_for_T, Ref);
").
:- 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, "
*(Word *)Ref = nb_copy(X, TypeInfo_for_T, Ref);
").
:- pragma c_header_code("
#include <mercury_memory.h>
#include <mercury_deep_copy.h>
#ifndef CONSERVATIVE_GC
static MemoryZone global_heap_zone;
static Word *global_hp;
#endif
/*
INIT nb_reference_module_init
*/
void nb_reference_module_init(void); /* suppress gcc warning */
void nb_reference_module_init(void) {
#ifndef CONSERVATIVE_GC
global_heap = create_zone(""global_heap"", 1, global_heap_size,
next_offset(), global_heap_zone_size, default_handler)
#endif
}
/*
* Recursively copy the term X (whose type is described by type_info) into
* the global heap, and return a pointer to the new term. If the nb_reference
* we are assigning to (bottom) is in the heap and part of X lives below it on
* the heap, we can avoid copying it, because if we backtrack beyond that, the
* reference will be reclaimed anyway, so the term will be unreachable.
*/
Word nb_copy(Word X, Word type_info, Word *bottom); /* suppress gcc warning */
Word nb_copy(Word X, Word type_info, Word *bottom) {
#ifdef CONSERVATIVE_GC
return X;
#else
Word result;
MemoryZone old_heap_zone = heap_zone;
Word old_hp = MR_hp;
if (bottom < heap_zone->bottom || bottom > heap_zone->top) {
bottom = heap_zone->bottom;
}
heap_zone = global_heap_zone;
global_heap_zone = old_heap_zone;
MR_hp = global_hp;
global_hp = old_hp;
save_transient_registers();
result = deep_copy(X, type_info, bottom, old_heap_zone->top);
restore_transient_registers();
old_heap_zone = global_heap_zone;
global_heap_zone = heap_zone;
heap_zone = old_heap_zone;
old_hp = global_hp;
global_hp = MR_hp;
MR_hp = old_hp;
return result;
#endif
}
").
New File: extras/references/reference.m
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1997 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 : 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.
%
% Note 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.
:- type reference(T) == c_pointer.
:- pragma c_header_code("#include ""mercury_trail.h""").
:- pragma c_header_code("
typedef struct {void * value; MR_ChoicepointId id;} *reference;
").
:- 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));
((reference)Ref)->value = (void *)X;
((reference)Ref)->id = MR_current_choicepoint_id();
}
").
:- pragma inline(value/2).
:- pragma c_code(value(Ref::in, X::out), will_not_call_mercury, "
X = (Word) ((reference)Ref)->value;
").
:- pragma inline(update/2).
:- pragma c_code(update(Ref::in, X::in), will_not_call_mercury, "
{
reference ref = (reference) 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;
}
").
New File: extras/references/reftest.m
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1995 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 : reftest.m
% Authors : pets (Peter Schachte)
% Stability : low
% Purpose : test of reference types
%
:- module reftest.
:- 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 }
; { 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(" int 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.
:- 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);
").
New File: extras/references/scoped_update.m
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1995 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 : scoped_update.m
% Authors : pets (Peter Schachte)
% Stability : low
% Purpose : Support for scoping of non-backtrackable changes
%
% Occasionally one wants to use impose some scoping on non-backtrackable
% changes to some memory. That is, one wants to implicitly give a given
% 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.
%
% Note 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 <mercury_trail.h>
/*
* To handle the scoping, we use a scope_handle 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;
} *scope_handle;
scope_handle enter_scope(Word ptr);
void exit_scope(scope_handle handle);
void enter_scope_failing(scope_handle handle, MR_untrail_reason reason);
void exit_scope_failing(scope_handle handle, MR_untrail_reason reason);
#include <stdio.h>
void show_handle(const char *msg, const scope_handle handle);
void show_handle(const char *msg, const scope_handle handle) {
/*
printf(""%s <%5d, in: %5d, out: %5d\n"",
msg, *(int *)handle->var, (int) handle->insideval,
(int) handle->outsideval);
*/
}
scope_handle enter_scope(Word ptr) {
Word rec;
scope_handle handle;
incr_hp(rec, (sizeof(*handle) + sizeof(Word) - 1) / sizeof(Word));
handle = (scope_handle) rec;
handle->var = (Word *)ptr;
handle->insideval = handle->outsideval = *(Word *)ptr;
MR_trail_function(exit_scope_failing, handle);
show_handle("">> enter scope: "", handle);
return handle;
}
void exit_scope(scope_handle handle) {
show_handle(""<< exit scope. old: "", handle);
handle->insideval = *handle->var;
*handle->var = handle->outsideval;
MR_trail_function(enter_scope_failing, handle);
show_handle("" new: "", handle);
}
void enter_scope_failing(scope_handle handle, MR_untrail_reason reason) {
switch (reason) {
case MR_exception:
case MR_undo:
show_handle(""=> fail back into scope. old: "", handle);
handle->outsideval = *handle->var;
*handle->var = handle->insideval;
show_handle(""=> new: "", handle);
break;
default:
break;
}
}
void exit_scope_failing(scope_handle handle, MR_untrail_reason reason) {
switch (reason) {
case MR_exception:
case MR_undo:
show_handle(""<= fail back out of scope. old: "", handle);
*handle->var = handle->outsideval;
show_handle(""<= new: "", handle);
break;
case MR_commit:
case MR_solve:
/* This *may* help GC collect more garbage */
handle->var = (Word *)0;
handle->outsideval = handle->insideval = (Word)0;
break;
default:
/* we may need to do something if reason == MR_gc */
break;
}
}
").
:- type scoped_update_handle == c_pointer.
:- pragma c_code(enter_scope(Ptr::in, Handle::muo), will_not_call_mercury, "
Handle = (Word) enter_scope(Ptr);
").
:- pragma c_code(exit_scope(Handle::mdi), will_not_call_mercury, "
exit_scope((scope_handle) Handle);
").
More information about the developers
mailing list