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