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;
}
