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