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