ext/Devel/DProf/DProf.xs

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