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