SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho) { #ifdef R_MEMORY_PROFILING SEXP object; char buffer[21]; checkArity(op, args); check1arg(args, call, "x"); object = CAR(args); if (TYPEOF(object) == CLOSXP || TYPEOF(object) == BUILTINSXP || TYPEOF(object) == SPECIALSXP) errorcall(call, _("argument must not be a function")); if(object == R_NilValue) errorcall(call, _("cannot trace NULL")); if(TYPEOF(object) == ENVSXP || TYPEOF(object) == PROMSXP) errorcall(call, _("'tracemem' is not useful for promise and environment objects")); if(TYPEOF(object) == EXTPTRSXP || TYPEOF(object) == WEAKREFSXP) errorcall(call, _("'tracemem' is not useful for weak reference or external pointer objects")); SET_RTRACE(object, 1); snprintf(buffer, 21, "<%p>", (void *) object); return mkString(buffer); #else errorcall(call, _("R was not compiled with support for memory profiling")); return R_NilValue; #endif }
/* primitives .primTrace() and .primUntrace() */ SEXP attribute_hidden do_trace(SEXP call, SEXP op, SEXP args, SEXP rho) { checkArity(op, args); find_char_fun if (TYPEOF(CAR(args)) != CLOSXP && TYPEOF(CAR(args)) != SPECIALSXP && TYPEOF(CAR(args)) != BUILTINSXP) errorcall(call, _("argument must be a function")); switch(PRIMVAL(op)) { case 0: SET_RTRACE(CAR(args), 1); break; case 1: SET_RTRACE(CAR(args), 0); break; } return R_NilValue; }
SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho) { #ifdef R_MEMORY_PROFILING SEXP object, previous, ans, argList; char buffer[21]; static SEXP do_retracemem_formals = NULL; if (do_retracemem_formals == NULL) do_retracemem_formals = allocFormalsList2(install("x"), R_PreviousSymbol); PROTECT(argList = matchArgs(do_retracemem_formals, args, call)); if(CAR(argList) == R_MissingArg) SETCAR(argList, R_NilValue); if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue); object = CAR(argList); if (TYPEOF(object) == CLOSXP || TYPEOF(object) == BUILTINSXP || TYPEOF(object) == SPECIALSXP) errorcall(call, _("argument must not be a function")); previous = CADR(argList); if(!isNull(previous) && !isString(previous)) errorcall(call, _("invalid '%s' argument"), "previous"); if (RTRACE(object)) { snprintf(buffer, 21, "<%p>", (void *) object); ans = mkString(buffer); } else { R_Visible = 0; ans = R_NilValue; } if (previous != R_NilValue){ SET_RTRACE(object, 1); if (R_current_trace_state()) { /* FIXME: previous will have <0x....> whereas other values are without the < > */ Rprintf("tracemem[%s -> %p]: ", translateChar(STRING_ELT(previous, 0)), (void *) object); memtrace_stack_dump(); } } UNPROTECT(1); return ans; #else R_Visible = 0; /* for consistency with other case */ return R_NilValue; #endif }
SEXP duplicate(SEXP s){ SEXP t; #ifdef R_PROFILING duplicate_counter++; #endif t = duplicate1(s, TRUE); #ifdef R_MEMORY_PROFILING if (RTRACE(s) && !(TYPEOF(s) == CLOSXP || TYPEOF(s) == BUILTINSXP || TYPEOF(s) == SPECIALSXP || TYPEOF(s) == PROMSXP || TYPEOF(s) == ENVSXP)){ memtrace_report(s,t); SET_RTRACE(t,1); } #endif return t; }
SEXP attribute_hidden do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP object; checkArity(op, args); check1arg(args, call, "x"); object=CAR(args); if (TYPEOF(object) == CLOSXP || TYPEOF(object) == BUILTINSXP || TYPEOF(object) == SPECIALSXP) errorcall(call, _("argument must not be a function")); if (RTRACE(object)) SET_RTRACE(object, 0); return R_NilValue; }
SEXP attribute_hidden do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho) { #ifdef R_MEMORY_PROFILING SEXP object; checkArity(op, args); check1arg(args, call, "x"); object=CAR(args); if (TYPEOF(object) == CLOSXP || TYPEOF(object) == BUILTINSXP || TYPEOF(object) == SPECIALSXP) errorcall(call, _("argument must not be a function")); if (RTRACE(object)) SET_RTRACE(object, 0); #else errorcall(call, _("R was not compiled with support for memory profiling")); #endif return R_NilValue; }