[p5sagit/p5-mst-13.2.git] / ext / Devel / DProf / DProf.xs

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* For older Perls */
#ifndef dTHR
#  define dTHR int dummy_thr
#endif	/* dTHR */ 

/*#define DBG_SUB 1      */
/*#define DBG_TIMER 1    */

#ifdef DBG_SUB
#  define DBG_SUB_NOTIFY(A,B) warn(A, B)
#else
#  define DBG_SUB_NOTIFY(A,B)  /* nothing */
#endif

#ifdef DBG_TIMER
#  define DBG_TIMER_NOTIFY(A) warn(A)
#else
#  define DBG_TIMER_NOTIFY(A)  /* nothing */
#endif

/* HZ == clock ticks per second */
#ifdef VMS
#  define HZ ((I32)CLK_TCK)
#  define DPROF_HZ HZ
#  include <starlet.h>  /* prototype for sys$gettim() */
#  define Times(ptr) (dprof_times(aTHX_ ptr))
#else
#  ifndef HZ
#    ifdef CLK_TCK
#      define HZ ((I32)CLK_TCK)
#    else
#      define HZ 60
#    endif
#  endif
#  ifdef OS2				/* times() has significant overhead */
#    define Times(ptr) (dprof_times(aTHX_ ptr))
#    define INCL_DOSPROFILE
#    define INCL_DOSERRORS
#    include <os2.h>
#    define toLongLong(arg) (*(long long*)&(arg))
#    define DPROF_HZ g_dprof_ticks
#  else
#    define Times(ptr) (times(ptr))
#    define DPROF_HZ HZ
#  endif 
#endif

XS(XS_Devel__DProf_END);        /* used by prof_mark() */

/* Everything is built on times(2).  See its manpage for a description
 * of the timings.
 */

union prof_any {
        clock_t tms_utime;  /* cpu time spent in user space */
        clock_t tms_stime;  /* cpu time spent in system */
        clock_t realtime;   /* elapsed real time, in ticks */
        char *name;
        U32 id;
        opcode ptype;
};

typedef union prof_any PROFANY;

typedef struct {
    U32		dprof_ticks;
    char*	out_file_name;	/* output file (defaults to tmon.out) */
    PerlIO*	fp;		/* pointer to tmon.out file */
    long	TIMES_LOCATION;	/* Where in the file to store the time totals */
    int		SAVE_STACK;	/* How much data to buffer until end of run */
    int		prof_pid;	/* pid of profiled process */
    struct tms	prof_start;
    struct tms	prof_end;
    clock_t	rprof_start;	/* elapsed real time ticks */
    clock_t	rprof_end;
    clock_t	wprof_u;
    clock_t	wprof_s;
    clock_t	wprof_r;
    clock_t	otms_utime;
    clock_t	otms_stime;
    clock_t	orealtime;
    PROFANY*	profstack;
    int		profstack_max;
    int		profstack_ix;
    HV*		cv_hash;
    U32		total;
    U32		lastid;
    U32		default_perldb;
    U32		depth;
#ifdef OS2
    ULONG	frequ;
    long long	start_cnt;
#endif
#ifdef PERL_IMPLICIT_CONTEXT
#  define register
    pTHX;
#  undef register
#endif
} prof_state_t;

prof_state_t g_prof_state;

#define g_dprof_ticks		g_prof_state.dprof_ticks
#define g_out_file_name		g_prof_state.out_file_name
#define g_fp			g_prof_state.fp
#define g_TIMES_LOCATION	g_prof_state.TIMES_LOCATION
#define g_SAVE_STACK		g_prof_state.SAVE_STACK
#define g_prof_pid		g_prof_state.prof_pid
#define g_prof_start		g_prof_state.prof_start
#define g_prof_end		g_prof_state.prof_end
#define g_rprof_start		g_prof_state.rprof_start
#define g_rprof_end		g_prof_state.rprof_end
#define g_wprof_u		g_prof_state.wprof_u
#define g_wprof_s		g_prof_state.wprof_s
#define g_wprof_r		g_prof_state.wprof_r
#define g_otms_utime		g_prof_state.otms_utime
#define g_otms_stime		g_prof_state.otms_stime
#define g_orealtime		g_prof_state.orealtime
#define g_profstack		g_prof_state.profstack
#define g_profstack_max		g_prof_state.profstack_max
#define g_profstack_ix		g_prof_state.profstack_ix
#define g_cv_hash		g_prof_state.cv_hash
#define g_total			g_prof_state.total
#define g_lastid		g_prof_state.lastid
#define g_default_perldb	g_prof_state.default_perldb
#define g_depth			g_prof_state.depth
#ifdef PERL_IMPLICIT_CONTEXT
#  define g_THX			g_prof_state.aTHX
#endif
#ifdef OS2
#  define g_frequ		g_prof_state.frequ
#  define g_start_cnt		g_prof_state.start_cnt
#endif

clock_t
dprof_times(pTHX_ struct tms *t)
{
#ifdef OS2
    ULONG rc;
    QWORD cnt;
    STRLEN n_a;
    
    if (!g_frequ) {
	if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
	    croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a));
	else
	    g_frequ = g_frequ/DPROF_HZ;	/* count per tick */
	if (CheckOSError(DosTmrQueryTime(&cnt)))
	    croak("DosTmrQueryTime: %s",
		  SvPV(perl_get_sv("!",TRUE), n_a));
	g_start_cnt = toLongLong(cnt);
    }

    if (CheckOSError(DosTmrQueryTime(&cnt)))
	    croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a));
    t->tms_stime = 0;
    return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
#else		/* !OS2 */
#  ifdef VMS
    clock_t retval;
    /* Get wall time and convert to 10 ms intervals to
     * produce the return value dprof expects */
#    if defined(__DECC) && defined (__ALPHA)
#      include <ints.h>
    uint64 vmstime;
    _ckvmssts(sys$gettim(&vmstime));
    vmstime /= 100000;
    retval = vmstime & 0x7fffffff;
#    else
    /* (Older hw or ccs don't have an atomic 64-bit type, so we
     * juggle 32-bit ints (and a float) to produce a time_t result
     * with minimal loss of information.) */
    long int vmstime[2],remainder,divisor = 100000;
    _ckvmssts(sys$gettim((unsigned long int *)vmstime));
    vmstime[1] &= 0x7fff;  /* prevent overflow in EDIV */
    _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
#    endif
    /* Fill in the struct tms using the CRTL routine . . .*/
    times((tbuffer_t *)t);
    return (clock_t) retval;
#  else		/* !VMS && !OS2 */
    return times(t);
#  endif
#endif
}

static void
prof_dumpa(pTHX_ opcode ptype, U32 id)
{
    if (ptype == OP_LEAVESUB) {
	PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id);
    }
    else if(ptype == OP_ENTERSUB) {
	PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id);
    }
    else if(ptype == OP_GOTO) {
	PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id);
    }
    else if(ptype == OP_DIE) {
	PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id);
    }
    else {
	PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype);
    }
}   

static void
prof_dumps(pTHX_ U32 id, char *pname, char *gname)
{
    PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
}   

static void
prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
{
    PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
}   

static void
prof_dump_until(pTHX_ long ix)
{
    long base = 0;
    struct tms t1, t2;
    clock_t realtime1, realtime2;

    realtime1 = Times(&t1);

    while (base < ix) {
	opcode ptype = g_profstack[base++].ptype;
	if (ptype == OP_TIME) {
	    long tms_utime = g_profstack[base++].tms_utime;
	    long tms_stime = g_profstack[base++].tms_stime;
	    long realtime = g_profstack[base++].realtime;

	    prof_dumpt(aTHX_ tms_utime, tms_stime, realtime);
	}
	else if (ptype == OP_GV) {
	    U32 id = g_profstack[base++].id;
	    char *pname = g_profstack[base++].name;
	    char *gname = g_profstack[base++].name;

	    prof_dumps(aTHX_ id, pname, gname);
	}
	else {
	    U32 id = g_profstack[base++].id;
	    prof_dumpa(aTHX_ ptype, id);
	}
    }
    PerlIO_flush(g_fp);
    realtime2 = Times(&t2);
    if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
	|| t1.tms_stime != t2.tms_stime) {
	g_wprof_r += realtime2 - realtime1;
	g_wprof_u += t2.tms_utime - t1.tms_utime;
	g_wprof_s += t2.tms_stime - t1.tms_stime;

	PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
	PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", 
		      /* The (IV) casts are one possibility:
		       * the Painfully Correct Way would be to
		       * have Clock_t_f. */
		      (IV)(t2.tms_utime - t1.tms_utime),
		      (IV)(t2.tms_stime - t1.tms_stime), 
		      (IV)(realtime2 - realtime1));
	PerlIO_printf(g_fp,"- & Devel::DProf::write\n");
	g_otms_utime = t2.tms_utime;
	g_otms_stime = t2.tms_stime;
	g_orealtime = realtime2;
	PerlIO_flush(g_fp);
    }
}

static void
prof_mark(pTHX_ opcode ptype)
{
    struct tms t;
    clock_t realtime, rdelta, udelta, sdelta;
    char *name, *pv;
    char *hvname;
    STRLEN len;
    SV *sv;
    U32 id;
    SV *Sub = GvSV(PL_DBsub);	/* name of current sub */

    if (g_SAVE_STACK) {
	if (g_profstack_ix + 5 > g_profstack_max) {
		g_profstack_max = g_profstack_max * 3 / 2;
		Renew(g_profstack, g_profstack_max, PROFANY);
	}
    }

    realtime = Times(&t);
    rdelta = realtime - g_orealtime;
    udelta = t.tms_utime - g_otms_utime;
    sdelta = t.tms_stime - g_otms_stime;
    if (rdelta || udelta || sdelta) {
	if (g_SAVE_STACK) {
	    g_profstack[g_profstack_ix++].ptype = OP_TIME;
	    g_profstack[g_profstack_ix++].tms_utime = udelta;
	    g_profstack[g_profstack_ix++].tms_stime = sdelta;
	    g_profstack[g_profstack_ix++].realtime = rdelta;
	}
	else { /* Write it to disk now so's not to eat up core */
	    if (g_prof_pid == (int)getpid()) {
		prof_dumpt(aTHX_ udelta, sdelta, rdelta);
		PerlIO_flush(g_fp);
	    }
	}
	g_orealtime = realtime;
	g_otms_stime = t.tms_stime;
	g_otms_utime = t.tms_utime;
    }

    {
	SV **svp;
	char *gname, *pname;
	CV *cv;

	cv = INT2PTR(CV*,SvIVX(Sub));
	svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE);
	if (!SvOK(*svp)) {
	    GV *gv = CvGV(cv);
		
	    sv_setiv(*svp, id = ++g_lastid);
	    pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) 
		     ? HvNAME(GvSTASH(gv)) 
		     : "(null)");
	    gname = GvNAME(gv);
	    if (CvXSUB(cv) == XS_Devel__DProf_END)
		return;
	    if (g_SAVE_STACK) { /* Store it for later recording  -JH */
		g_profstack[g_profstack_ix++].ptype = OP_GV;
		g_profstack[g_profstack_ix++].id = id;
		g_profstack[g_profstack_ix++].name = pname;
		g_profstack[g_profstack_ix++].name = gname;
	    }
	    else { /* Write it to disk now so's not to eat up core */
		/* Only record the parent's info */
		if (g_prof_pid == (int)getpid()) {
		    prof_dumps(aTHX_ id, pname, gname);
		    PerlIO_flush(g_fp);
		}
		else
		    PL_perldb = 0;		/* Do not debug the kid. */
	    }
	}
	else {
	    id = SvIV(*svp);
	}
    }

    g_total++;
    if (g_SAVE_STACK) { /* Store it for later recording  -JH */
	g_profstack[g_profstack_ix++].ptype = ptype;
	g_profstack[g_profstack_ix++].id = id;

	/* Only record the parent's info */
	if (g_SAVE_STACK < g_profstack_ix) {
	    if (g_prof_pid == (int)getpid())
		prof_dump_until(aTHX_ g_profstack_ix);
	    else
		PL_perldb = 0;		/* Do not debug the kid. */
	    g_profstack_ix = 0;
	}
    }
    else { /* Write it to disk now so's not to eat up core */

	/* Only record the parent's info */
	if (g_prof_pid == (int)getpid()) {
	    prof_dumpa(aTHX_ ptype, id);
	    PerlIO_flush(g_fp);
	}
	else
	    PL_perldb = 0;		/* Do not debug the kid. */
    }
}

#ifdef PL_NEEDED
#  define defstash PL_defstash
#endif

/* Counts overhead of prof_mark and extra XS call. */
static void
test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
{
    dTHR;
    CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
    int i, j, k = 0;
    HV *oldstash = PL_curstash;
    struct tms t1, t2;
    clock_t realtime1, realtime2;
    U32 ototal = g_total;
    U32 ostack = g_SAVE_STACK;
    U32 operldb = PL_perldb;

    g_SAVE_STACK = 1000000;
    realtime1 = Times(&t1);
    
    while (k < 2) {
	i = 0;
	    /* Disable debugging of perl_call_sv on second pass: */
	PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
	PL_perldb = g_default_perldb;
	while (++i <= 100) {
	    j = 0;
	    g_profstack_ix = 0;		/* Do not let the stack grow */
	    while (++j <= 100) {
/* 		prof_mark(aTHX_ OP_ENTERSUB); */

		PUSHMARK(PL_stack_sp);
		perl_call_sv((SV*)cv, G_SCALAR);
		PL_stack_sp--;
/* 		prof_mark(aTHX_ OP_LEAVESUB); */
	    }
	}
	PL_curstash = oldstash;
	if (k == 0) {			/* Put time with debugging */
	    realtime2 = Times(&t2);
	    *r = realtime2 - realtime1;
	    *u = t2.tms_utime - t1.tms_utime;
	    *s = t2.tms_stime - t1.tms_stime;
	}
	else {				/* Subtract time without debug */
	    realtime1 = Times(&t1);
	    *r -= realtime1 - realtime2;
	    *u -= t1.tms_utime - t2.tms_utime;
	    *s -= t1.tms_stime - t2.tms_stime;	    
	}
	k++;
    }
    g_total = ototal;
    g_SAVE_STACK = ostack;
    PL_perldb = operldb;
}

static void
prof_recordheader(pTHX)
{
    clock_t r, u, s;

    /* g_fp is opened in the BOOT section */
    PerlIO_printf(g_fp, "#fOrTyTwO\n");
    PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ);
    PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION);
    PerlIO_printf(g_fp, "# All values are given in HZ\n");
    test_time(aTHX_ &r, &u, &s);
    PerlIO_printf(g_fp,
		  "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
		  /* The (IV) casts are one possibility:
		   * the Painfully Correct Way would be to
		   * have Clock_t_f. */
		  (IV)u, (IV)s, (IV)r);
    PerlIO_printf(g_fp, "$over_tests=10000;\n");

    g_TIMES_LOCATION = PerlIO_tell(g_fp);

    /* Pad with whitespace. */
    /* This should be enough even for very large numbers. */
    PerlIO_printf(g_fp, "%*s\n", 240 , "");

    PerlIO_printf(g_fp, "\n");
    PerlIO_printf(g_fp, "PART2\n");

    PerlIO_flush(g_fp);
}

static void
prof_record(pTHX)
{
    /* g_fp is opened in the BOOT section */

    /* Now that we know the runtimes, fill them in at the recorded
       location -JH */

    clock_t r, u, s;

    if (g_SAVE_STACK) {
	prof_dump_until(aTHX_ g_profstack_ix);
    }
    PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET);
    /* Write into reserved 240 bytes: */
    PerlIO_printf(g_fp,
		  "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
		  /* The (IV) casts are one possibility:
		   * the Painfully Correct Way would be to
		   * have Clock_t_f. */
		  (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u),
		  (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s),
		  (IV)(g_rprof_end-g_rprof_start-g_wprof_r));
    PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total);
    
    PerlIO_close(g_fp);
}

#define NONESUCH()

static void
check_depth(pTHX_ void *foo)
{
    U32 need_depth = (U32)foo;
    if (need_depth != g_depth) {
	if (need_depth > g_depth) {
	    warn("garbled call depth when profiling");
	}
	else {
	    I32 marks = g_depth - need_depth;

/* 	    warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
	    while (marks--) {
		prof_mark(aTHX_ OP_DIE);
	    }
	    g_depth = need_depth;
	}
    }
}

#define for_real
#ifdef for_real

XS(XS_DB_sub)
{
    dXSARGS;
    dORIGMARK;
    SV *Sub = GvSV(PL_DBsub);		/* name of current sub */

#ifdef PERL_IMPLICIT_CONTEXT
    /* profile only the interpreter that loaded us */
    if (g_THX != aTHX) {
        PUSHMARK(ORIGMARK);
        perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
    }
    else
#endif
    {
	HV *oldstash = PL_curstash;

        DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));

	SAVEDESTRUCTOR_X(check_depth, (void*)g_depth);
	g_depth++;

        prof_mark(aTHX_ OP_ENTERSUB);
        PUSHMARK(ORIGMARK);
        perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
        prof_mark(aTHX_ OP_LEAVESUB);
	g_depth--;
    }
    return;
}

XS(XS_DB_goto)
{
#ifdef PERL_IMPLICIT_CONTEXT
    if (g_THX == aTHX)
#endif
    {
        prof_mark(aTHX_ OP_GOTO);
        return;
    }
}

#endif /* for_real */

#ifdef testing

        MODULE = Devel::DProf           PACKAGE = DB

        void
        sub(...)
	PPCODE:
	    {
                dORIGMARK;
                HV *oldstash = PL_curstash;
		SV *Sub = GvSV(PL_DBsub);	/* name of current sub */
                /* SP -= items;  added by xsubpp */
                DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));

                sv_setiv(PL_DBsingle, 0);	/* disable DB single-stepping */

                prof_mark(aTHX_ OP_ENTERSUB);
                PUSHMARK(ORIGMARK);

                PL_curstash = PL_debstash;	/* To disable debugging of perl_call_sv */
                perl_call_sv(Sub, GIMME);
                PL_curstash = oldstash;

                prof_mark(aTHX_ OP_LEAVESUB);
                SPAGAIN;
                /* PUTBACK;  added by xsubpp */
	    }

#endif /* testing */

MODULE = Devel::DProf           PACKAGE = Devel::DProf

void
END()
PPCODE:
    {
        if (PL_DBsub) {
	    /* maybe the process forked--we want only
	     * the parent's profile.
	     */
	    if (
#ifdef PERL_IMPLICIT_CONTEXT
		g_THX == aTHX &&
#endif
		g_prof_pid == (int)getpid())
	    {
		g_rprof_end = Times(&g_prof_end);
		DBG_TIMER_NOTIFY("Profiler timer is off.\n");
		prof_record(aTHX);
	    }
	}
    }

void
NONESUCH()

BOOT:
    {
	g_TIMES_LOCATION = 42;
	g_SAVE_STACK = 1<<14;
    	g_profstack_max = 128;
#ifdef PERL_IMPLICIT_CONTEXT
	g_THX = aTHX;
#endif

        /* Before we go anywhere make sure we were invoked
         * properly, else we'll dump core.
         */
        if (!PL_DBsub)
	    croak("DProf: run perl with -d to use DProf.\n");

        /* When we hook up the XS DB::sub we'll be redefining
         * the DB::sub from the PM file.  Turn off warnings
         * while we do this.
         */
        {
	    I32 warn_tmp = PL_dowarn;
	    PL_dowarn = 0;
	    newXS("DB::sub", XS_DB_sub, file);
	    newXS("DB::goto", XS_DB_goto, file);
	    PL_dowarn = warn_tmp;
        }

        sv_setiv(PL_DBsingle, 0);	/* disable DB single-stepping */

	{
	    char *buffer = getenv("PERL_DPROF_BUFFER");

	    if (buffer) {
		g_SAVE_STACK = atoi(buffer);
	    }

	    buffer = getenv("PERL_DPROF_TICKS");

	    if (buffer) {
		g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
	    }
	    else {
		g_dprof_ticks = HZ;
	    }

	    buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
	    g_out_file_name = savepv(buffer ? buffer : "tmon.out");
	}

        if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL)
	    croak("DProf: unable to write '%s', errno = %d\n",
		  g_out_file_name, errno);

	g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
	g_cv_hash = newHV();
        g_prof_pid = (int)getpid();

	New(0, g_profstack, g_profstack_max, PROFANY);
        prof_recordheader(aTHX);
        DBG_TIMER_NOTIFY("Profiler timer is on.\n");
	g_orealtime = g_rprof_start = Times(&g_prof_start);
	g_otms_utime = g_prof_start.tms_utime;
	g_otms_stime = g_prof_start.tms_stime;
	PL_perldb = g_default_perldb;
    }
Commit	Line	Data
f2abf2f9	1	#define PERL_NO_GET_CONTEXT
583a019e	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
7399586d	11	/#define DBG_SUB 1 /
7399586d	12	/#define DBG_TIMER 1 /
583a019e	13
583a019e	14	#ifdef DBG_SUB
f2abf2f9	15	# define DBG_SUB_NOTIFY(A,B) warn(A, B)
583a019e	16	#else
	17	# define DBG_SUB_NOTIFY(A,B) /* nothing */
	18	#endif
	19
	20	#ifdef DBG_TIMER
f2abf2f9	21	# define DBG_TIMER_NOTIFY(A) warn(A)
583a019e	22	#else
	23	# define DBG_TIMER_NOTIFY(A) /* nothing */
	24	#endif
	25
583a019e	26	/* HZ == clock ticks per second */
583a019e	27	#ifdef VMS
552e38a9	28	# define HZ ((I32)CLK_TCK)
583a019e	29	# define DPROF_HZ HZ
583a019e	30	# include <starlet.h> /* prototype for sys$gettim() */
f2abf2f9	31	# define Times(ptr) (dprof_times(aTHX_ ptr))
583a019e	32	#else
	33	# ifndef HZ
	34	# ifdef CLK_TCK
552e38a9	35	# define HZ ((I32)CLK_TCK)
583a019e	36	# else
	37	# define HZ 60
	38	# endif
	39	# endif
	40	# ifdef OS2 /* times() has significant overhead */
f2abf2f9	41	# define Times(ptr) (dprof_times(aTHX_ ptr))
583a019e	42	# define INCL_DOSPROFILE
	43	# define INCL_DOSERRORS
	44	# include <os2.h>
	45	# define toLongLong(arg) ((long long)&(arg))
f2abf2f9	46	# define DPROF_HZ g_dprof_ticks
583a019e	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
583a019e	55	/* Everything is built on times(2). See its manpage for a description
	56	* of the timings.
	57	*/
	58
583a019e	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
f2abf2f9	70	typedef struct {
f2abf2f9	71	U32 dprof_ticks;
34445a8a	72	char* out_file_name; /* output file (defaults to tmon.out) */
f2abf2f9	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
12a98ad5	100	# define register
f2abf2f9	101	pTHX;
12a98ad5	102	# undef register
f2abf2f9	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
34445a8a	109	#define g_out_file_name g_prof_state.out_file_name
f2abf2f9	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
583a019e	139
f2abf2f9	140	clock_t
f2abf2f9	141	dprof_times(pTHX_ struct tms *t)
583a019e	142	{
f2abf2f9	143	#ifdef OS2
	144	ULONG rc;
	145	QWORD cnt;
6b5cb48c	146	STRLEN n_a;
f2abf2f9	147
	148	if (!g_frequ) {
	149	if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
6b5cb48c	150	croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a));
f2abf2f9	151	else
	152	g_frequ = g_frequ/DPROF_HZ; /* count per tick */
	153	if (CheckOSError(DosTmrQueryTime(&cnt)))
	154	croak("DosTmrQueryTime: %s",
6b5cb48c	155	SvPV(perl_get_sv("!",TRUE), n_a));
f2abf2f9	156	g_start_cnt = toLongLong(cnt);
583a019e	157	}
f2abf2f9	158
f2abf2f9	159	if (CheckOSError(DosTmrQueryTime(&cnt)))
6b5cb48c	160	croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a));
f2abf2f9	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	}
583a019e	191
583a019e	192	static void
f2abf2f9	193	prof_dumpa(pTHX_ opcode ptype, U32 id)
583a019e	194	{
f2abf2f9	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);
583a019e	209	}
	210	}
	211
	212	static void
f2abf2f9	213	prof_dumps(pTHX_ U32 id, char pname, char gname)
583a019e	214	{
f2abf2f9	215	PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
583a019e	216	}
583a019e	217
583a019e	218	static void
f2abf2f9	219	prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
583a019e	220	{
f2abf2f9	221	PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
583a019e	222	}
	223
	224	static void
f2abf2f9	225	prof_dump_until(pTHX_ long ix)
583a019e	226	{
	227	long base = 0;
	228	struct tms t1, t2;
	229	clock_t realtime1, realtime2;
	230
	231	realtime1 = Times(&t1);
	232
f2abf2f9	233	while (base < ix) {
f2abf2f9	234	opcode ptype = g_profstack[base++].ptype;
583a019e	235	if (ptype == OP_TIME) {
f2abf2f9	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);
583a019e	252	}
583a019e	253	}
f2abf2f9	254	PerlIO_flush(g_fp);
583a019e	255	realtime2 = Times(&t2);
	256	if (realtime2 != realtime1 \|\| t1.tms_utime != t2.tms_utime
	257	\|\| t1.tms_stime != t2.tms_stime) {
f2abf2f9	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;
583a019e	261
f2abf2f9	262	PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
f2abf2f9	263	PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n",
57b0da17	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));
f2abf2f9	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);
583a019e	275	}
	276	}
	277
583a019e	278	static void
f2abf2f9	279	prof_mark(pTHX_ opcode ptype)
583a019e	280	{
f2abf2f9	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	}
583a019e	296
f2abf2f9	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);
583a019e	312	}
583a019e	313	}
f2abf2f9	314	g_orealtime = realtime;
	315	g_otms_stime = t.tms_stime;
	316	g_otms_utime = t.tms_utime;
	317	}
583a019e	318
f2abf2f9	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);
583a019e	347	}
f2abf2f9	348	else
f2abf2f9	349	PL_perldb = 0; /* Do not debug the kid. */
583a019e	350	}
583a019e	351	}
f2abf2f9	352	else {
	353	id = SvIV(*svp);
	354	}
	355	}
583a019e	356
f2abf2f9	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 */
583a019e	372
f2abf2f9	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	}
583a019e	381	}
583a019e	382
583a019e	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
f2abf2f9	389	test_time(pTHX_ clock_t r, clock_t u, clock_t *s)
583a019e	390	{
	391	dTHR;
	392	CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
	393	int i, j, k = 0;
f2abf2f9	394	HV *oldstash = PL_curstash;
583a019e	395	struct tms t1, t2;
583a019e	396	clock_t realtime1, realtime2;
f2abf2f9	397	U32 ototal = g_total;
	398	U32 ostack = g_SAVE_STACK;
	399	U32 operldb = PL_perldb;
583a019e	400
f2abf2f9	401	g_SAVE_STACK = 1000000;
583a019e	402	realtime1 = Times(&t1);
	403
	404	while (k < 2) {
	405	i = 0;
	406	/* Disable debugging of perl_call_sv on second pass: */
f2abf2f9	407	PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
f2abf2f9	408	PL_perldb = g_default_perldb;
583a019e	409	while (++i <= 100) {
583a019e	410	j = 0;
f2abf2f9	411	g_profstack_ix = 0; /* Do not let the stack grow */
583a019e	412	while (++j <= 100) {
f2abf2f9	413	/* prof_mark(aTHX_ OP_ENTERSUB); */
583a019e	414
f2abf2f9	415	PUSHMARK(PL_stack_sp);
	416	perl_call_sv((SV*)cv, G_SCALAR);
	417	PL_stack_sp--;
	418	/* prof_mark(aTHX_ OP_LEAVESUB); */
583a019e	419	}
583a019e	420	}
f2abf2f9	421	PL_curstash = oldstash;
583a019e	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;
f2abf2f9	427	}
f2abf2f9	428	else { /* Subtract time without debug */
583a019e	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	}
f2abf2f9	436	g_total = ototal;
	437	g_SAVE_STACK = ostack;
	438	PL_perldb = operldb;
583a019e	439	}
	440
	441	static void
f2abf2f9	442	prof_recordheader(pTHX)
583a019e	443	{
f2abf2f9	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);
583a019e	470	}
	471
	472	static void
f2abf2f9	473	prof_record(pTHX)
583a019e	474	{
f2abf2f9	475	/* g_fp is opened in the BOOT section */
583a019e	476
f2abf2f9	477	/* Now that we know the runtimes, fill them in at the recorded
f2abf2f9	478	location -JH */
583a019e	479
f2abf2f9	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);
583a019e	496
f2abf2f9	497	PerlIO_close(g_fp);
583a019e	498	}
	499
	500	#define NONESUCH()
	501
583a019e	502	static void
d7b9cf63	503	check_depth(pTHX_ void *foo)
583a019e	504	{
583a019e	505	U32 need_depth = (U32)foo;
f2abf2f9	506	if (need_depth != g_depth) {
f2abf2f9	507	if (need_depth > g_depth) {
583a019e	508	warn("garbled call depth when profiling");
f2abf2f9	509	}
	510	else {
	511	I32 marks = g_depth - need_depth;
583a019e	512
f2abf2f9	513	/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
583a019e	514	while (marks--) {
f2abf2f9	515	prof_mark(aTHX_ OP_DIE);
583a019e	516	}
f2abf2f9	517	g_depth = need_depth;
583a019e	518	}
	519	}
	520	}
	521
	522	#define for_real
	523	#ifdef for_real
	524
	525	XS(XS_DB_sub)
	526	{
f2abf2f9	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;
583a019e	541
a5f35447	542	DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
583a019e	543
f2abf2f9	544	SAVEDESTRUCTOR_X(check_depth, (void*)g_depth);
f2abf2f9	545	g_depth++;
583a019e	546
f2abf2f9	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;
583a019e	554	}
	555
	556	XS(XS_DB_goto)
	557	{
f2abf2f9	558	#ifdef PERL_IMPLICIT_CONTEXT
	559	if (g_THX == aTHX)
	560	#endif
	561	{
	562	prof_mark(aTHX_ OP_GOTO);
583a019e	563	return;
f2abf2f9	564	}
583a019e	565	}
	566
	567	#endif /* for_real */
	568
	569	#ifdef testing
	570
	571	MODULE = Devel::DProf PACKAGE = DB
	572
	573	void
	574	sub(...)
f2abf2f9	575	PPCODE:
f2abf2f9	576	{
583a019e	577	dORIGMARK;
f2abf2f9	578	HV *oldstash = PL_curstash;
f2abf2f9	579	SV Sub = GvSV(PL_DBsub); / name of current sub */
583a019e	580	/* SP -= items; added by xsubpp */
a5f35447	581	DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
583a019e	582
f2abf2f9	583	sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
583a019e	584
f2abf2f9	585	prof_mark(aTHX_ OP_ENTERSUB);
f2abf2f9	586	PUSHMARK(ORIGMARK);
583a019e	587
f2abf2f9	588	PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */
	589	perl_call_sv(Sub, GIMME);
	590	PL_curstash = oldstash;
583a019e	591
f2abf2f9	592	prof_mark(aTHX_ OP_LEAVESUB);
583a019e	593	SPAGAIN;
583a019e	594	/* PUTBACK; added by xsubpp */
f2abf2f9	595	}
583a019e	596
	597	#endif /* testing */
	598
	599	MODULE = Devel::DProf PACKAGE = Devel::DProf
	600
	601	void
	602	END()
f2abf2f9	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	}
583a019e	621
	622	void
	623	NONESUCH()
	624
	625	BOOT:
f2abf2f9	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
583a019e	634	/* Before we go anywhere make sure we were invoked
	635	* properly, else we'll dump core.
	636	*/
f2abf2f9	637	if (!PL_DBsub)
f2abf2f9	638	croak("DProf: run perl with -d to use DProf.\n");
583a019e	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	{
f2abf2f9	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;
583a019e	650	}
583a019e	651
f2abf2f9	652	sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
583a019e	653
	654	{
	655	char *buffer = getenv("PERL_DPROF_BUFFER");
	656
	657	if (buffer) {
f2abf2f9	658	g_SAVE_STACK = atoi(buffer);
583a019e	659	}
	660
	661	buffer = getenv("PERL_DPROF_TICKS");
	662
	663	if (buffer) {
f2abf2f9	664	g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
	665	}
	666	else {
	667	g_dprof_ticks = HZ;
583a019e	668	}
34445a8a	669
	670	buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
	671	g_out_file_name = savepv(buffer ? buffer : "tmon.out");
583a019e	672	}
583a019e	673
34445a8a	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);
583a019e	677
f2abf2f9	678	g_default_perldb = PERLDBf_NONAME \| PERLDBf_SUB \| PERLDBf_GOTO;
	679	g_cv_hash = newHV();
	680	g_prof_pid = (int)getpid();
583a019e	681
f2abf2f9	682	New(0, g_profstack, g_profstack_max, PROFANY);
f2abf2f9	683	prof_recordheader(aTHX);
583a019e	684	DBG_TIMER_NOTIFY("Profiler timer is on.\n");
f2abf2f9	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	}