proposed addition to standard library

[Fergus Henderson]

Hi,

Here's a more fleshed out version of the object identity stuff I described
in previous mail.  I'm thinking of adding this to the standard library.
(I just need to extend the implementation to work for non-gc grades;
that will require making `object(T)' a builtin type with its own type_layout,
so that we handle deep_copy for it correctly.  Also we'd want io__write
to handle objects nicely.)

Comments?

What do people think about using the name `object' for this?
Any suggestions for an alternative name?

%-----------------------------------------------------------------------------%
% Copyright (C) 1997 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: object.m
%	This file provides the `object(T)' ADT, which is used for
%	immutable objects with identity.
%	Useful for hash consing, amoung other things.
% author: fjh
% stability: high
%-----------------------------------------------------------------------------%
:- module object.
:- interface.

	% An object(T) is an abstract thing that
	% has an identity, and a value of type T.
	% Objects with the same identity have the same value,
	% but objects with the same value can have different
	% identities.  However, for each value there is
	% a canonical object with that value.
	% Objects are unifiable and comparable;
	% those operations are both constant time, since they need
	% only compare the object identities, not the values.
:- type object(T).

	% `object_value(Object) = Value' is true iff
	% `Object' is an object with value `Value'.
:- func object_value(object(T)) = T.
:- mode object_value(in) = out is det.		% this is O(1)
:- mode object_value(out) = in is cc_multi.	% this is also O(1)

	% `canonical_object(Value)' returns the canonical object for the
	% specified value.
	% Warning: such objects will NOT be garbage collected.
:- func canonical_object(T) = object(T).

%-----------------------------------------------------------------------------%
:- implementation.
:- import_module map, std_util.

	% Defining object(T) as c_pointer will only work with the
	% conservative garbage collector.  For non-gc (or accurate-gc)
	% grades, deep_copy will not work correctly.
:- type object(T) == c_pointer. 

:- pragma c_code(object_value(Obj::in) = (Val::out), will_not_call_mercury, "
	Val = Obj;
").
:- pragma c_code(object_value(Obj::out) = (Val::in), will_not_call_mercury, "
	Obj = Val;
").

% the following function is not referentially transparent
% it is a det version of the reverse mode of object_value
:- func value_to_object(T) = object(T).
:- pragma c_code(value_to_object(Val::in) = (Obj::out), will_not_call_mercury,
"
	Obj = Val;
").

canonical_object(Value) = CanonicalObject :-
	%
	% The calls to `get_global_table' and `set_global_table' below
	% are non-logical.  We pass Object to set_global_table and return
	% it as CanonicalObject just to try to make sure that the compiler
	% won't optimize away the call to set_global_table.
	%
	% XXX we ought to be using hash tables here...
	%
	type_to_univ(Value, UnivValue),
	get_global_table(Table0),
	( map__search(Table0, UnivValue, Object) ->
		CanonicalObject = Object
	;
		Object = value_to_object(Value),
		map__det_insert(Table0, UnivValue, Object, Table),
		set_global_table(Table, Object, CanonicalObject)
	).

:- type canonical_object_table == map(univ, c_pointer).

:- pred get_global_table(canonical_object_table::uo) is det.

:- pred set_global_table(canonical_object_table::in, T::in, T::out) is det.

:- pragma c_header_code("
	extern Word ML_canonical_object_table;
").

:- pragma c_code("
	#define ML_EMPTY_MAP 0	/* works now, but not very robust */
	Word ML_canonical_object_table = ML_EMPTY_MAP;
").

:- pragma c_code(get_global_table(Table::uo), will_not_call_mercury,
	"Table = ML_canonical_object_table;"
).

:- pragma c_code(set_global_table(Table::in, In::in, Out::out),
		will_not_call_mercury, "
	ML_canonical_object_table = Table;
	Out = In;
").

/********************
OLD VERSION
	% This implementation uses tabling.
:- table canonical_object/1.
canonical_object(Value) = assert_unique(canonical_object_2(Value)).

:- pred canonical_object_2(T::in, object(T)::out) is cc_multi.
canonical_object_2(object_value(Object), Object).

:- func assert_unique(pred(T)) = T.
:- mode assert_unique(pred(out) is cc_nondet) = out is semidet.
:- mode assert_unique(pred(out) is cc_multi) = out is det.

assert_unique(Pred) = OutVal :-
	call(cc_cast(Pred), OutVal).

:- func cc_cast(pred(T)) = pred(T).
:- mode cc_cast(pred(out) is cc_nondet) = out(pred(out) is semidet) is det.
:- mode cc_cast(pred(out) is cc_multi) = out(pred(out) is det) is det.

:- pragma c_code(cc_cast(X::(pred(out) is cc_multi)) =
			(Y::out(pred(out) is det)),
		will_not_call_mercury,
		"Y = X;").
:- pragma c_code(cc_cast(X::(pred(out) is cc_nondet)) =
			(Y::out(pred(out) is semidet)),
		will_not_call_mercury,
		"Y = X;").
END OLD VERSION
********************/

%-----------------------------------------------------------------------------%

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