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