diff: changes to copy/2

[Fergus Henderson]

Fix the handling of copy/2.

library/mercury_builtin.m:
	Implement copy/2 properly, using deep_copy().
	Add unsafe_promise_unique/2 with the same semantics
	as the old copy/2.

library/io.m:
library/set_bbbtree.m:
compiler/handle_options.m:
compiler/typecheck.m:
compiler/mode_info.m:
	Change some occurrences of copy/2 to call unsafe_promise_unique/2.

library/io.m:
	Change io__get_stream_names and io__set_stream_names to not
	use unique modes (this seems the simplest way for the moment
	of avoiding some ugly calls to unsafe_promise_unique).

cvs diff compiler/handle_options.m compiler/mode_info.m compiler/typecheck.m library/io.m library/mercury_builtin.m library/set_bbbtree.m
Index: compiler/handle_options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/handle_options.m,v
retrieving revision 1.29
diff -u -r1.29 handle_options.m
--- handle_options.m	1997/09/02 07:03:39	1.29
+++ handle_options.m	1997/10/12 07:22:06
@@ -177,7 +177,7 @@
 		[]
 	),
 
-	{ copy(OptionTable, OptionTable1) }, % XXX
+	{ unsafe_promise_unique(OptionTable, OptionTable1) }, % XXX
 	globals__io_init(OptionTable1, GC_Method, TagsMethod, ArgsMethod,
 		TypeInfoMethod, PrologDialect),
 
Index: compiler/mode_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mode_info.m,v
retrieving revision 1.39
diff -u -r1.39 mode_info.m
--- mode_info.m	1997/07/27 15:01:05	1.39
+++ mode_info.m	1997/10/12 07:22:21
@@ -358,14 +358,14 @@
 mode_info_get_io_state(mode_info(IOState0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_),
 		IOState) :-
 	% XXX
-	copy(IOState0, IOState).
+	unsafe_promise_unique(IOState0, IOState).
 
 %-----------------------------------------------------------------------------%
 
 mode_info_set_io_state( mode_info(_,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P), IOState0,
 			mode_info(IOState,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P)) :-
 	% XXX
-	copy(IOState0, IOState).
+	unsafe_promise_unique(IOState0, IOState).
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.214
diff -u -r1.214 typecheck.m
--- typecheck.m	1997/09/02 07:13:18	1.214
+++ typecheck.m	1997/10/12 12:12:56
@@ -2299,7 +2299,7 @@
 	map__init(TypeBindings),
 	FoundTypeError = no,
 	WarnedAboutOverloading = no,
-	copy(IOState0, IOState),	% XXX
+	unsafe_promise_unique(IOState0, IOState),	% XXX
 	TypeCheckInfo = typecheck_info(
 		IOState, ModuleInfo, CallPredId, 0, PredId, Context,
 		unify_context(explicit, []),
@@ -2315,7 +2315,7 @@
 
 typecheck_info_get_io_state(typecheck_info(IOState0,_,_,_,_,_,_,_,_,_,_,_,_), 
 		IOState) :-
-	copy(IOState0, IOState).	% XXX
+	unsafe_promise_unique(IOState0, IOState).	% XXX
 
 %-----------------------------------------------------------------------------%
 
@@ -2325,7 +2325,7 @@
 
 typecheck_info_set_io_state(typecheck_info(_,B,C,D,E,F,G,H,I,J,K,L,M), IOState0,
 			typecheck_info(IOState,B,C,D,E,F,G,H,I,J,K,L,M)) :-
-	copy(IOState0, IOState).	% XXX
+	unsafe_promise_unique(IOState0, IOState).	% XXX
 
 %-----------------------------------------------------------------------------%
 
Index: library/io.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/io.m,v
retrieving revision 1.140
diff -u -r1.140 io.m
--- io.m	1997/09/09 18:56:14	1.140
+++ io.m	1997/10/12 07:24:58
@@ -1794,31 +1794,27 @@
 :- pred io__stream_name(io__stream, string, io__state, io__state).
 :- mode io__stream_name(in, out, di, uo) is det.
 
-	% XXX major design flaw with regard to unique modes
-	% means that this is very inefficient.
 io__stream_name(Stream, Name) -->
-	io__get_stream_names(StreamNames0),
-	{ map__search(StreamNames0, Stream, Name1) ->
+	io__get_stream_names(StreamNames),
+	{ map__search(StreamNames, Stream, Name1) ->
 		Name = Name1
 	;
 		Name = "<stream name unavailable>"
 	},
-	{ copy(StreamNames0, StreamNames) }, % is this necessary?
 	io__set_stream_names(StreamNames).
 
 :- pred io__get_stream_names(io__stream_names, io__state, io__state).
-:- mode io__get_stream_names(uo, di, uo) is det.
+:- mode io__get_stream_names(out, di, uo) is det.
 
-:- pragma c_code(io__get_stream_names(StreamNames::uo, IO0::di, IO::uo), "
+:- pragma c_code(io__get_stream_names(StreamNames::out, IO0::di, IO::uo), "
 	StreamNames = ML_io_stream_names;
-	ML_io_stream_names = 0; /* ensure uniqueness */
 	update_io(IO0, IO);
 ").
 
 :- pred io__set_stream_names(io__stream_names, io__state, io__state).
-:- mode io__set_stream_names(di, di, uo) is det.
+:- mode io__set_stream_names(in, di, uo) is det.
 
-:- pragma c_code(io__set_stream_names(StreamNames::di, IO0::di, IO::uo), "
+:- pragma c_code(io__set_stream_names(StreamNames::in, IO0::di, IO::uo), "
 	ML_io_stream_names = StreamNames;
 	update_io(IO0, IO);
 ").
@@ -1836,9 +1832,7 @@
 
 io__insert_stream_name(Stream, Name) -->
 	io__get_stream_names(StreamNames0),
-	{ copy(Stream, Stream1) },
-	{ copy(Name, Name1) },
-	{ map__set(StreamNames0, Stream1, Name1, StreamNames) },
+	{ map__set(StreamNames0, Stream, Name, StreamNames) },
 	io__set_stream_names(StreamNames).
 
 %-----------------------------------------------------------------------------%
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.83
diff -u -r1.83 mercury_builtin.m
--- mercury_builtin.m	1997/09/06 18:23:33	1.83
+++ mercury_builtin.m	1997/10/12 07:13:48
@@ -102,15 +102,22 @@
 
 % PREDICATES.
 
-% copy/2 is used to make a `unique' copy of a data structure,
-% so that you can use destructive update.
-% At the moment it doesn't actually do any copying, since we
-% haven't implemented destructive update yet and so there is no need.
+% copy/2 makes a deep copy of a data structure.  The resulting copy is a
+% `unique' value, so you can use destructive update on it.
 
 :- pred copy(T, T).
 :- mode copy(ui, uo) is det.
 :- mode copy(in, uo) is det.
 
+% unsafe_promise_unique/2 is used to promise the compiler that you have a
+% `unique' copy of a data structure, so that you can use destructive update.
+% It is used to work around limitations in the current support for unique
+% modes.  `unsafe_promise_unique(X, Y)' is the same as `Y = X' except that
+% the compiler will assume that `Y' is unique.
+
+:- pred unsafe_promise_unique(T, T).
+:- mode unsafe_promise_unique(in, uo) is det.
+
 % We define !/0 (and !/2 for dcgs) to be equivalent to `true'.  This is for
 % backwards compatibility with Prolog systems.  But of course it only works
 % if all your cuts are green cuts.
@@ -640,20 +647,73 @@
 
 %-----------------------------------------------------------------------------%
 
+/* unsafe_promise_unique/2
+	:- pred unsafe_promise_unique(T, T).
+	:- mode unsafe_promise_unique(in, uo) is det.
+*/
+
+/* This doesn't work, due to the lack of support for aliasing.
+:- pragma(c_code, unsafe_promise_unique(X::in, Y::uo), "Y = X;").
+*/
+
+:- external(unsafe_promise_unique/2).
+:- pragma(c_code, "
+Define_extern_entry(mercury__unsafe_promise_unique_2_0);
+
+BEGIN_MODULE(unsafe_promise_unique_module)
+	init_entry(mercury__unsafe_promise_unique_2_0);
+BEGIN_CODE
+
+Define_entry(mercury__unsafe_promise_unique_2_0);
+#ifdef	COMPACT_ARGS
+	r1 = r2;
+#else
+	r3 = r2;
+#endif
+	proceed();
+
+END_MODULE
+
+/* Ensure that the initialization code for the above module gets run. */
+/*
+INIT sys_init_unsafe_promise_unique_module
+*/
+void sys_init_unsafe_promise_unique_module(void);
+	/* extra declaration to suppress gcc -Wmissing-decl warning */
+void sys_init_unsafe_promise_unique_module(void) {
+	extern ModuleFunc unsafe_promise_unique_module;
+	unsafe_promise_unique_module();
+}
+
+").
+
+%-----------------------------------------------------------------------------%
+
 /* copy/2
 	:- pred copy(T, T).
 	:- mode copy(ui, uo) is det.
 	:- mode copy(in, uo) is det.
 */
 
-	% XXX note that this is *not* deep copy, and so it is unsafe!
-
-/* This doesn't work, due to the lack of support for aliasing.
-:- pragma(c_code, copy(X::ui, Y::uo), "Y = X;").
-:- pragma(c_code, copy(X::in, Y::uo), "Y = X;").
-*/
+/*************
+Using `pragma c_code' doesn't work, due to the lack of support for
+aliasing, and in particular the lack of support for `ui' modes.
+:- pragma c_code(copy(Value::ui, Copy::uo), "
+	save_transient_registers();
+	Copy = deep_copy(Value, TypeInfo_for_T, NULL, NULL);
+	restore_transient_registers();
+").
+:- pragma c_code(copy(Value::in, Copy::uo), "
+	save_transient_registers();
+	Copy = deep_copy(Value, TypeInfo_for_T, NULL, NULL);
+	restore_transient_registers();
+").
+*************/
 
 :- external(copy/2).
+
+:- pragma(c_header_code, "#include ""deep_copy.h""").
+
 :- pragma(c_code, "
 Define_extern_entry(mercury__copy_2_0);
 Define_extern_entry(mercury__copy_2_1);
@@ -663,22 +723,41 @@
 	init_entry(mercury__copy_2_1);
 BEGIN_CODE
 
+#ifdef PROFILE_CALLS
+  #define fallthru(target, caller) { tailcall((target), (caller)); }
+#else
+  #define fallthru(target, caller)
+#endif
+
 Define_entry(mercury__copy_2_0);
+fallthru(ENTRY(mercury__copy_2_1), ENTRY(mercury__copy_2_0))
 Define_entry(mercury__copy_2_1);
+{
+	Word value, copy, type_info;
+
+	type_info = r1;
+	value = r2;
+
+	save_transient_registers();
+	copy = deep_copy(value, type_info, NULL, NULL);
+	restore_transient_registers();
+
 #ifdef	COMPACT_ARGS
-	r1 = r2;
+	r1 = copy;
 #else
-	r3 = r2;
+	r3 = copy;
 #endif
-	proceed();
 
+	proceed();
+}
 END_MODULE
 
 /* Ensure that the initialization code for the above module gets run. */
 /*
 INIT sys_init_copy_module
 */
-void sys_init_copy_module(void); /* suppress gcc -Wmissing-decl warning */
+void sys_init_copy_module(void);
+	/* extra declaration to suppress gcc -Wmissing-decl warning */
 void sys_init_copy_module(void) {
 	extern ModuleFunc copy_module;
 	copy_module();
Index: library/set_bbbtree.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/set_bbbtree.m,v
retrieving revision 1.10
diff -u -r1.10 set_bbbtree.m
--- set_bbbtree.m	1997/07/27 15:07:11	1.10
+++ set_bbbtree.m	1997/10/12 07:14:32
@@ -394,7 +394,7 @@
 set_bbbtree__insert(Set0, X, Set) :-
 	set_bbbtree__def_ratio(Ratio),
 	set_bbbtree__insert_r(Set0, X, Set1, Ratio),
-	copy(Set1, Set).
+	unsafe_promise_unique(Set1, Set).
 
 /* Uncomment this once destructive input and unique modes are fixed and detele
    the one above.
@@ -488,7 +488,7 @@
 	;
 		Set2 = Set0
 	),
-	copy(Set2, Set).
+	unsafe_promise_unique(Set2, Set).
 
 %------------------------------------------------------------------------------%
 
@@ -890,7 +890,7 @@
 	set_bbbtree__size(R, RSize),
 	N is 1 + LSize + RSize,
 	Tree0 = tree(X, N, L, R),
-	copy(Tree0, Tree).
+	unsafe_promise_unique(Tree0, Tree).
 
 %------------------------------------------------------------------------------%
 

-- 
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.