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