The R Project SVN R

Rev

Rev 36990 | Rev 38004 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 36990 Rev 38002
Line 94... Line 94...
94 
    LOGICAL(value)[0] = prev;
 94 
    LOGICAL(value)[0] = prev;
95 
    return value;
 95 
    return value;
96 
}
 96 
}
97 
 
 97 
 
98 
Rboolean R_current_trace_state() { return GET_TRACE_STATE; }
 98 
Rboolean R_current_trace_state() { return GET_TRACE_STATE; }
- 
 
 99 
 
- 
 
 100 
 
- 
 
 101 
/* memory tracing */
- 
 
 102 
/* report when a traced object is duplicated */
- 
 
 103 
 
- 
 
 104 
SEXP attribute_hidden do_memtrace(SEXP call, SEXP op, SEXP args, SEXP rho)
- 
 
 105 
{
- 
 
 106 
#ifdef R_MEMORY_PROFILING
- 
 
 107 
    SEXP object;
- 
 
 108 
    char buffer[20];
- 
 
 109 
 
- 
 
 110 
    checkArity(op, args);
- 
 
 111 
 
- 
 
 112 
    object=CAR(args);
- 
 
 113 
    if (TYPEOF(object) == CLOSXP ||
- 
 
 114 
	TYPEOF(object) == BUILTINSXP ||
- 
 
 115 
	TYPEOF(object) == SPECIALSXP)
- 
 
 116 
	    errorcall(call, "argument must not be a function");
- 
 
 117 
 
- 
 
 118 
    if(object == R_NilValue)
- 
 
 119 
	    errorcall(call, "cannot trace NULL");
- 
 
 120 
 
- 
 
 121 
    if(TYPEOF(object) == ENVSXP || TYPEOF(object) == PROMSXP)
- 
 
 122 
	    errorcall(call,"memtrace is not useful for promise and environment objects");
- 
 
 123 
    if(TYPEOF(object) == EXTPTRSXP || TYPEOF(object) == WEAKREFSXP)
- 
 
 124 
	    errorcall(call,"memtrace is not useful for weak reference or pointer objects");
- 
 
 125 
 
- 
 
 126 
    SET_TRACE(object, 1);
- 
 
 127 
    sprintf(buffer, "<%p>", object);
- 
 
 128 
    return mkString(buffer);
- 
 
 129 
#else
- 
 
 130 
    errorcall(call,"R not compiled with memory profiling");
- 
 
 131 
    return R_NilValue;
- 
 
 132 
#endif
- 
 
 133 
}
- 
 
 134 
 
- 
 
 135 
SEXP attribute_hidden do_memuntrace(SEXP call, SEXP op, SEXP args, SEXP rho)
- 
 
 136 
{
- 
 
 137 
#ifdef R_MEMORY_PROFILING
- 
 
 138 
    SEXP object;
- 
 
 139 
 
- 
 
 140 
    checkArity(op, args);
- 
 
 141 
 
- 
 
 142 
    object=CAR(args);
- 
 
 143 
    if (TYPEOF(object) == CLOSXP ||
- 
 
 144 
	TYPEOF(object) == BUILTINSXP ||
- 
 
 145 
	TYPEOF(object) == SPECIALSXP)
- 
 
 146 
	    errorcall(call, "argument must not be a function");
- 
 
 147 
 
- 
 
 148 
    if (TRACE(object))
- 
 
 149 
	    SET_TRACE(object, 0);
- 
 
 150 
#else
- 
 
 151 
    error(call,"R not compiled with memory profiling");
- 
 
 152 
#endif
- 
 
 153 
    return R_NilValue;
- 
 
 154 
}
- 
 
 155 
 
- 
 
 156 
 
- 
 
 157 
#ifndef R_MEMORY_PROFILING
- 
 
 158 
void memtrace_report(SEXP object){
- 
 
 159 
     return;
- 
 
 160 
}
- 
 
 161 
#else
- 
 
 162 
void memtrace_report(SEXP old, SEXP new){
- 
 
 163 
    RCNTXT *cptr;
- 
 
 164
- 
 
 165 
    if (!R_current_trace_state()) return;
- 
 
 166 
    Rprintf("memtrace[%p->%p]: ",old,new);
- 
 
 167 
    for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
- 
 
 168 
	if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
- 
 
 169 
	    && TYPEOF(cptr->call) == LANGSXP) {
- 
 
 170 
	    SEXP fun = CAR(cptr->call);
- 
 
 171 
	    Rprintf("%s ",
- 
 
 172 
		    TYPEOF(fun) == SYMSXP ? CHAR(PRINTNAME(fun)) :
- 
 
 173 
		    "<Anonymous>");
- 
 
 174 
	}
- 
 
 175 
    }
- 
 
 176 
    Rprintf("\n");
- 
 
 177 
 
- 
 
 178 
}
- 
 
 179 
 
- 
 
 180 
#endif /* R_MEMORY_PROFILING */