1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
4 * Copyright (C) 1998-2020 The R Core Team.
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21 #ifdef HAVE_CONFIG_H
22 #include <config.h>
23 #endif
24
25 #define R_USE_SIGNALS 1
26 #include <Defn.h>
27 #include <Internal.h>
28
do_debug(SEXP call,SEXP op,SEXP args,SEXP rho)29 SEXP attribute_hidden do_debug(SEXP call, SEXP op, SEXP args, SEXP rho)
30 {
31 SEXP ans = R_NilValue;
32
33 checkArity(op,args);
34 #define find_char_fun \
35 if (isValidString(CAR(args))) { \
36 SEXP s; \
37 PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0))); \
38 SETCAR(args, findFun(s, rho)); \
39 UNPROTECT(1); \
40 }
41 find_char_fun
42
43 if (TYPEOF(CAR(args)) != CLOSXP &&
44 TYPEOF(CAR(args)) != SPECIALSXP &&
45 TYPEOF(CAR(args)) != BUILTINSXP)
46 error(_("argument must be a function"));
47 switch(PRIMVAL(op)) {
48 case 0: // debug()
49 SET_RDEBUG(CAR(args), 1);
50 break;
51 case 1: // undebug()
52 if( RDEBUG(CAR(args)) != 1 )
53 warning("argument is not being debugged");
54 SET_RDEBUG(CAR(args), 0);
55 break;
56 case 2: // isdebugged()
57 ans = ScalarLogical(RDEBUG(CAR(args)));
58 break;
59 case 3: // debugonce()
60 SET_RSTEP(CAR(args), 1);
61 break;
62 }
63 return ans;
64 }
65
66 /* primitives .primTrace() and .primUntrace() */
do_trace(SEXP call,SEXP op,SEXP args,SEXP rho)67 SEXP attribute_hidden do_trace(SEXP call, SEXP op, SEXP args, SEXP rho)
68 {
69 checkArity(op, args);
70
71 find_char_fun
72
73 if (TYPEOF(CAR(args)) != CLOSXP &&
74 TYPEOF(CAR(args)) != SPECIALSXP &&
75 TYPEOF(CAR(args)) != BUILTINSXP)
76 errorcall(call, _("argument must be a function"));
77
78 switch(PRIMVAL(op)) {
79 case 0:
80 SET_RTRACE(CAR(args), 1);
81 break;
82 case 1:
83 SET_RTRACE(CAR(args), 0);
84 break;
85 }
86 return R_NilValue;
87 }
88
89
90 /* maintain global trace & debug state */
91
92 static Rboolean tracing_state = TRUE, debugging_state = TRUE;
93 #define GET_TRACE_STATE tracing_state
94 #define GET_DEBUG_STATE debugging_state
95 #define SET_TRACE_STATE(value) tracing_state = value
96 #define SET_DEBUG_STATE(value) debugging_state = value
97
do_traceOnOff(SEXP call,SEXP op,SEXP args,SEXP rho)98 SEXP attribute_hidden do_traceOnOff(SEXP call, SEXP op, SEXP args, SEXP rho)
99 {
100 checkArity(op, args);
101 SEXP onOff = CAR(args);
102 Rboolean trace = (PRIMVAL(op) == 0),
103 prev = trace ? GET_TRACE_STATE : GET_DEBUG_STATE;
104
105 if(length(onOff) > 0) {
106 Rboolean _new = asLogical(onOff);
107 if(_new == TRUE || _new == FALSE)
108 if(trace) SET_TRACE_STATE(_new);
109 else SET_DEBUG_STATE(_new);
110 else
111 error(_("Value for '%s' must be TRUE or FALSE"),
112 trace ? "tracingState" : "debuggingState");
113 }
114 return ScalarLogical(prev);
115 }
116
117 // GUIs, packages, etc can query:
R_current_debug_state()118 Rboolean R_current_debug_state() { return GET_DEBUG_STATE; }
R_current_trace_state()119 Rboolean R_current_trace_state() { return GET_TRACE_STATE; }
120
121
122 /* memory tracing */
123 /* report when a traced object is duplicated */
124
125 #ifdef R_MEMORY_PROFILING
126
do_tracemem(SEXP call,SEXP op,SEXP args,SEXP rho)127 SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
128 {
129 SEXP object;
130 char buffer[21];
131
132 checkArity(op, args);
133 check1arg(args, call, "x");
134
135 object = CAR(args);
136 if (TYPEOF(object) == CLOSXP ||
137 TYPEOF(object) == BUILTINSXP ||
138 TYPEOF(object) == SPECIALSXP)
139 errorcall(call, _("argument must not be a function"));
140
141 if(object == R_NilValue)
142 errorcall(call, _("cannot trace NULL"));
143
144 if(TYPEOF(object) == ENVSXP || TYPEOF(object) == PROMSXP)
145 errorcall(call,
146 _("'tracemem' is not useful for promise and environment objects"));
147 if(TYPEOF(object) == EXTPTRSXP || TYPEOF(object) == WEAKREFSXP)
148 errorcall(call,
149 _("'tracemem' is not useful for weak reference or external pointer objects"));
150
151 SET_RTRACE(object, 1);
152 snprintf(buffer, 21, "<%p>", (void *) object);
153 return mkString(buffer);
154 }
155
do_untracemem(SEXP call,SEXP op,SEXP args,SEXP rho)156 SEXP attribute_hidden do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
157 {
158 SEXP object;
159
160 checkArity(op, args);
161 check1arg(args, call, "x");
162
163 object=CAR(args);
164 if (TYPEOF(object) == CLOSXP ||
165 TYPEOF(object) == BUILTINSXP ||
166 TYPEOF(object) == SPECIALSXP)
167 errorcall(call, _("argument must not be a function"));
168
169 if (RTRACE(object))
170 SET_RTRACE(object, 0);
171 return R_NilValue;
172 }
173
174 #else
175
do_tracemem(SEXP call,SEXP op,SEXP args,SEXP rho)176 SEXP attribute_hidden NORET do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
177 {
178 checkArity(op, args);
179 check1arg(args, call, "x");
180 errorcall(call, _("R was not compiled with support for memory profiling"));
181 }
182
do_untracemem(SEXP call,SEXP op,SEXP args,SEXP rho)183 SEXP attribute_hidden NORET do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
184 {
185 checkArity(op, args);
186 check1arg(args, call, "x");
187 errorcall(call, _("R was not compiled with support for memory profiling"));
188 }
189
190 #endif /* R_MEMORY_PROFILING */
191
192 #ifndef R_MEMORY_PROFILING
memtrace_report(void * old,void * _new)193 void memtrace_report(void* old, void *_new) {
194 return;
195 }
196 #else
memtrace_stack_dump(void)197 static void memtrace_stack_dump(void)
198 {
199 RCNTXT *cptr;
200
201 for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
202 if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
203 && TYPEOF(cptr->call) == LANGSXP) {
204 SEXP fun = CAR(cptr->call);
205 Rprintf("%s ",
206 TYPEOF(fun) == SYMSXP ? translateChar(PRINTNAME(fun)) :
207 "<Anonymous>");
208 }
209 }
210 Rprintf("\n");
211 }
212
memtrace_report(void * old,void * _new)213 void memtrace_report(void * old, void * _new)
214 {
215 if (!R_current_trace_state()) return;
216 Rprintf("tracemem[%p -> %p]: ", (void *) old, _new);
217 memtrace_stack_dump();
218 }
219
220 #endif /* R_MEMORY_PROFILING */
221
do_retracemem(SEXP call,SEXP op,SEXP args,SEXP rho)222 SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
223 {
224 #ifdef R_MEMORY_PROFILING
225 SEXP object, previous, ans, argList;
226 char buffer[21];
227 static SEXP do_retracemem_formals = NULL;
228 Rboolean visible;
229
230 if (do_retracemem_formals == NULL)
231 do_retracemem_formals = allocFormalsList2(install("x"),
232 R_PreviousSymbol);
233
234 PROTECT(argList = matchArgs_NR(do_retracemem_formals, args, call));
235 if(CAR(argList) == R_MissingArg) SETCAR(argList, R_NilValue);
236 if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue);
237
238 object = CAR(argList);
239 if (TYPEOF(object) == CLOSXP ||
240 TYPEOF(object) == BUILTINSXP ||
241 TYPEOF(object) == SPECIALSXP)
242 errorcall(call, _("argument must not be a function"));
243
244 previous = CADR(argList);
245 if(!isNull(previous) && (!isString(previous) || LENGTH(previous) != 1))
246 errorcall(call, _("invalid '%s' argument"), "previous");
247
248 if (RTRACE(object)) {
249 snprintf(buffer, 21, "<%p>", (void *) object);
250 visible = TRUE;
251 ans = mkString(buffer);
252 } else {
253 visible = FALSE;
254 ans = R_NilValue;
255 }
256
257 if (previous != R_NilValue){
258 SET_RTRACE(object, 1);
259 if (R_current_trace_state()) {
260 /* FIXME: previous will have <0x....> whereas other values are
261 without the < > */
262 Rprintf("tracemem[%s -> %p]: ",
263 translateChar(STRING_ELT(previous, 0)), (void *) object);
264 memtrace_stack_dump();
265 }
266 }
267 UNPROTECT(1);
268 R_Visible = visible;
269 return ans;
270 #else
271 R_Visible = FALSE; /* for consistency with other case */
272 return R_NilValue;
273 #endif
274 }
275