Instrument R_PreserveObject/R_ReleaseObject

R.patch

Index: src/include/Rinternals.h
===================================================================
--- src/include/Rinternals.h	(revision 78478)
+++ src/include/Rinternals.h	(working copy)
@@ -1461,9 +1461,15 @@
 int R_check_class_etc      (SEXP x, const char **valid);
 
 /* preserve objects across GCs */
-void R_PreserveObject(SEXP);
-void R_ReleaseObject(SEXP);
+  /*
+    void R_PreserveObject(SEXP);
+    void R_ReleaseObject(SEXP);*/
+#define R_PreserveObject(X) imp_R_PreserveObject(X, __func__, __FILE__, __LINE__)
+#define R_ReleaseObject(X) imp_R_ReleaseObject(X, __func__, __FILE__, __LINE__)
+void imp_R_PreserveObject(SEXP, const char *, const char *, int);
+void imp_R_ReleaseObject(SEXP, const char *, const char *, int);
 
+  
 SEXP R_NewPreciousMSet(int);
 void R_PreserveInMSet(SEXP x, SEXP mset);
 void R_ReleaseFromMSet(SEXP x, SEXP mset);
Index: src/main/main.c
===================================================================
--- src/main/main.c	(revision 78478)
+++ src/main/main.c	(working copy)
@@ -1676,6 +1676,8 @@
     return(again);
 }
 
+static void call_R_ReleaseObject(SEXP x) { R_ReleaseObject(x); }
+
 SEXP
 R_addTaskCallback(SEXP f, SEXP data, SEXP useData, SEXP name)
 {
@@ -1695,7 +1697,7 @@
 
     PROTECT(index = allocVector(INTSXP, 1));
     el = Rf_addTaskCallback(R_taskCallbackRoutine,  internalData,
-			    (void (*)(void*)) R_ReleaseObject, tmpName,
+			    (void (*)(void*)) call_R_ReleaseObject, tmpName,
 			    INTEGER(index));
 
     if(length(name) == 0) {
Index: src/main/memory.c
===================================================================
--- src/main/memory.c	(revision 78478)
+++ src/main/memory.c	(working copy)
@@ -3491,9 +3491,13 @@
 static int use_precious_hash = FALSE;
 static int precious_inited = FALSE;
 
-void R_PreserveObject(SEXP object)
+static long precious_counter = 0;
+
+void imp_R_PreserveObject(SEXP object, const char *fun, const char *fn, int line)
 {
     R_CHECK_THREAD;
+    precious_counter++;
+    fprintf(stderr, "P+:%p(%d) @%ld <%s() %s @%d>\n", object, (int)TYPEOF(object), precious_counter, fun, fn, line);
     if (! precious_inited) {
 	precious_inited = TRUE;
 	if (getenv("R_HASH_PRECIOUS"))
@@ -3510,9 +3514,12 @@
 	R_PreciousList = CONS(object, R_PreciousList);
 }
 
-void R_ReleaseObject(SEXP object)
+void imp_R_ReleaseObject(SEXP object, const char *fun, const char *fn, int line)
 {
     R_CHECK_THREAD;
+    precious_counter--;
+    fprintf(stderr, "P-:%p(%d) @%ld <%s() %s @%d>\n", object, (int)TYPEOF(object), precious_counter, fun, fn, line);
+
     if (! precious_inited)
 	return; /* can't be anything to delete yet */
     if (use_precious_hash) {