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