dprof.xs

source of perl for linux application,

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

/* define DBG_SUB to cause a warning on each subroutine entry. */
/*#define DBG_SUB 1      */

/* define DBG_TIMER to cause a warning when the timer is turned on and off. */
/*#define DBG_TIMER 1  */

#ifdef DEBUGGING
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif

static CV *
db_get_cv(pTHX_ SV *sv)
{
	CV *cv;

	if (SvIOK(sv)) {			/* if (PERLDB_SUB_NN) { */
	    cv = INT2PTR(CV*,SvIVX(sv));
	} else {
	    if (SvPOK(sv)) {
		cv = get_cv(SvPVX_const(sv), TRUE);
	    } else if (SvROK(sv)) {
		cv = (CV*)SvRV(sv);
	    } else {
		croak("DProf: don't know what subroutine to profile");
	    }
	}
	return cv;
}

#ifdef DBG_SUB
#  define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(aTHX_ A)
void
dprof_dbg_sub_notify(pTHX_ SV *Sub) {
    CV * const cv = db_get_cv(aTHX_ Sub);
    GV * const gv = cv ? CvGV(cv) : NULL;
    if (cv && gv) {
	warn("XS DBsub(%s::%s)\n",
	     ((GvSTASH(gv) && HvNAME_get(GvSTASH(gv))) ?
	      HvNAME_get(GvSTASH(gv)) : "(null)"),
	     GvNAME(gv));
    } else {
	warn("XS DBsub(unknown) at %x", Sub);
    }
}
#else
#  define DBG_SUB_NOTIFY(A)  /* 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() */
#  include <lib$routines.h>
#  define Times(ptr) (dprof_times(aTHX_ ptr))
#  define NEEDS_DPROF_TIMES
#else
#  ifdef BSDish
#    define Times(ptr) (dprof_times(aTHX_ ptr))
#    define NEEDS_DPROF_TIMES
#    define HZ 1000000
#    define DPROF_HZ HZ
#  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 NEEDS_DPROF_TIMES
#      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
#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 */
        const char *name;
        U32 id;
        opcode ptype;
};

typedef union prof_any PROFANY;

typedef struct {
    U32		dprof_ticks;
    const char*	out_file_name;	/* output file (defaults to tmon.out) */
    PerlIO*	fp;		/* pointer to tmon.out file */
    Off_t	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;	/* cache of CV to identifier mappings */
    SV*		key_hash;	/* key for cv_hash */
    U32		total;
    U32		lastid;
    U32		default_perldb;
    UV		depth;
#ifdef OS2
    ULONG	frequ;
    long long	start_cnt;
#endif
#ifdef PERL_IMPLICIT_CONTEXT
    PerlInterpreter *my_perl;
#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_key_hash		g_prof_state.key_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.my_perl
#endif
#ifdef OS2
#  define g_frequ		g_prof_state.frequ
#  define g_start_cnt		g_prof_state.start_cnt
#endif

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

    if (CheckOSError(DosTmrQueryTime(&cnt)))
	    croak("DosTmrQueryTime: %s", SvPV_nolen(perl_get_sv("!",TRUE)));
    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 */
#    ifdef BSDish
#      include <sys/resource.h>
    struct rusage ru;
    struct timeval tv;
    /* Measure offset from start time to avoid overflow  */
    static struct timeval tv0 = { 0, 0 };

    if (!tv0.tv_sec)
        if (gettimeofday(&tv0, NULL) < 0)
            croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",TRUE)));
    
    if (getrusage(0, &ru) < 0)
        croak("getrusage: %s", SvPV_nolen_const(perl_get_sv("!",TRUE)));

    if (gettimeofday(&tv, NULL) < 0)
        croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",TRUE)));

    t->tms_stime = DPROF_HZ * ru.ru_stime.tv_sec + ru.ru_stime.tv_usec;
    t->tms_utime = DPROF_HZ * ru.ru_utime.tv_sec + ru.ru_utime.tv_usec;

    if (tv.tv_usec < tv0.tv_usec)
        tv.tv_sec--, tv.tv_usec += DPROF_HZ;

    return DPROF_HZ * (tv.tv_sec - tv0.tv_sec) + tv.tv_usec - tv0.tv_usec;
#    else  /* !VMS && !OS2 && !BSD! */
    return times(t);
#    endif
#  endif
#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, const char *pname, const 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 realtime2;

    const clock_t realtime1 = Times(&t1);

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

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

	    prof_dumps(aTHX_ id, pname, gname);
	}
	else {
	    const 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
set_cv_key(pTHX_ CV *cv, const char *pname, const char *gname)
{
	SvGROW(g_key_hash, sizeof(CV**) + strlen(pname) + strlen(gname) + 3);
	sv_setpvn(g_key_hash, (char*)&cv, sizeof(CV**));
	sv_catpv(g_key_hash, pname);
	sv_catpv(g_key_hash, "::");
	sv_catpv(g_key_hash, gname);
}

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

    if (g_SAVE_STACK) {
	if (g_profstack_ix + 10 > 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) {
	    ASSERT(g_profstack_ix + 4 <= g_profstack_max);
	    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);
	    }
	}