view release on metacpan or  search on metacpan

DProf.xs  view on Meta::CPAN

    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) {