[m-rev.] diff: fix bug with copying closures
Fergus Henderson
fjh at cs.mu.OZ.AU
Wed Aug 8 07:46:38 AEST 2001
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
--------------------------------------------------------------------------
More information about the reviews
mailing list