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