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