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