[m-rev.] diff: fix bug with copying closures

[Fergus Henderson]

Estimated hours taken: 3
Branches: main, release

Fix a bug where MR_deep_copy() was crashing when copying closures
for polymorphic predicates.

runtime/mercury_layout_util.h:
runtime/mercury_layout_util.c:
	Add MR_materialize_closure_typeinfos(),
	for use by mercury_deep_copy_body.h.

runtime/mercury_deep_copy.c:
	#include mercury_layout_util.h, for MR_materialize_closure_typeinfos().

runtime/mercury_deep_copy_body.h:
	Fix a bug: when copying closures, use MR_materialize_closure_typeinfos()
	to get the type_infos for the already-applied closure arguments
	from the closure itself, rather than trying to get them from
	the arguments of the typeinfo for the closure (the latter holds
	the type-infos for the yet-to-be-applied arguments, not the
	already-applied arguments).

tests/hard_coded/Mmakefile:
tests/hard_coded/copy_pred_2.m:
tests/hard_coded/copy_pred_2.exp:
	Add a test case.

Workspace: /home/venus/fjh/ws-venus4/mercury
Index: runtime/mercury_deep_copy.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy.c,v
retrieving revision 1.24
diff -u -d -r1.24 mercury_deep_copy.c
--- runtime/mercury_deep_copy.c	31 May 2001 06:00:11 -0000	1.24
+++ runtime/mercury_deep_copy.c	7 Aug 2001 20:35:15 -0000
@@ -16,6 +16,7 @@
 #include "mercury_deep_copy.h"
 #include "mercury_type_info.h"
 #include "mercury_ho_call.h"
+#include "mercury_layout_util.h"
 #include "mercury_memory.h"
 
 
Index: runtime/mercury_deep_copy_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy_body.h,v
retrieving revision 1.37
diff -u -d -r1.37 mercury_deep_copy_body.h
--- runtime/mercury_deep_copy_body.h	29 Apr 2001 18:21:57 -0000	1.37
+++ runtime/mercury_deep_copy_body.h	7 Aug 2001 20:51:23 -0000
@@ -452,9 +452,14 @@
                 new_closure->MR_closure_layout = closure_layout;
                 new_closure->MR_closure_num_hidden_args = args;
                 new_closure->MR_closure_code = old_closure->MR_closure_code;
+			
+		/*
+		** Fill in the pseudo_typeinfos in the closure layout
+		** with the values from the closure.
+		*/
+                type_info_arg_vector = MR_materialize_closure_typeinfos(
+		    closure_layout->type_params, old_closure);
 
-                type_info_arg_vector =
-                    MR_TYPEINFO_GET_HIGHER_ORDER_ARG_VECTOR(type_info);
                 /* copy the arguments */
                 for (i = 0; i < args; i++) {
                     MR_PseudoTypeInfo arg_pseudo_type_info;
@@ -471,6 +476,9 @@
                             type_info_arg_vector, arg_pseudo_type_info,
                             lower_limit, upper_limit);
                 }
+		if (type_info_arg_vector) {
+		    MR_free(type_info_arg_vector);
+		}
 
                 new_data = (MR_Word) new_closure;
                 leave_forwarding_pointer(data_ptr, new_data);
Index: runtime/mercury_layout_util.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_layout_util.c,v
retrieving revision 1.22
diff -u -d -r1.22 mercury_layout_util.c
--- runtime/mercury_layout_util.c	18 Jan 2001 01:19:06 -0000	1.22
+++ runtime/mercury_layout_util.c	7 Aug 2001 21:27:57 -0000
@@ -15,6 +15,10 @@
 #include "mercury_stack_layout.h"
 #include "mercury_layout_util.h"
 
+static MR_Word MR_lookup_closure_long_lval(MR_Long_Lval locn, MR_Closure *closure,
+	bool *succeeded);
+
+
 void
 MR_copy_regs_to_saved_regs(int max_mr_num, MR_Word *saved_regs)
 {
@@ -75,26 +79,25 @@
 MR_materialize_typeinfos_base(const MR_Label_Layout *label_layout,
 	MR_Word *saved_regs, MR_Word *base_sp, MR_Word *base_curfr)
 {
-	MR_TypeInfoParams	type_params;
-	bool			succeeded;
-	MR_Integer		count;
-	int			i;
+	const MR_Type_Param_Locns *tvar_locns;
+	
+	tvar_locns = label_layout->MR_sll_tvars;
+	if (tvar_locns != NULL) {
+		MR_TypeInfoParams	type_params;
+		bool			succeeded;
+		MR_Integer		count;
+		int			i;
 
-	if (label_layout->MR_sll_tvars != NULL) {
-		count = label_layout->MR_sll_tvars->MR_tp_param_count;
-		type_params = (MR_TypeInfoParams)
-			MR_NEW_ARRAY(MR_Word, count + 1);
+		count = tvar_locns->MR_tp_param_count;
+		type_params = (MR_TypeInfoParams) MR_NEW_ARRAY(MR_Word, count + 1);
 
 		for (i = 0; i < count; i++) {
-			if (label_layout->MR_sll_tvars->MR_tp_param_locns[i]
-					!= 0)
+			if (tvar_locns->MR_tp_param_locns[i] != 0)
 			{
 				type_params[i + 1] = (MR_TypeInfo)
 					MR_lookup_long_lval_base(
-						label_layout->MR_sll_tvars->
-							MR_tp_param_locns[i],
-						saved_regs,
-						base_sp, base_curfr,
+						tvar_locns->MR_tp_param_locns[i],
+						saved_regs, base_sp, base_curfr,
 						&succeeded);
 				if (! succeeded) {
 					MR_fatal_error("missing type param in "
@@ -104,6 +107,40 @@
 		}
 
 		return type_params;
+
+	} else {
+		return NULL;
+	}
+}
+
+MR_TypeInfoParams
+MR_materialize_closure_typeinfos(const MR_Type_Param_Locns *tvar_locns,
+	MR_Closure *closure)
+{
+	if (tvar_locns != NULL) {
+		MR_TypeInfoParams	type_params;
+		bool			succeeded;
+		MR_Integer		count;
+		int			i;
+
+		count = tvar_locns->MR_tp_param_count;
+		type_params = (MR_TypeInfoParams) MR_NEW_ARRAY(MR_Word, count + 1);
+
+		for (i = 0; i < count; i++) {
+			if (tvar_locns->MR_tp_param_locns[i] != 0)
+			{
+				type_params[i + 1] = (MR_TypeInfo)
+					MR_lookup_closure_long_lval(
+						tvar_locns->MR_tp_param_locns[i],
+						closure, &succeeded);
+				if (! succeeded) {
+					MR_fatal_error("missing type param in "
+					    "MR_materialize_closure_typeinfos");
+				}
+			}
+		}
+
+		return type_params;
 	} else {
 		return NULL;
 	}
@@ -138,6 +175,111 @@
 	return MR_lookup_long_lval_base(locn, saved_regs,
 		MR_saved_sp(saved_regs), MR_saved_curfr(saved_regs),
 		succeeded);
+}
+
+static MR_Word
+MR_lookup_closure_long_lval(MR_Long_Lval locn, MR_Closure *closure,
+	bool *succeeded)
+{
+	int	locn_num;
+	int	offset;
+	MR_Word	value;
+	MR_Word	baseaddr;
+	MR_Word	sublocn;
+
+	*succeeded = FALSE;
+	value = 0;
+
+	locn_num = (int) MR_LONG_LVAL_NUMBER(locn);
+	switch (MR_LONG_LVAL_TYPE(locn)) {
+		case MR_LONG_LVAL_TYPE_R:
+			if (MR_print_locn) {
+				printf("r%d", locn_num);
+			}
+			if (locn_num <= closure->MR_closure_num_hidden_args) {
+				value = closure->MR_closure_hidden_args(locn_num);
+				*succeeded = TRUE;
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_F:
+			if (MR_print_locn) {
+				printf("f%d", locn_num);
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_STACKVAR:
+			if (MR_print_locn) {
+				printf("stackvar%d", locn_num);
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_FRAMEVAR:
+			if (MR_print_locn) {
+				printf("framevar%d", locn_num);
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_SUCCIP:
+			if (MR_print_locn) {
+				printf("succip");
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_MAXFR:
+			if (MR_print_locn) {
+				printf("maxfr");
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_CURFR:
+			if (MR_print_locn) {
+				printf("curfr");
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_HP:
+			if (MR_print_locn) {
+				printf("hp");
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_SP:
+			if (MR_print_locn) {
+				printf("sp");
+			}
+			break;
+
+		case MR_LONG_LVAL_TYPE_INDIRECT:
+			offset = MR_LONG_LVAL_INDIRECT_OFFSET(locn_num);
+			sublocn = MR_LONG_LVAL_INDIRECT_BASE_LVAL(locn_num);
+			if (MR_print_locn) {
+				printf("offset %d from ", offset);
+			}
+			baseaddr = MR_lookup_closure_long_lval(sublocn,
+					closure, succeeded);
+			if (! *succeeded) {
+				break;
+			}
+			value = MR_typeclass_info_type_info(baseaddr,
+				offset);
+			*succeeded = TRUE;
+			break;
+
+		case MR_LONG_LVAL_TYPE_UNKNOWN:
+			if (MR_print_locn) {
+				printf("unknown");
+			}
+			break;
+
+		default:
+			if (MR_print_locn) {
+				printf("DEFAULT");
+			}
+			break;
+	}
+
+	return value;
 }
 
 MR_Word
Index: runtime/mercury_layout_util.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_layout_util.h,v
retrieving revision 1.14
diff -u -d -r1.14 mercury_layout_util.h
--- runtime/mercury_layout_util.h	18 Jan 2001 01:19:07 -0000	1.14
+++ runtime/mercury_layout_util.h	7 Aug 2001 21:35:42 -0000
@@ -37,8 +37,8 @@
 ** index zero will not have a type_info in it.  We store a dummy type_ctor_info
 ** there, so that the array will itself look like a typeinfo.
 ** 
-** The vector returned by MR_materialize_typeinfos is from malloc;
-** it should be freed after last use.
+** The vector returned by MR_materialize_typeinfos is from MR_malloc;
+** it should be MR_freed after last use.
 **
 ** MR_materialize_typeinfos looks up locations in the current
 ** environment, as indicated by the set of saved registers (including MR_sp
@@ -46,6 +46,11 @@
 ** assumes the environment is given by the given values of MR_sp and MR_curfr,
 ** and does not assume that the registers have valid contents unless saved_regs
 ** is non-null.
+**
+** MR_materialize_closure_typeinfos does much the same except that
+** it takes an MR_Closure rather than an MR_Label_Layout,
+** and it gets the type_infos from a closure using the closure_layout,
+** rather than getting them from the registers/stacks using a label_layout.
 */ 
 
 extern	MR_TypeInfoParams	MR_materialize_typeinfos(
@@ -55,6 +60,10 @@
 					const MR_Label_Layout *label_layout,
 					MR_Word *saved_regs,
 					MR_Word *base_sp, MR_Word *base_curfr);
+extern	MR_TypeInfoParams	MR_materialize_closure_typeinfos(
+					const MR_Type_Param_Locns *tvar_locns,
+					MR_Closure *closure);
+
 
 /*
 ** If the given encoded location refers to a register, return its number.
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.124
diff -u -d -r1.124 Mmakefile
--- tests/hard_coded/Mmakefile	1 Aug 2001 00:31:39 -0000	1.124
+++ tests/hard_coded/Mmakefile	7 Aug 2001 21:40:27 -0000
@@ -150,7 +150,7 @@
 
 # The following tests are passed only in some grades:
 #
-# XXX copy_pred does not work in the hl* grades (e.g. hlc.gc),
+# XXX copy_pred and copy_pred_2 do not work in the hl* grades (e.g. hlc.gc),
 # because the MLDS back-end doesn't generate the closure layout
 # information needed to copy closures.
 #
@@ -168,11 +168,13 @@
 	ifeq "$(findstring profdeep,$(GRADE))" ""
 		BACKEND_PROGS = \
 			copy_pred \
+			copy_pred_2 \
 			factt_non \
 			type_tables 
 	else
 		BACKEND_PROGS = \
 			copy_pred \
+			copy_pred_2 \
 			type_tables
 	endif
 else
Index: tests/hard_coded/copy_pred_2.exp
===================================================================
RCS file: tests/hard_coded/copy_pred_2.exp
diff -N tests/hard_coded/copy_pred_2.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/copy_pred_2.exp	7 Aug 2001 21:40:55 -0000
@@ -0,0 +1,4 @@
+copying
+calling
+printing
+10, 20, blah
Index: tests/hard_coded/copy_pred_2.m
===================================================================
RCS file: tests/hard_coded/copy_pred_2.m
diff -N tests/hard_coded/copy_pred_2.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/copy_pred_2.m	7 Aug 2001 21:39:38 -0000
@@ -0,0 +1,39 @@
+	:- module copy_pred_2.
+	:- interface.
+	:- import_module io.
+
+	:- pred main(io__state::di, io__state::uo) is det.
+
+	:- implementation.
+
+	:- import_module list, map.
+	:- import_module std_util, string.
+
+	main -->
+		{ make_closure(10, 20, P0) },
+		io__write_string("copying\n"),
+		{ copy(P0, P1) },
+		{ inst_cast(P1, P) },
+		io__write_string("calling\n"),
+		{ P("blah", S) },
+		io__write_string("printing\n"),
+		print(S), nl.
+
+	:- pred make_closure(T, T, pred(string, string)).
+	:- mode make_closure(in, in, out(pred(in, out) is det)) is det.
+	:- pragma no_inline(make_closure/3).
+
+	make_closure(A, B, foo(A, B)).
+
+	:- pred inst_cast(pred(string, string), pred(string, string)).
+	:- mode inst_cast(in, out(pred(in, out) is det)) is det.
+	:- pragma c_code(inst_cast(X::in, Y::out(pred(in, out) is det)),
+		[will_not_call_mercury, thread_safe], "Y = X").
+
+	:- pred foo(T, T, string, string).
+	:- mode foo(in, in, in, out) is det.
+	foo(A, B, S0, S) :-
+		functor(A, FA, _),
+		functor(B, FB, _),
+		string__format("%s, %s, %s",
+			[s(FA), s(FB), s(S0)], S).

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
The University of Melbourne         |  of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh>  |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------