The R Project SVN – R – Diff – /trunk/src/main/debug.c

     errorcall(call,"R not compiled with memory profiling");
     return R_NilValue;
 #endif
+}
 SEXP attribute_hidden do_memuntrace(SEXP call, SEXP op, SEXP args, SEXP rho)
+{
 #ifdef R_MEMORY_PROFILING
     SEXP object;
 #ifndef R_MEMORY_PROFILING
 void memtrace_report(SEXP old, SEXP new){
      return;
+}
 #else
-void memtrace_report(SEXP old, SEXP new){
+static void memtrace_stack_dump(void){
     RCNTXT *cptr;
-    if (!R_current_trace_state()) return;
-    Rprintf("memtrace[%p->%p]: ",old,new);
     for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
 	if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
 	    && TYPEOF(cptr->call) == LANGSXP) {
 	    SEXP fun = CAR(cptr->call);
 	    Rprintf("%s ",
 		    "<Anonymous>");
+	}
+    }
     Rprintf("\n");
+}
+void memtrace_report(SEXP old, SEXP new){
+    if (!R_current_trace_state()) return;
+    Rprintf("memtrace[%p->%p]: ",old,new);
+    memtrace_stack_dump();
+}
 #endif /* R_MEMORY_PROFILING */
+SEXP attribute_hidden do_memretrace(SEXP call, SEXP op, SEXP args, SEXP rho)
+{
+#ifdef R_MEMORY_PROFILING
+    SEXP object, origin, ans;
+    char buffer[20];
+    checkArity(op, args);
+    object = CAR(args);
+    if (TYPEOF(object) == CLOSXP ||
+	TYPEOF(object) == BUILTINSXP ||
+	TYPEOF(object) == SPECIALSXP)
+	    errorcall(call, "argument must not be a function");
+    origin = CADR(args);
+    if (TRACE(object)){
+	    sprintf(buffer, "<%p>", object);
+	    ans= mkString(buffer);
+    } else ans=R_NilValue;
+    if (origin!=R_NilValue){
+       SET_TRACE(object, 1);
+       if (R_current_trace_state()) {
+	       Rprintf("memtrace[%s->%p]: ",CHAR(STRING_ELT(origin, 0)), object);
+	       memtrace_stack_dump();
+       }
+    }
+    return ans;
+#else
+    return R_NilValue;
+#endif
+}

The R Project SVN R

(root)/trunk/src/main/debug.c @ 28362 – Rev 38426 → 38550