#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 */
# 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))
#else
# ifndef HZ
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 */
U32 total;
U32 lastid;
U32 default_perldb;
- U32 depth;
+ UV 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
#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),na));
+ 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),na));
+ SvPV(perl_get_sv("!",TRUE), n_a));
g_start_cnt = toLongLong(cnt);
}
if (CheckOSError(DosTmrQueryTime(&cnt)))
- croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na));
+ 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 */
{
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 */
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;
+ clock_t realtime1 = 0, realtime2 = 0;
U32 ototal = g_total;
U32 ostack = g_SAVE_STACK;
U32 operldb = PL_perldb;
/* 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);
}
static void
check_depth(pTHX_ void *foo)
{
- U32 need_depth = (U32)foo;
+ U32 need_depth = PTR2UV(foo);
if (need_depth != g_depth) {
if (need_depth > g_depth) {
warn("garbled call depth when profiling");
}
else {
- I32 marks = g_depth - need_depth;
+ IV marks = g_depth - need_depth;
/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
while (marks--) {
XS(XS_DB_sub)
{
- dXSARGS;
+ dMARK;
dORIGMARK;
SV *Sub = GvSV(PL_DBsub); /* name of current sub */
{
HV *oldstash = PL_curstash;
- DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na));
+ DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
- SAVEDESTRUCTOR_X(check_depth, (void*)g_depth);
+ SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth));
g_depth++;
prof_mark(aTHX_ OP_ENTERSUB);
PUSHMARK(ORIGMARK);
perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
+ PL_curstash = oldstash;
prof_mark(aTHX_ OP_LEAVESUB);
g_depth--;
}
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(Sub, na));
+ DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
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("tmon.out", "w")) == NULL)
- croak("DProf: unable to write tmon.out, errno = %d\n", errno);
+ 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();