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