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