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

/* XXX DProf could use some cleanups for PERL_IMPLICIT_CONTEXT */

#define PERL_POLLUTE

#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

static U32 dprof_ticks;

/* HZ == clock ticks per second */
#ifdef VMS
#  define HZ ((I32)CLK_TCK)
#  define DPROF_HZ HZ
#  include <starlet.h>  /* prototype for sys$gettim() */
   clock_t dprof_times(struct tms *bufptr) {
        clock_t retval;
	dTHX;
        /* 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 *)bufptr);
        return (clock_t) retval;
   }
#  define Times(ptr) (dprof_times(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(ptr))
#    define INCL_DOSPROFILE
#    define INCL_DOSERRORS
#    include <os2.h>
#    define toLongLong(arg) (*(long long*)&(arg))
#    define DPROF_HZ dprof_ticks

static ULONG frequ;
static long long start_cnt;
clock_t
dprof_times(struct tms *t)
{
    ULONG rc;
    QWORD cnt;
    
    if (!frequ) {
	if (CheckOSError(DosTmrQueryFreq(&frequ)))
	    croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na));
	else
	    frequ = frequ/DPROF_HZ;	/* count per tick */
	if (CheckOSError(DosTmrQueryTime(&cnt)))
	    croak("DosTmrQueryTime: %s",
		  SvPV(perl_get_sv("!",TRUE),na));
	start_cnt = toLongLong(cnt);
    }

    if (CheckOSError(DosTmrQueryTime(&cnt)))
	    croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na));
    t->tms_stime = 0;
    return (t->tms_utime = (toLongLong(cnt) - start_cnt)/frequ);
}
#  else
#    define Times(ptr) (times(ptr))
#    define DPROF_HZ HZ
#  endif 
#endif

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

static PerlIO *fp;      /* pointer to tmon.out file */

/* Added -JH */
static long TIMES_LOCATION=42;/* Where in the file to store the time totals */
static int SAVE_STACK = 1<<14;		/* How much data to buffer until */
					/* end of run */

static int prof_pid;    /* pid of profiled process */

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

static
struct tms      prof_start,
                prof_end;

static
clock_t         rprof_start, /* elapsed real time, in ticks */
                rprof_end,
		wprof_u, wprof_s, wprof_r;

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;

static PROFANY  *profstack;
static int      profstack_max = 128;
static int      profstack_ix = 0;

static void
prof_dump(opcode ptype, char *name)
{
    if(ptype == OP_LEAVESUB){
	PerlIO_printf(fp,"- & %s\n", name );
    } else if(ptype == OP_ENTERSUB) {
	PerlIO_printf(fp,"+ & %s\n", name );
    } else if(ptype == OP_DIE) {
	PerlIO_printf(fp,"/ & %s\n", name );
    } else {
	PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype);
    }
    safefree(name);
}   

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

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

static clock_t otms_utime, otms_stime, orealtime;

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

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

    realtime1 = Times(&t1);

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

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

	    prof_dumps(id, pname, gname);
	} else {
#ifdef PERLDBf_NONAME
	    U32 id = profstack[base++].id;
	    prof_dumpa(ptype, id);
#else
	    char *name = profstack[base++].name;
	    prof_dump(ptype, name);
#endif 
	}
    }
    PerlIO_flush(fp);
    realtime2 = Times(&t2);
    if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
	|| t1.tms_stime != t2.tms_stime) {
	wprof_r += realtime2 - realtime1;
	wprof_u += t2.tms_utime - t1.tms_utime;
	wprof_s += t2.tms_stime - t1.tms_stime;

	PerlIO_printf(fp,"+ & Devel::DProf::write\n" );
	PerlIO_printf(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(fp,"- & Devel::DProf::write\n" );
	otms_utime = t2.tms_utime;
	otms_stime = t2.tms_stime;
	orealtime = realtime2;
	PerlIO_flush(fp);
    }
}

static HV* cv_hash;
static U32 total = 0;

static void
prof_mark( 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(DBsub);       /* name of current sub */

        if( SAVE_STACK ){
                if( profstack_ix + 5 > profstack_max ){
                        profstack_max = profstack_max * 3 / 2;
                        Renew( profstack, profstack_max, PROFANY );
                }
        }

        realtime = Times(&t);
	rdelta = realtime - orealtime;
	udelta = t.tms_utime - otms_utime;
	sdelta = t.tms_stime - otms_stime;
	if (rdelta || udelta || sdelta) {
	    if (SAVE_STACK) {
		profstack[profstack_ix++].ptype = OP_TIME;
		profstack[profstack_ix++].tms_utime = udelta;
		profstack[profstack_ix++].tms_stime = sdelta;
		profstack[profstack_ix++].realtime = rdelta;
	    } else { /* Write it to disk now so's not to eat up core */
		if (prof_pid == (int)getpid()) {
		    prof_dumpt(udelta, sdelta, rdelta);
		    PerlIO_flush(fp);
		}
	    }
	    orealtime = realtime;
	    otms_stime = t.tms_stime;
	    otms_utime = t.tms_utime;
	}

#ifdef PERLDBf_NONAME
	{
	    dTHX;
	    SV **svp;
	    char *gname, *pname;
	    static U32 lastid;
	    CV *cv;

	    cv = INT2PTR(CV*,SvIVX(Sub));
	    svp = hv_fetch(cv_hash, (char*)&cv, sizeof(CV*), TRUE);
	    if (!SvOK(*svp)) {
		GV *gv = CvGV(cv);
		    
		sv_setiv(*svp, id = ++lastid);
		pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) 
			 ? HvNAME(GvSTASH(gv)) 
			 : "(null)");
		gname = GvNAME(gv);
		if (CvXSUB(cv) == XS_Devel__DProf_END)
		    return;
		if (SAVE_STACK) { /* Store it for later recording  -JH */
		    profstack[profstack_ix++].ptype = OP_GV;
		    profstack[profstack_ix++].id = id;
		    profstack[profstack_ix++].name = pname;
		    profstack[profstack_ix++].name = gname;
		} else { /* Write it to disk now so's not to eat up core */

		    /* Only record the parent's info */
		    if (prof_pid == (int)getpid()) {
			prof_dumps(id, pname, gname);
			PerlIO_flush(fp);
		    } else
			perldb = 0;		/* Do not debug the kid. */
		}
	    } else {
		id = SvIV(*svp);
	    }
	}
#else
	pv = SvPV( Sub, len );

        if( SvROK(Sub) ){
                /* Attempt to make CODE refs slightly identifiable by
                 * including their package name.
                 */
                sv = (SV*)SvRV(Sub);
                if( sv && SvTYPE(sv) == SVt_PVCV ){
                        if( CvSTASH(sv) ){
                                hvname = HvNAME(CvSTASH(sv));
                        }
                        else if( CvXSUB(sv) == &XS_Devel__DProf_END ){
                                /*warn( "prof_mark() found dprof::end");*/
                                return; /* don't profile Devel::DProf::END */
                        }
                        else{
                    croak( "DProf prof_mark() lost on CODE ref %s\n", pv );
                        }
                        len += strlen( hvname ) + 2;  /* +2 for ::'s */

                }
                else{
        croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv );
                }
                name = (char *)safemalloc( len * sizeof(char) + 1 );
                strcpy( name, hvname );
                strcat( name, "::" );
                strcat( name, pv );
        }
        else{
                if( *(pv+len-1) == 'D' ){
                        /* It could be an &AUTOLOAD. */

                        /* I measured a bunch of *.pl and *.pm (from Perl
                         * distribution and other misc things) and found
                         * 780 fully-qualified names.  They averaged
                         * about 19 chars each.  Only 1 of those names
                         * ended with 'D' and wasn't an &AUTOLOAD--it
                         * was &overload::OVERLOAD.
                         *    --dmr 2/19/96
                         */

                        if( strcmp( pv+len-9, ":AUTOLOAD" ) == 0 ){
                                /* The sub name is in $AUTOLOAD */
                                sv = perl_get_sv( pv, 0 );
                                if( sv == NULL ){
                croak("DProf prof_mark() lost on AUTOLOAD (%s).\n", pv );
                                }
                                pv = SvPV( sv, na );
                                DBG_SUB_NOTIFY( "  AUTOLOAD(%s)\n", pv );
                        }
                }
                name = savepv( pv );
        }
#endif /* PERLDBf_NONAME */

	total++;
        if (SAVE_STACK) { /* Store it for later recording  -JH */
	    profstack[profstack_ix++].ptype = ptype;
#ifdef PERLDBf_NONAME
	    profstack[profstack_ix++].id = id;
#else
	    profstack[profstack_ix++].name = name;
#endif 
            /* Only record the parent's info */
	    if (SAVE_STACK < profstack_ix) {
		if (prof_pid == (int)getpid())
		    prof_dump_until(profstack_ix);
		else
		    perldb = 0;		/* Do not debug the kid. */
		profstack_ix = 0;
	    }
        } else { /* Write it to disk now so's not to eat up core */

            /* Only record the parent's info */
            if (prof_pid == (int)getpid()) {
#ifdef PERLDBf_NONAME
		prof_dumpa(ptype, id);
#else
		prof_dump(ptype, name);
#endif 
                PerlIO_flush(fp);
            } else
		perldb = 0;		/* Do not debug the kid. */
        }
}

static U32 default_perldb;

#ifdef PL_NEEDED
#  define defstash PL_defstash
#endif

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

    SAVE_STACK = 1000000;
    realtime1 = Times(&t1);
    
    while (k < 2) {
	i = 0;
	    /* Disable debugging of perl_call_sv on second pass: */
	curstash = (k == 0 ? defstash : debstash);
	perldb = default_perldb;
	while (++i <= 100) {
	    j = 0;
	    profstack_ix = 0;		/* Do not let the stack grow */
	    while (++j <= 100) {
/* 		prof_mark( OP_ENTERSUB ); */

		PUSHMARK( stack_sp );
		perl_call_sv( (SV*)cv, G_SCALAR );
		stack_sp--;
/* 		prof_mark( OP_LEAVESUB ); */
	    }
	}
	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++;
    }
    total = ototal;
    SAVE_STACK = ostack;
    perldb = operldb;
}

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

        /* fp is opened in the BOOT section */
        PerlIO_printf(fp, "#fOrTyTwO\n" );
        PerlIO_printf(fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ );
        PerlIO_printf(fp, "$XS_VERSION='DProf %s';\n", XS_VERSION );
        PerlIO_printf(fp, "# All values are given in HZ\n" );
	test_time(&r, &u, &s);
        PerlIO_printf(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(fp, "$over_tests=10000;\n");

        TIMES_LOCATION = PerlIO_tell(fp);

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

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

        PerlIO_flush(fp);
}

static void
prof_record(void)
{
        /* 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(SAVE_STACK){
	    prof_dump_until(profstack_ix);
        }
        PerlIO_seek(fp, TIMES_LOCATION, SEEK_SET);
	/* Write into reserved 240 bytes: */
        PerlIO_printf(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)(prof_end.tms_utime-prof_start.tms_utime-wprof_u),
		      (IV)(prof_end.tms_stime-prof_start.tms_stime-wprof_s),
		      (IV)(rprof_end-rprof_start-wprof_r) );
        PerlIO_printf(fp, "\n$total_marks=%"IVdf, (IV)total);
	
        PerlIO_close( fp );
}

#define NONESUCH()

static U32 depth = 0;

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

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

#define for_real
#ifdef for_real

XS(XS_DB_sub)
{
        dXSARGS;
        dORIGMARK;
        HV *oldstash = curstash;
	SV *Sub = GvSV(DBsub);       /* name of current sub */

        SP -= items;

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

#ifndef PERLDBf_NONAME			/* Was needed on older Perls */
        sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
#endif 

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

        prof_mark( OP_ENTERSUB );
        PUSHMARK( ORIGMARK );

#ifdef G_NODEBUG
        perl_call_sv( INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
#else
        curstash = debstash;    /* To disable debugging of perl_call_sv */
#ifdef PERLDBf_NONAME
        perl_call_sv( (SV*)SvIV(Sub), GIMME );
#else
        perl_call_sv( Sub, GIMME );
#endif 
        curstash = oldstash;
#endif 

        prof_mark( OP_LEAVESUB );
	depth--;

        SPAGAIN;
        PUTBACK;
        return;
}

XS(XS_DB_goto)
{
        prof_mark( OP_GOTO );
        return;
}

#endif /* for_real */

#ifdef testing

        MODULE = Devel::DProf           PACKAGE = DB

        void
        sub(...)
                PPCODE:

                dORIGMARK;
                HV *oldstash = curstash;
		SV *Sub = GvSV(DBsub);       /* name of current sub */
                /* SP -= items;  added by xsubpp */
                DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );

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

                prof_mark( OP_ENTERSUB );
                PUSHMARK( ORIGMARK );

                curstash = debstash;    /* To disable debugging of perl_call_sv
*/
                perl_call_sv( Sub, GIMME );
                curstash = oldstash;

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

#endif /* testing */

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

void
END()
        PPCODE:
        if( DBsub ){
                /* maybe the process forked--we want only
                 * the parent's profile.
                 */
                if( prof_pid == (int)getpid() ){
                        rprof_end = Times(&prof_end);
                        DBG_TIMER_NOTIFY("Profiler timer is off.\n");
                        prof_record();
                }
        }

void
NONESUCH()

BOOT:
        /* Before we go anywhere make sure we were invoked
         * properly, else we'll dump core.
         */
        if( ! 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 = dowarn;
                dowarn = 0;
                newXS("DB::sub", XS_DB_sub, file);
                newXS("DB::goto", XS_DB_goto, file);
                dowarn = warn_tmp;
        }

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

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

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

	    buffer = getenv("PERL_DPROF_TICKS");

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

        if( (fp = PerlIO_open( "tmon.out", "w" )) == NULL )
                croak("DProf: unable to write tmon.out, errno = %d\n", errno );
#ifdef PERLDBf_NONAME
	default_perldb = PERLDBf_NONAME | PERLDBf_SUB; /* no name needed. */
#ifdef PERLDBf_GOTO
	default_perldb = default_perldb | PERLDBf_GOTO;
#endif 
	cv_hash = newHV();
#else
#  ifdef PERLDBf_SUB
	default_perldb = PERLDBf_SUB;		/* debug subroutines only. */
#  endif
#endif
        prof_pid = (int)getpid();

	New( 0, profstack, profstack_max, PROFANY );

        prof_recordheader();

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