dprof.xs

source of perl for linux application,

	g_orealtime = realtime;
	g_otms_stime = t.tms_stime;
	g_otms_utime = t.tms_utime;
    }

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

	CV * const cv = db_get_cv(aTHX_ Sub);
	GV * const gv = CvGV(cv);
	if (isGV_with_GP(gv)) {
	    pname = GvSTASH(gv) ? HvNAME_get(GvSTASH(gv)) : NULL;
	    pname = pname ? pname : (char *) "(null)";
	    gname = GvNAME(gv);
	} else {
	    gname = pname = (char *) "(null)";
	}

	set_cv_key(aTHX_ cv, pname, gname);
	svp = hv_fetch(g_cv_hash, SvPVX_const(g_key_hash), SvCUR(g_key_hash), TRUE);
	if (!SvOK(*svp)) {
	    sv_setiv(*svp, id = ++g_lastid);
	    if (CvXSUB(cv) == XS_Devel__DProf_END)
		return;
	    if (g_SAVE_STACK) { /* Store it for later recording  -JH */
		ASSERT(g_profstack_ix + 4 <= g_profstack_max);
		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 */
	ASSERT(g_profstack_ix + 2 <= g_profstack_max);
	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)
{
    CV * const cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
    HV * const oldstash = PL_curstash;
    struct tms t1, t2;
    const U32 ototal = g_total;
    const U32 ostack = g_SAVE_STACK;
    const U32 operldb = PL_perldb;
    int k = 0;

    clock_t realtime1 = Times(&t1);
    clock_t realtime2 = 0;

    g_SAVE_STACK = 1000000;

    while (k < 2) {
	int 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) {
	    int 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 */

    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)
{
    const U32 need_depth = PTR2UV(foo);
    if (need_depth != g_depth) {
	if (need_depth > g_depth) {
	    warn("garbled call depth when profiling");
	}
	else {
	    IV 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);
XS(XS_DB_sub)
{
    dMARK;
    dORIGMARK;
    SV * const 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((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
    }
    else
#endif
    {
	HV * const oldstash = PL_curstash;
	const I32 old_scopestack_ix = PL_scopestack_ix;
	const I32 old_cxstack_ix = cxstack_ix;

        DBG_SUB_NOTIFY(Sub);

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

        prof_mark(aTHX_ OP_ENTERSUB);
        PUSHMARK(ORIGMARK);
        perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
        PL_curstash = oldstash;

	/* Make sure we are on the same context and scope as before the call
	 * to the sub. If the called sub was exited via a goto, next or
	 * last then this will try to croak(), however perl may still crash
	 * with a segfault. */
	if (PL_scopestack_ix != old_scopestack_ix || cxstack_ix != old_cxstack_ix)
	    croak("panic: Devel::DProf inconsistent subroutine return");

        prof_mark(aTHX_ OP_LEAVESUB);
	g_depth--;
    }
    return;
}

XS(XS_DB_goto);
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 * const oldstash = PL_curstash;
		SV * const Sub = GvSV(PL_DBsub);	/* name of current sub */
                /* SP -= items;  added by xsubpp */
                DBG_SUB_NOTIFY(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_V);
                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.
         */
        {
	    const bool 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 */

	{
	    const 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_key_hash = newSV(256);
        g_prof_pid = (int)getpid();

	Newx(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;
    }