Commit | Line | Data |
146174a9 |
1 | #define PERL_NO_GET_CONTEXT |
583a019e |
2 | #include "EXTERN.h" |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
5 | |
94277a97 |
6 | /* define DBG_SUB to cause a warning on each subroutine entry. */ |
7399586d |
7 | /*#define DBG_SUB 1 */ |
94277a97 |
8 | |
9 | /* define DBG_TIMER to cause a warning when the timer is turned on and off. */ |
10 | /*#define DBG_TIMER 1 */ |
583a019e |
11 | |
ae7638f4 |
12 | #ifdef DEBUGGING |
13 | #define ASSERT(x) assert(x) |
14 | #else |
15 | #define ASSERT(x) |
16 | #endif |
17 | |
7619c85e |
18 | static CV * |
19 | db_get_cv(pTHX_ SV *sv) |
20 | { |
21 | CV *cv; |
22 | |
19bcb543 |
23 | if (SvIOK(sv)) { /* if (PERLDB_SUB_NN) { */ |
7619c85e |
24 | cv = INT2PTR(CV*,SvIVX(sv)); |
25 | } else { |
26 | if (SvPOK(sv)) { |
3f48f963 |
27 | STRLEN len; |
28 | const char *const name = SvPV(sv, len); |
29 | cv = get_cvn_flags(name, len, GV_ADD | SvUTF8(sv)); |
7619c85e |
30 | } else if (SvROK(sv)) { |
31 | cv = (CV*)SvRV(sv); |
32 | } else { |
33 | croak("DProf: don't know what subroutine to profile"); |
34 | } |
35 | } |
36 | return cv; |
37 | } |
38 | |
583a019e |
39 | #ifdef DBG_SUB |
7619c85e |
40 | # define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(aTHX_ A) |
94277a97 |
41 | void |
7619c85e |
42 | dprof_dbg_sub_notify(pTHX_ SV *Sub) { |
0626a780 |
43 | CV * const cv = db_get_cv(aTHX_ Sub); |
44 | GV * const gv = cv ? CvGV(cv) : NULL; |
94277a97 |
45 | if (cv && gv) { |
46 | warn("XS DBsub(%s::%s)\n", |
bfcb3514 |
47 | ((GvSTASH(gv) && HvNAME_get(GvSTASH(gv))) ? |
48 | HvNAME_get(GvSTASH(gv)) : "(null)"), |
94277a97 |
49 | GvNAME(gv)); |
50 | } else { |
51 | warn("XS DBsub(unknown) at %x", Sub); |
52 | } |
53 | } |
583a019e |
54 | #else |
94277a97 |
55 | # define DBG_SUB_NOTIFY(A) /* nothing */ |
583a019e |
56 | #endif |
57 | |
94277a97 |
58 | |
583a019e |
59 | #ifdef DBG_TIMER |
146174a9 |
60 | # define DBG_TIMER_NOTIFY(A) warn(A) |
583a019e |
61 | #else |
62 | # define DBG_TIMER_NOTIFY(A) /* nothing */ |
63 | #endif |
64 | |
583a019e |
65 | /* HZ == clock ticks per second */ |
66 | #ifdef VMS |
552e38a9 |
67 | # define HZ ((I32)CLK_TCK) |
583a019e |
68 | # define DPROF_HZ HZ |
69 | # include <starlet.h> /* prototype for sys$gettim() */ |
3e4b306a |
70 | # include <lib$routines.h> |
146174a9 |
71 | # define Times(ptr) (dprof_times(aTHX_ ptr)) |
d86c571c |
72 | # define NEEDS_DPROF_TIMES |
583a019e |
73 | #else |
59512d54 |
74 | # ifdef BSDish |
146174a9 |
75 | # define Times(ptr) (dprof_times(aTHX_ ptr)) |
d86c571c |
76 | # define NEEDS_DPROF_TIMES |
59512d54 |
77 | # define HZ 1000000 |
583a019e |
78 | # define DPROF_HZ HZ |
59512d54 |
79 | # else |
80 | # ifndef HZ |
81 | # ifdef CLK_TCK |
82 | # define HZ ((I32)CLK_TCK) |
83 | # else |
84 | # define HZ 60 |
85 | # endif |
86 | # endif |
87 | # ifdef OS2 /* times() has significant overhead */ |
88 | # define Times(ptr) (dprof_times(aTHX_ ptr)) |
89 | # define NEEDS_DPROF_TIMES |
90 | # define INCL_DOSPROFILE |
91 | # define INCL_DOSERRORS |
92 | # include <os2.h> |
93 | # define toLongLong(arg) (*(long long*)&(arg)) |
94 | # define DPROF_HZ g_dprof_ticks |
95 | # else |
96 | # define Times(ptr) (times(ptr)) |
97 | # define DPROF_HZ HZ |
98 | # endif |
99 | # endif |
583a019e |
100 | #endif |
101 | |
102 | XS(XS_Devel__DProf_END); /* used by prof_mark() */ |
103 | |
583a019e |
104 | /* Everything is built on times(2). See its manpage for a description |
105 | * of the timings. |
106 | */ |
107 | |
583a019e |
108 | union prof_any { |
109 | clock_t tms_utime; /* cpu time spent in user space */ |
110 | clock_t tms_stime; /* cpu time spent in system */ |
111 | clock_t realtime; /* elapsed real time, in ticks */ |
d86c571c |
112 | const char *name; |
583a019e |
113 | U32 id; |
114 | opcode ptype; |
115 | }; |
116 | |
117 | typedef union prof_any PROFANY; |
118 | |
146174a9 |
119 | typedef struct { |
120 | U32 dprof_ticks; |
d86c571c |
121 | const char* out_file_name; /* output file (defaults to tmon.out) */ |
146174a9 |
122 | PerlIO* fp; /* pointer to tmon.out file */ |
4a9d6100 |
123 | Off_t TIMES_LOCATION; /* Where in the file to store the time totals */ |
146174a9 |
124 | int SAVE_STACK; /* How much data to buffer until end of run */ |
125 | int prof_pid; /* pid of profiled process */ |
126 | struct tms prof_start; |
127 | struct tms prof_end; |
128 | clock_t rprof_start; /* elapsed real time ticks */ |
129 | clock_t rprof_end; |
130 | clock_t wprof_u; |
131 | clock_t wprof_s; |
132 | clock_t wprof_r; |
133 | clock_t otms_utime; |
134 | clock_t otms_stime; |
135 | clock_t orealtime; |
136 | PROFANY* profstack; |
137 | int profstack_max; |
138 | int profstack_ix; |
7619c85e |
139 | HV* cv_hash; /* cache of CV to identifier mappings */ |
140 | SV* key_hash; /* key for cv_hash */ |
146174a9 |
141 | U32 total; |
142 | U32 lastid; |
143 | U32 default_perldb; |
425d70b4 |
144 | UV depth; |
146174a9 |
145 | #ifdef OS2 |
146 | ULONG frequ; |
147 | long long start_cnt; |
148 | #endif |
149 | #ifdef PERL_IMPLICIT_CONTEXT |
82f07646 |
150 | PerlInterpreter *my_perl; |
146174a9 |
151 | #endif |
152 | } prof_state_t; |
153 | |
154 | prof_state_t g_prof_state; |
155 | |
156 | #define g_dprof_ticks g_prof_state.dprof_ticks |
157 | #define g_out_file_name g_prof_state.out_file_name |
158 | #define g_fp g_prof_state.fp |
159 | #define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION |
160 | #define g_SAVE_STACK g_prof_state.SAVE_STACK |
161 | #define g_prof_pid g_prof_state.prof_pid |
162 | #define g_prof_start g_prof_state.prof_start |
163 | #define g_prof_end g_prof_state.prof_end |
164 | #define g_rprof_start g_prof_state.rprof_start |
165 | #define g_rprof_end g_prof_state.rprof_end |
166 | #define g_wprof_u g_prof_state.wprof_u |
167 | #define g_wprof_s g_prof_state.wprof_s |
168 | #define g_wprof_r g_prof_state.wprof_r |
169 | #define g_otms_utime g_prof_state.otms_utime |
170 | #define g_otms_stime g_prof_state.otms_stime |
171 | #define g_orealtime g_prof_state.orealtime |
172 | #define g_profstack g_prof_state.profstack |
173 | #define g_profstack_max g_prof_state.profstack_max |
174 | #define g_profstack_ix g_prof_state.profstack_ix |
175 | #define g_cv_hash g_prof_state.cv_hash |
7619c85e |
176 | #define g_key_hash g_prof_state.key_hash |
146174a9 |
177 | #define g_total g_prof_state.total |
178 | #define g_lastid g_prof_state.lastid |
179 | #define g_default_perldb g_prof_state.default_perldb |
180 | #define g_depth g_prof_state.depth |
181 | #ifdef PERL_IMPLICIT_CONTEXT |
82f07646 |
182 | # define g_THX g_prof_state.my_perl |
146174a9 |
183 | #endif |
184 | #ifdef OS2 |
185 | # define g_frequ g_prof_state.frequ |
186 | # define g_start_cnt g_prof_state.start_cnt |
187 | #endif |
583a019e |
188 | |
d86c571c |
189 | #ifdef NEEDS_DPROF_TIMES |
0626a780 |
190 | static clock_t |
146174a9 |
191 | dprof_times(pTHX_ struct tms *t) |
583a019e |
192 | { |
146174a9 |
193 | #ifdef OS2 |
194 | ULONG rc; |
195 | QWORD cnt; |
196 | |
197 | if (!g_frequ) { |
198 | if (CheckOSError(DosTmrQueryFreq(&g_frequ))) |
64ace3f8 |
199 | croak("DosTmrQueryFreq: %s", SvPV_nolen(perl_get_sv("!",GV_ADD))); |
146174a9 |
200 | else |
201 | g_frequ = g_frequ/DPROF_HZ; /* count per tick */ |
202 | if (CheckOSError(DosTmrQueryTime(&cnt))) |
203 | croak("DosTmrQueryTime: %s", |
64ace3f8 |
204 | SvPV_nolen_const(perl_get_sv("!",GV_ADD))); |
146174a9 |
205 | g_start_cnt = toLongLong(cnt); |
583a019e |
206 | } |
146174a9 |
207 | |
208 | if (CheckOSError(DosTmrQueryTime(&cnt))) |
64ace3f8 |
209 | croak("DosTmrQueryTime: %s", SvPV_nolen(perl_get_sv("!",GV_ADD))); |
146174a9 |
210 | t->tms_stime = 0; |
211 | return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ); |
212 | #else /* !OS2 */ |
213 | # ifdef VMS |
214 | clock_t retval; |
215 | /* Get wall time and convert to 10 ms intervals to |
216 | * produce the return value dprof expects */ |
217 | # if defined(__DECC) && defined (__ALPHA) |
218 | # include <ints.h> |
219 | uint64 vmstime; |
220 | _ckvmssts(sys$gettim(&vmstime)); |
221 | vmstime /= 100000; |
222 | retval = vmstime & 0x7fffffff; |
223 | # else |
224 | /* (Older hw or ccs don't have an atomic 64-bit type, so we |
225 | * juggle 32-bit ints (and a float) to produce a time_t result |
226 | * with minimal loss of information.) */ |
227 | long int vmstime[2],remainder,divisor = 100000; |
228 | _ckvmssts(sys$gettim((unsigned long int *)vmstime)); |
229 | vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ |
230 | _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); |
231 | # endif |
232 | /* Fill in the struct tms using the CRTL routine . . .*/ |
233 | times((tbuffer_t *)t); |
234 | return (clock_t) retval; |
235 | # else /* !VMS && !OS2 */ |
59512d54 |
236 | # ifdef BSDish |
237 | # include <sys/resource.h> |
238 | struct rusage ru; |
239 | struct timeval tv; |
240 | /* Measure offset from start time to avoid overflow */ |
241 | static struct timeval tv0 = { 0, 0 }; |
242 | |
243 | if (!tv0.tv_sec) |
244 | if (gettimeofday(&tv0, NULL) < 0) |
64ace3f8 |
245 | croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD))); |
59512d54 |
246 | |
247 | if (getrusage(0, &ru) < 0) |
64ace3f8 |
248 | croak("getrusage: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD))); |
59512d54 |
249 | |
250 | if (gettimeofday(&tv, NULL) < 0) |
64ace3f8 |
251 | croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD))); |
59512d54 |
252 | |
253 | t->tms_stime = DPROF_HZ * ru.ru_stime.tv_sec + ru.ru_stime.tv_usec; |
254 | t->tms_utime = DPROF_HZ * ru.ru_utime.tv_sec + ru.ru_utime.tv_usec; |
255 | |
256 | if (tv.tv_usec < tv0.tv_usec) |
257 | tv.tv_sec--, tv.tv_usec += DPROF_HZ; |
258 | |
259 | return DPROF_HZ * (tv.tv_sec - tv0.tv_sec) + tv.tv_usec - tv0.tv_usec; |
260 | # else /* !VMS && !OS2 && !BSD! */ |
146174a9 |
261 | return times(t); |
59512d54 |
262 | # endif |
146174a9 |
263 | # endif |
264 | #endif |
265 | } |
d86c571c |
266 | #endif |
583a019e |
267 | |
268 | static void |
146174a9 |
269 | prof_dumpa(pTHX_ opcode ptype, U32 id) |
583a019e |
270 | { |
146174a9 |
271 | if (ptype == OP_LEAVESUB) { |
272 | PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id); |
273 | } |
274 | else if(ptype == OP_ENTERSUB) { |
275 | PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id); |
276 | } |
277 | else if(ptype == OP_GOTO) { |
278 | PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id); |
279 | } |
280 | else if(ptype == OP_DIE) { |
281 | PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id); |
282 | } |
283 | else { |
284 | PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype); |
583a019e |
285 | } |
286 | } |
287 | |
288 | static void |
0626a780 |
289 | prof_dumps(pTHX_ U32 id, const char *pname, const char *gname) |
583a019e |
290 | { |
146174a9 |
291 | PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname); |
583a019e |
292 | } |
293 | |
583a019e |
294 | static void |
146174a9 |
295 | prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime) |
583a019e |
296 | { |
146174a9 |
297 | PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); |
583a019e |
298 | } |
299 | |
300 | static void |
146174a9 |
301 | prof_dump_until(pTHX_ long ix) |
583a019e |
302 | { |
303 | long base = 0; |
304 | struct tms t1, t2; |
0626a780 |
305 | clock_t realtime2; |
583a019e |
306 | |
0626a780 |
307 | const clock_t realtime1 = Times(&t1); |
583a019e |
308 | |
146174a9 |
309 | while (base < ix) { |
0626a780 |
310 | const opcode ptype = g_profstack[base++].ptype; |
583a019e |
311 | if (ptype == OP_TIME) { |
0626a780 |
312 | const long tms_utime = g_profstack[base++].tms_utime; |
313 | const long tms_stime = g_profstack[base++].tms_stime; |
314 | const long realtime = g_profstack[base++].realtime; |
146174a9 |
315 | |
316 | prof_dumpt(aTHX_ tms_utime, tms_stime, realtime); |
317 | } |
318 | else if (ptype == OP_GV) { |
0626a780 |
319 | const U32 id = g_profstack[base++].id; |
320 | const char * const pname = g_profstack[base++].name; |
321 | const char * const gname = g_profstack[base++].name; |
146174a9 |
322 | |
323 | prof_dumps(aTHX_ id, pname, gname); |
324 | } |
325 | else { |
0626a780 |
326 | const U32 id = g_profstack[base++].id; |
146174a9 |
327 | prof_dumpa(aTHX_ ptype, id); |
583a019e |
328 | } |
329 | } |
146174a9 |
330 | PerlIO_flush(g_fp); |
583a019e |
331 | realtime2 = Times(&t2); |
332 | if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime |
333 | || t1.tms_stime != t2.tms_stime) { |
146174a9 |
334 | g_wprof_r += realtime2 - realtime1; |
335 | g_wprof_u += t2.tms_utime - t1.tms_utime; |
336 | g_wprof_s += t2.tms_stime - t1.tms_stime; |
337 | |
338 | PerlIO_printf(g_fp,"+ & Devel::DProf::write\n"); |
339 | PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", |
340 | /* The (IV) casts are one possibility: |
341 | * the Painfully Correct Way would be to |
342 | * have Clock_t_f. */ |
343 | (IV)(t2.tms_utime - t1.tms_utime), |
344 | (IV)(t2.tms_stime - t1.tms_stime), |
345 | (IV)(realtime2 - realtime1)); |
346 | PerlIO_printf(g_fp,"- & Devel::DProf::write\n"); |
347 | g_otms_utime = t2.tms_utime; |
348 | g_otms_stime = t2.tms_stime; |
349 | g_orealtime = realtime2; |
350 | PerlIO_flush(g_fp); |
583a019e |
351 | } |
352 | } |
353 | |
452932c3 |
354 | static void |
0626a780 |
355 | set_cv_key(pTHX_ CV *cv, const char *pname, const char *gname) |
7619c85e |
356 | { |
19bcb543 |
357 | SvGROW(g_key_hash, sizeof(CV**) + strlen(pname) + strlen(gname) + 3); |
358 | sv_setpvn(g_key_hash, (char*)&cv, sizeof(CV**)); |
7619c85e |
359 | sv_catpv(g_key_hash, pname); |
360 | sv_catpv(g_key_hash, "::"); |
361 | sv_catpv(g_key_hash, gname); |
362 | } |
363 | |
364 | static void |
146174a9 |
365 | prof_mark(pTHX_ opcode ptype) |
583a019e |
366 | { |
146174a9 |
367 | struct tms t; |
368 | clock_t realtime, rdelta, udelta, sdelta; |
146174a9 |
369 | U32 id; |
0626a780 |
370 | SV * const Sub = GvSV(PL_DBsub); /* name of current sub */ |
146174a9 |
371 | |
372 | if (g_SAVE_STACK) { |
ae7638f4 |
373 | if (g_profstack_ix + 10 > g_profstack_max) { |
146174a9 |
374 | g_profstack_max = g_profstack_max * 3 / 2; |
375 | Renew(g_profstack, g_profstack_max, PROFANY); |
376 | } |
377 | } |
583a019e |
378 | |
146174a9 |
379 | realtime = Times(&t); |
380 | rdelta = realtime - g_orealtime; |
381 | udelta = t.tms_utime - g_otms_utime; |
382 | sdelta = t.tms_stime - g_otms_stime; |
383 | if (rdelta || udelta || sdelta) { |
384 | if (g_SAVE_STACK) { |
ae7638f4 |
385 | ASSERT(g_profstack_ix + 4 <= g_profstack_max); |
146174a9 |
386 | g_profstack[g_profstack_ix++].ptype = OP_TIME; |
387 | g_profstack[g_profstack_ix++].tms_utime = udelta; |
388 | g_profstack[g_profstack_ix++].tms_stime = sdelta; |
389 | g_profstack[g_profstack_ix++].realtime = rdelta; |
390 | } |
391 | else { /* Write it to disk now so's not to eat up core */ |
392 | if (g_prof_pid == (int)getpid()) { |
393 | prof_dumpt(aTHX_ udelta, sdelta, rdelta); |
394 | PerlIO_flush(g_fp); |
583a019e |
395 | } |
583a019e |
396 | } |
146174a9 |
397 | g_orealtime = realtime; |
398 | g_otms_stime = t.tms_stime; |
399 | g_otms_utime = t.tms_utime; |
400 | } |
583a019e |
401 | |
146174a9 |
402 | { |
403 | SV **svp; |
404 | char *gname, *pname; |
146174a9 |
405 | |
0626a780 |
406 | CV * const cv = db_get_cv(aTHX_ Sub); |
407 | GV * const gv = CvGV(cv); |
93fec93b |
408 | if (isGV_with_GP(gv)) { |
409 | pname = GvSTASH(gv) ? HvNAME_get(GvSTASH(gv)) : NULL; |
410 | pname = pname ? pname : (char *) "(null)"; |
411 | gname = GvNAME(gv); |
412 | } else { |
413 | gname = pname = (char *) "(null)"; |
414 | } |
7619c85e |
415 | |
416 | set_cv_key(aTHX_ cv, pname, gname); |
aa07b2f6 |
417 | svp = hv_fetch(g_cv_hash, SvPVX_const(g_key_hash), SvCUR(g_key_hash), TRUE); |
146174a9 |
418 | if (!SvOK(*svp)) { |
146174a9 |
419 | sv_setiv(*svp, id = ++g_lastid); |
146174a9 |
420 | if (CvXSUB(cv) == XS_Devel__DProf_END) |
421 | return; |
422 | if (g_SAVE_STACK) { /* Store it for later recording -JH */ |
ae7638f4 |
423 | ASSERT(g_profstack_ix + 4 <= g_profstack_max); |
146174a9 |
424 | g_profstack[g_profstack_ix++].ptype = OP_GV; |
425 | g_profstack[g_profstack_ix++].id = id; |
426 | g_profstack[g_profstack_ix++].name = pname; |
427 | g_profstack[g_profstack_ix++].name = gname; |
428 | } |
429 | else { /* Write it to disk now so's not to eat up core */ |
430 | /* Only record the parent's info */ |
431 | if (g_prof_pid == (int)getpid()) { |
432 | prof_dumps(aTHX_ id, pname, gname); |
433 | PerlIO_flush(g_fp); |
583a019e |
434 | } |
146174a9 |
435 | else |
436 | PL_perldb = 0; /* Do not debug the kid. */ |
583a019e |
437 | } |
438 | } |
146174a9 |
439 | else { |
440 | id = SvIV(*svp); |
441 | } |
442 | } |
583a019e |
443 | |
146174a9 |
444 | g_total++; |
445 | if (g_SAVE_STACK) { /* Store it for later recording -JH */ |
ae7638f4 |
446 | ASSERT(g_profstack_ix + 2 <= g_profstack_max); |
146174a9 |
447 | g_profstack[g_profstack_ix++].ptype = ptype; |
448 | g_profstack[g_profstack_ix++].id = id; |
449 | |
450 | /* Only record the parent's info */ |
451 | if (g_SAVE_STACK < g_profstack_ix) { |
452 | if (g_prof_pid == (int)getpid()) |
453 | prof_dump_until(aTHX_ g_profstack_ix); |
454 | else |
455 | PL_perldb = 0; /* Do not debug the kid. */ |
456 | g_profstack_ix = 0; |
457 | } |
458 | } |
459 | else { /* Write it to disk now so's not to eat up core */ |
583a019e |
460 | |
146174a9 |
461 | /* Only record the parent's info */ |
462 | if (g_prof_pid == (int)getpid()) { |
463 | prof_dumpa(aTHX_ ptype, id); |
464 | PerlIO_flush(g_fp); |
465 | } |
466 | else |
467 | PL_perldb = 0; /* Do not debug the kid. */ |
468 | } |
583a019e |
469 | } |
470 | |
583a019e |
471 | /* Counts overhead of prof_mark and extra XS call. */ |
472 | static void |
146174a9 |
473 | test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s) |
583a019e |
474 | { |
b96d8cd9 |
475 | CV * const cv = get_cvs("Devel::DProf::NONESUCH_noxs", 0); |
0626a780 |
476 | HV * const oldstash = PL_curstash; |
583a019e |
477 | struct tms t1, t2; |
0626a780 |
478 | const U32 ototal = g_total; |
479 | const U32 ostack = g_SAVE_STACK; |
480 | const U32 operldb = PL_perldb; |
481 | int k = 0; |
482 | |
483 | clock_t realtime1 = Times(&t1); |
484 | clock_t realtime2 = 0; |
583a019e |
485 | |
146174a9 |
486 | g_SAVE_STACK = 1000000; |
0626a780 |
487 | |
583a019e |
488 | while (k < 2) { |
0626a780 |
489 | int i = 0; |
583a019e |
490 | /* Disable debugging of perl_call_sv on second pass: */ |
146174a9 |
491 | PL_curstash = (k == 0 ? PL_defstash : PL_debstash); |
492 | PL_perldb = g_default_perldb; |
583a019e |
493 | while (++i <= 100) { |
0626a780 |
494 | int j = 0; |
146174a9 |
495 | g_profstack_ix = 0; /* Do not let the stack grow */ |
583a019e |
496 | while (++j <= 100) { |
146174a9 |
497 | /* prof_mark(aTHX_ OP_ENTERSUB); */ |
583a019e |
498 | |
146174a9 |
499 | PUSHMARK(PL_stack_sp); |
500 | perl_call_sv((SV*)cv, G_SCALAR); |
501 | PL_stack_sp--; |
502 | /* prof_mark(aTHX_ OP_LEAVESUB); */ |
583a019e |
503 | } |
504 | } |
146174a9 |
505 | PL_curstash = oldstash; |
583a019e |
506 | if (k == 0) { /* Put time with debugging */ |
507 | realtime2 = Times(&t2); |
508 | *r = realtime2 - realtime1; |
509 | *u = t2.tms_utime - t1.tms_utime; |
510 | *s = t2.tms_stime - t1.tms_stime; |
146174a9 |
511 | } |
512 | else { /* Subtract time without debug */ |
583a019e |
513 | realtime1 = Times(&t1); |
514 | *r -= realtime1 - realtime2; |
515 | *u -= t1.tms_utime - t2.tms_utime; |
516 | *s -= t1.tms_stime - t2.tms_stime; |
517 | } |
518 | k++; |
519 | } |
146174a9 |
520 | g_total = ototal; |
521 | g_SAVE_STACK = ostack; |
522 | PL_perldb = operldb; |
583a019e |
523 | } |
524 | |
525 | static void |
146174a9 |
526 | prof_recordheader(pTHX) |
583a019e |
527 | { |
146174a9 |
528 | clock_t r, u, s; |
529 | |
530 | /* g_fp is opened in the BOOT section */ |
531 | PerlIO_printf(g_fp, "#fOrTyTwO\n"); |
532 | PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ); |
533 | PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION); |
534 | PerlIO_printf(g_fp, "# All values are given in HZ\n"); |
535 | test_time(aTHX_ &r, &u, &s); |
536 | PerlIO_printf(g_fp, |
537 | "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n", |
538 | /* The (IV) casts are one possibility: |
539 | * the Painfully Correct Way would be to |
540 | * have Clock_t_f. */ |
541 | (IV)u, (IV)s, (IV)r); |
542 | PerlIO_printf(g_fp, "$over_tests=10000;\n"); |
543 | |
544 | g_TIMES_LOCATION = PerlIO_tell(g_fp); |
545 | |
546 | /* Pad with whitespace. */ |
547 | /* This should be enough even for very large numbers. */ |
548 | PerlIO_printf(g_fp, "%*s\n", 240 , ""); |
549 | |
550 | PerlIO_printf(g_fp, "\n"); |
551 | PerlIO_printf(g_fp, "PART2\n"); |
552 | |
553 | PerlIO_flush(g_fp); |
583a019e |
554 | } |
555 | |
556 | static void |
146174a9 |
557 | prof_record(pTHX) |
583a019e |
558 | { |
146174a9 |
559 | /* g_fp is opened in the BOOT section */ |
560 | |
561 | /* Now that we know the runtimes, fill them in at the recorded |
562 | location -JH */ |
583a019e |
563 | |
146174a9 |
564 | if (g_SAVE_STACK) { |
565 | prof_dump_until(aTHX_ g_profstack_ix); |
566 | } |
567 | PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET); |
568 | /* Write into reserved 240 bytes: */ |
569 | PerlIO_printf(g_fp, |
570 | "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";", |
571 | /* The (IV) casts are one possibility: |
572 | * the Painfully Correct Way would be to |
573 | * have Clock_t_f. */ |
574 | (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u), |
575 | (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s), |
576 | (IV)(g_rprof_end-g_rprof_start-g_wprof_r)); |
577 | PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total); |
583a019e |
578 | |
146174a9 |
579 | PerlIO_close(g_fp); |
583a019e |
580 | } |
581 | |
582 | #define NONESUCH() |
583 | |
583a019e |
584 | static void |
d7b9cf63 |
585 | check_depth(pTHX_ void *foo) |
583a019e |
586 | { |
0626a780 |
587 | const U32 need_depth = PTR2UV(foo); |
146174a9 |
588 | if (need_depth != g_depth) { |
589 | if (need_depth > g_depth) { |
583a019e |
590 | warn("garbled call depth when profiling"); |
146174a9 |
591 | } |
592 | else { |
425d70b4 |
593 | IV marks = g_depth - need_depth; |
583a019e |
594 | |
146174a9 |
595 | /* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */ |
583a019e |
596 | while (marks--) { |
146174a9 |
597 | prof_mark(aTHX_ OP_DIE); |
583a019e |
598 | } |
146174a9 |
599 | g_depth = need_depth; |
583a019e |
600 | } |
601 | } |
602 | } |
603 | |
604 | #define for_real |
605 | #ifdef for_real |
606 | |
0626a780 |
607 | XS(XS_DB_sub); |
583a019e |
608 | XS(XS_DB_sub) |
609 | { |
c6c619a9 |
610 | dMARK; |
146174a9 |
611 | dORIGMARK; |
0626a780 |
612 | SV * const Sub = GvSV(PL_DBsub); /* name of current sub */ |
146174a9 |
613 | |
614 | #ifdef PERL_IMPLICIT_CONTEXT |
615 | /* profile only the interpreter that loaded us */ |
616 | if (g_THX != aTHX) { |
617 | PUSHMARK(ORIGMARK); |
7619c85e |
618 | perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG); |
146174a9 |
619 | } |
620 | else |
621 | #endif |
622 | { |
0626a780 |
623 | HV * const oldstash = PL_curstash; |
624 | const I32 old_scopestack_ix = PL_scopestack_ix; |
625 | const I32 old_cxstack_ix = cxstack_ix; |
583a019e |
626 | |
94277a97 |
627 | DBG_SUB_NOTIFY(Sub); |
583a019e |
628 | |
a6f8e609 |
629 | SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth)); |
146174a9 |
630 | g_depth++; |
583a019e |
631 | |
146174a9 |
632 | prof_mark(aTHX_ OP_ENTERSUB); |
633 | PUSHMARK(ORIGMARK); |
7619c85e |
634 | perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG); |
8063af02 |
635 | PL_curstash = oldstash; |
7619c85e |
636 | |
637 | /* Make sure we are on the same context and scope as before the call |
638 | * to the sub. If the called sub was exited via a goto, next or |
639 | * last then this will try to croak(), however perl may still crash |
640 | * with a segfault. */ |
641 | if (PL_scopestack_ix != old_scopestack_ix || cxstack_ix != old_cxstack_ix) |
642 | croak("panic: Devel::DProf inconsistent subroutine return"); |
643 | |
146174a9 |
644 | prof_mark(aTHX_ OP_LEAVESUB); |
645 | g_depth--; |
646 | } |
647 | return; |
583a019e |
648 | } |
649 | |
0626a780 |
650 | XS(XS_DB_goto); |
583a019e |
651 | XS(XS_DB_goto) |
652 | { |
146174a9 |
653 | #ifdef PERL_IMPLICIT_CONTEXT |
654 | if (g_THX == aTHX) |
655 | #endif |
656 | { |
657 | prof_mark(aTHX_ OP_GOTO); |
583a019e |
658 | return; |
146174a9 |
659 | } |
583a019e |
660 | } |
661 | |
662 | #endif /* for_real */ |
663 | |
664 | #ifdef testing |
665 | |
666 | MODULE = Devel::DProf PACKAGE = DB |
667 | |
668 | void |
669 | sub(...) |
146174a9 |
670 | PPCODE: |
671 | { |
583a019e |
672 | dORIGMARK; |
0626a780 |
673 | HV * const oldstash = PL_curstash; |
674 | SV * const Sub = GvSV(PL_DBsub); /* name of current sub */ |
583a019e |
675 | /* SP -= items; added by xsubpp */ |
94277a97 |
676 | DBG_SUB_NOTIFY(Sub); |
583a019e |
677 | |
146174a9 |
678 | sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ |
583a019e |
679 | |
146174a9 |
680 | prof_mark(aTHX_ OP_ENTERSUB); |
681 | PUSHMARK(ORIGMARK); |
583a019e |
682 | |
146174a9 |
683 | PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */ |
d781cccd |
684 | perl_call_sv(Sub, GIMME_V); |
146174a9 |
685 | PL_curstash = oldstash; |
583a019e |
686 | |
146174a9 |
687 | prof_mark(aTHX_ OP_LEAVESUB); |
583a019e |
688 | SPAGAIN; |
689 | /* PUTBACK; added by xsubpp */ |
146174a9 |
690 | } |
583a019e |
691 | |
692 | #endif /* testing */ |
693 | |
694 | MODULE = Devel::DProf PACKAGE = Devel::DProf |
695 | |
696 | void |
697 | END() |
146174a9 |
698 | PPCODE: |
699 | { |
700 | if (PL_DBsub) { |
701 | /* maybe the process forked--we want only |
702 | * the parent's profile. |
703 | */ |
704 | if ( |
705 | #ifdef PERL_IMPLICIT_CONTEXT |
706 | g_THX == aTHX && |
707 | #endif |
708 | g_prof_pid == (int)getpid()) |
709 | { |
710 | g_rprof_end = Times(&g_prof_end); |
711 | DBG_TIMER_NOTIFY("Profiler timer is off.\n"); |
712 | prof_record(aTHX); |
713 | } |
714 | } |
715 | } |
583a019e |
716 | |
717 | void |
718 | NONESUCH() |
719 | |
720 | BOOT: |
146174a9 |
721 | { |
722 | g_TIMES_LOCATION = 42; |
723 | g_SAVE_STACK = 1<<14; |
724 | g_profstack_max = 128; |
725 | #ifdef PERL_IMPLICIT_CONTEXT |
726 | g_THX = aTHX; |
727 | #endif |
728 | |
583a019e |
729 | /* Before we go anywhere make sure we were invoked |
730 | * properly, else we'll dump core. |
731 | */ |
146174a9 |
732 | if (!PL_DBsub) |
733 | croak("DProf: run perl with -d to use DProf.\n"); |
583a019e |
734 | |
735 | /* When we hook up the XS DB::sub we'll be redefining |
736 | * the DB::sub from the PM file. Turn off warnings |
737 | * while we do this. |
738 | */ |
739 | { |
0626a780 |
740 | const bool warn_tmp = PL_dowarn; |
146174a9 |
741 | PL_dowarn = 0; |
742 | newXS("DB::sub", XS_DB_sub, file); |
743 | newXS("DB::goto", XS_DB_goto, file); |
744 | PL_dowarn = warn_tmp; |
583a019e |
745 | } |
746 | |
146174a9 |
747 | sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ |
583a019e |
748 | |
749 | { |
0626a780 |
750 | const char *buffer = getenv("PERL_DPROF_BUFFER"); |
583a019e |
751 | |
752 | if (buffer) { |
146174a9 |
753 | g_SAVE_STACK = atoi(buffer); |
583a019e |
754 | } |
755 | |
756 | buffer = getenv("PERL_DPROF_TICKS"); |
757 | |
758 | if (buffer) { |
146174a9 |
759 | g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */ |
760 | } |
761 | else { |
762 | g_dprof_ticks = HZ; |
583a019e |
763 | } |
583a019e |
764 | |
146174a9 |
765 | buffer = getenv("PERL_DPROF_OUT_FILE_NAME"); |
766 | g_out_file_name = savepv(buffer ? buffer : "tmon.out"); |
767 | } |
583a019e |
768 | |
146174a9 |
769 | if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL) |
770 | croak("DProf: unable to write '%s', errno = %d\n", |
771 | g_out_file_name, errno); |
583a019e |
772 | |
146174a9 |
773 | g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO; |
774 | g_cv_hash = newHV(); |
7619c85e |
775 | g_key_hash = newSV(256); |
146174a9 |
776 | g_prof_pid = (int)getpid(); |
583a019e |
777 | |
a02a5408 |
778 | Newx(g_profstack, g_profstack_max, PROFANY); |
146174a9 |
779 | prof_recordheader(aTHX); |
583a019e |
780 | DBG_TIMER_NOTIFY("Profiler timer is on.\n"); |
146174a9 |
781 | g_orealtime = g_rprof_start = Times(&g_prof_start); |
782 | g_otms_utime = g_prof_start.tms_utime; |
783 | g_otms_stime = g_prof_start.tms_stime; |
784 | PL_perldb = g_default_perldb; |
785 | } |