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