/* vim: ts=8 sw=4 expandtab:
* ************************************************************************
* This file is part of the Devel::NYTProf package.
* Copyright 2008 Adam J. Kaplan, The New York Times Company.
* Copyright 2009-2010 Tim Bunce, Ireland.
* Released under the same terms as Perl 5.8
* See http://search.cpan.org/dist/Devel-NYTProf/
*
* Contributors:
* Tim Bunce, http://www.tim.bunce.name and http://blog.timbunce.org
* Nicholas Clark,
* Adam Kaplan, akaplan at nytimes.com
* Steve Peters, steve at fisharerojo.org
*
* ************************************************************************
*/
#ifndef WIN32
#define PERL_NO_GET_CONTEXT /* we want efficiency */
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "FileHandle.h"
#include "NYTProf.h"
#ifndef NO_PPPORT_H
#define NEED_eval_pv
#define NEED_grok_number
#define NEED_grok_numeric_radix
#define NEED_newCONSTSUB
#define NEED_newRV_noinc
#define NEED_sv_2pv_flags
#define NEED_newSVpvn_flags
#define NEED_my_strlcat
# include "ppport.h"
#endif
/* Until ppport.h gets this: */
#ifndef memEQs
# define memEQs(s1, l, s2) \
(sizeof(s2)-1 == l && memEQ(s1, ("" s2 ""), (sizeof(s2)-1)))
#endif
#ifdef USE_HARD_ASSERT
#undef NDEBUG
#include <assert.h>
#endif
#if !defined(OutCopFILE)
# define OutCopFILE CopFILE
#endif
#ifndef gv_fetchfile_flags /* added in perl 5.009005 */
/* we know our uses don't contain embedded nulls, so we just need to copy to a
* buffer so we can add a trailing null byte */
#define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c)
static GV *
Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, const U32 flags) {
char buf[2000];
if (namelen >= sizeof(buf)-1)
croak("panic: gv_fetchfile_flags overflow");
memcpy(buf, name, namelen);
buf[namelen] = '\0'; /* null-terminate */
return gv_fetchfile(buf);
}
#endif
#ifndef OP_SETSTATE
#define OP_SETSTATE OP_NEXTSTATE
#endif
#ifndef PERLDBf_SAVESRC
#define PERLDBf_SAVESRC PERLDBf_SUBLINE
#endif
#ifndef PERLDBf_SAVESRC_NOSUBS
#define PERLDBf_SAVESRC_NOSUBS 0
#endif
#ifndef CvISXSUB
#define CvISXSUB CvXSUB
#endif
#if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION < 8))
/* If we're using DB::DB() instead of opcode redirection with an old perl
* then PL_curcop in DB() will refer to the DB() wrapper in Devel/NYTProf.pm
* so we'd have to crawl the stack to find the right cop. However, for some
* reason that I don't pretend to understand the following expression works:
*/
#define PL_curcop_nytprof (opt_use_db_sub ? ((cxstack + cxstack_ix)->blk_oldcop) : PL_curcop)
#else
#define PL_curcop_nytprof PL_curcop
#endif
#define OP_NAME_safe(op) ((op) ? OP_NAME(op) : "NULL")
#ifdef I_SYS_TIME
#include <sys/time.h>
#endif
#include <stdio.h>
#ifdef HAS_ZLIB
#include <zlib.h>
#define default_compression_level 6
#else
#define default_compression_level 0
#endif
#ifndef ZLIB_VERSION
#define ZLIB_VERSION "0"
#endif
#define NYTP_FILE_MAJOR_VERSION 5
#define NYTP_FILE_MINOR_VERSION 0
#define NYTP_START_NO 0
#define NYTP_START_BEGIN 1
#define NYTP_START_CHECK_unused 2 /* not used */
#define NYTP_START_INIT 3
#define NYTP_START_END 4
#define NYTP_OPTf_ADDPID 0x0001 /* append .pid to output filename */
#define NYTP_OPTf_OPTIMIZE 0x0002 /* affect $^P & 0x04 */
#define NYTP_OPTf_SAVESRC 0x0004 /* copy source code lines into profile data */
#define NYTP_FIDf_IS_PMC 0x0001 /* .pm probably really loaded as .pmc */
#define NYTP_FIDf_VIA_STMT 0x0002 /* fid first seen by stmt profiler */
#define NYTP_FIDf_VIA_SUB 0x0004 /* fid first seen by sub profiler */
#define NYTP_FIDf_IS_AUTOSPLIT 0x0008 /* fid is an autosplit (see AutoLoader) */
#define NYTP_FIDf_HAS_SRC 0x0010 /* src is available to profiler */
#define NYTP_FIDf_SAVE_SRC 0x0020 /* src will be saved by profiler, if NYTP_FIDf_HAS_SRC also set */
#define NYTP_FIDf_IS_ALIAS 0x0040 /* fid is clone of the 'parent' fid it was autosplit from */
#define NYTP_FIDf_IS_FAKE 0x0080 /* eg dummy caller of a string eval that doesn't have a filename */
#define NYTP_FIDf_IS_EVAL 0x0100 /* is an eval */
/* indices to elements of the file info array */
#define NYTP_FIDi_FILENAME 0
#define NYTP_FIDi_EVAL_FID 1
#define NYTP_FIDi_EVAL_LINE 2
#define NYTP_FIDi_FID 3
#define NYTP_FIDi_FLAGS 4
#define NYTP_FIDi_FILESIZE 5
#define NYTP_FIDi_FILEMTIME 6
#define NYTP_FIDi_PROFILE 7
#define NYTP_FIDi_EVAL_FI 8
#define NYTP_FIDi_HAS_EVALS 9
#define NYTP_FIDi_SUBS_DEFINED 10
#define NYTP_FIDi_SUBS_CALLED 11
#define NYTP_FIDi_elements 12 /* highest index, plus 1 */
/* indices to elements of the sub info array (report-side only) */
#define NYTP_SIi_FID 0 /* fid of file sub was defined in */
#define NYTP_SIi_FIRST_LINE 1 /* line number of first line of sub */
#define NYTP_SIi_LAST_LINE 2 /* line number of last line of sub */
#define NYTP_SIi_CALL_COUNT 3 /* number of times sub was called */
#define NYTP_SIi_INCL_RTIME 4 /* incl real time in sub */
#define NYTP_SIi_EXCL_RTIME 5 /* excl real time in sub */
#define NYTP_SIi_SUB_NAME 6 /* sub name */
#define NYTP_SIi_PROFILE 7 /* ref to profile object */
#define NYTP_SIi_REC_DEPTH 8 /* max recursion call depth */
#define NYTP_SIi_RECI_RTIME 9 /* recursive incl real time in sub */
#define NYTP_SIi_CALLED_BY 10 /* { fid => { line => [...] } } */
#define NYTP_SIi_elements 11 /* highest index, plus 1 */
/* indices to elements of the sub call info array */
/* XXX currently ticks are accumulated into NYTP_SCi_*_TICKS during profiling
* and then NYTP_SCi_*_RTIME are calculated and output. This avoids float noise
* during profiling but we should really output ticks so the reporting side
* can also be more accurate when merging subs, for example.
* That'll probably need a file format bump and thus also a major version bump.
* Will need coresponding changes to NYTP_SIi_* as well.
*/
#define NYTP_SCi_CALL_COUNT 0 /* count of calls to sub */
#define NYTP_SCi_INCL_RTIME 1 /* inclusive real time in sub (set from NYTP_SCi_INCL_TICKS) */
#define NYTP_SCi_EXCL_RTIME 2 /* exclusive real time in sub (set from NYTP_SCi_EXCL_TICKS) */
#define NYTP_SCi_INCL_TICKS 3 /* inclusive ticks in sub */
#define NYTP_SCi_EXCL_TICKS 4 /* exclusive ticks in sub */
#define NYTP_SCi_RECI_RTIME 5 /* recursive incl real time in sub */
#define NYTP_SCi_REC_DEPTH 6 /* max recursion call depth */
#define NYTP_SCi_CALLING_SUB 7 /* name of calling sub */
#define NYTP_SCi_elements 8 /* highest index, plus 1 */
/* we're not thread-safe (or even multiplicity safe) yet, so detect and bail */
#ifdef MULTIPLICITY
static PerlInterpreter *orig_my_perl;
#endif
#define MAX_HASH_SIZE 512
typedef struct hash_entry Hash_entry;
struct hash_entry {
unsigned int id;
char* key;
int key_len;
Hash_entry* next_entry;
Hash_entry* next_inserted; /* linked list in insertion order */
};
typedef struct hash_table {
Hash_entry** table;
char *name;
unsigned int size;
unsigned int entry_struct_size;
Hash_entry* first_inserted;
Hash_entry* prior_inserted; /* = last_inserted before the last insertion */
Hash_entry* last_inserted;
unsigned int next_id; /* starts at 1, 0 is reserved */
} Hash_table;
typedef struct {
Hash_entry he;
unsigned int eval_fid;
unsigned int eval_line_num;
unsigned int file_size;
unsigned int file_mtime;
unsigned int fid_flags;
char *key_abs;
/* update autosplit logic in get_file_id if fields are added or changed */
} fid_hash_entry;
static Hash_table fidhash = { NULL, "fid", MAX_HASH_SIZE, sizeof(fid_hash_entry), NULL, NULL, NULL, 1 };
typedef struct {
Hash_entry he;
} str_hash_entry;
static Hash_table strhash = { NULL, "str", MAX_HASH_SIZE, sizeof(str_hash_entry), NULL, NULL, NULL, 1 };
/* END Hash table definitions */
/* defaults */
static NYTP_file out;
/* options and overrides */
static char PROF_output_file[MAXPATHLEN+1] = "nytprof.out";
static unsigned int profile_opts = NYTP_OPTf_OPTIMIZE | NYTP_OPTf_SAVESRC;
static int profile_start = NYTP_START_BEGIN; /* when to start profiling */
struct NYTP_options_t {
const char *option_name;
IV option_iv;
char *option_pv; /* strdup'd */
};
/* XXX boolean options should be moved into profile_opts */
static struct NYTP_options_t options[] = {
#define profile_usecputime options[0].option_iv
{ "usecputime", 0, NULL },
#define profile_subs options[1].option_iv
{ "subs", 1, NULL }, /* subroutine times */
#define profile_blocks options[2].option_iv
{ "blocks", 0, NULL }, /* block and sub *exclusive* times */
#define profile_leave options[3].option_iv
{ "leave", 1, NULL }, /* correct block end timing */
#define embed_fid_line options[4].option_iv
{ "expand", 0, NULL },
#define trace_level options[5].option_iv
{ "trace", 0, NULL },
#define opt_use_db_sub options[6].option_iv
{ "use_db_sub", 0, NULL },
#define compression_level options[7].option_iv
{ "compress", default_compression_level, NULL },
#define profile_clock options[8].option_iv
{ "clock", -1, NULL },
#define profile_stmts options[9].option_iv
{ "stmts", 1, NULL }, /* statement exclusive times */
#define profile_slowops options[10].option_iv
{ "slowops", 2, NULL }, /* slow opcodes, typically system calls */
#define profile_findcaller options[11].option_iv
{ "findcaller", 0, NULL }, /* find sub caller instead of trusting outer */
#define profile_forkdepth options[12].option_iv
{ "forkdepth", -1, NULL }, /* how many generations of kids to profile */
#define opt_perldb options[13].option_iv
{ "perldb", 0, NULL }, /* force certain PL_perldb value */
#define opt_nameevals options[14].option_iv
{ "nameevals", 1, NULL }, /* change $^P 0x100 bit */
#define opt_nameanonsubs options[15].option_iv
{ "nameanonsubs", 1, NULL }, /* change $^P 0x200 bit */
#define opt_calls options[16].option_iv
{ "calls", 1, NULL }, /* output call/return event stream */
#define opt_evals options[17].option_iv
{ "evals", 0, NULL } /* handling of string evals - TBD XXX */
};
/* XXX TODO: add these to options:
if (strEQ(option, "file")) {
strncpy(PROF_output_file, value, MAXPATHLEN);
else if (strEQ(option, "log")) {
else if (strEQ(option, "start")) {
else if (strEQ(option, "addpid")) {
else if (strEQ(option, "optimize") || strEQ(option, "optimise")) {
else if (strEQ(option, "savesrc")) {
else if (strEQ(option, "endatexit")) {
else if (strEQ(option, "libcexit")) {
and write the options to the stream when profiling starts.
*/
/* time tracking */
#ifdef HAS_CLOCK_GETTIME
/* http://www.freebsd.org/cgi/man.cgi?query=clock_gettime
* http://webnews.giga.net.tw/article//mailing.freebsd.performance/710
* http://sean.chittenden.org/news/2008/06/01/
* Explanation of why gettimeofday() (and presumably CLOCK_REALTIME) may go backwards:
* http://groups.google.com/group/comp.os.linux.development.apps/tree/browse_frm/thread/dc29071f2417f75f/ac44671fdb35f6db?rnum=1&_done=%2Fgroup%2Fcomp.os.linux.development.apps%2Fbrowse_frm%2Fthread%2Fdc29071f2417f75f%2Fc46264dba0863463%3Flnk%3Dst%26rnum%3D1%26#doc_776f910824bdbee8
*/
typedef struct timespec time_of_day_t;
# define CLOCK_GETTIME(ts) clock_gettime(profile_clock, ts)
# define TICKS_PER_SEC 10000000 /* 10 million - 100ns */
# define get_time_of_day(into) CLOCK_GETTIME(&into)
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
ticks = ((e.tv_sec - s.tv_sec) * TICKS_PER_SEC + (e.tv_nsec / (typ)100) - (s.tv_nsec / (typ)100)); \
} STMT_END
#else /* !HAS_CLOCK_GETTIME */
#ifdef HAS_MACH_TIME
#include <mach/mach.h>
#include <mach/mach_time.h>
mach_timebase_info_data_t our_timebase;
typedef uint64_t time_of_day_t;
# define TICKS_PER_SEC 10000000 /* 10 million - 100ns */
# define get_time_of_day(into) into = mach_absolute_time()
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
if( our_timebase.denom == 0 ) mach_timebase_info(&our_timebase); \
ticks = (e-s) * our_timebase.numer / our_timebase.denom / (typ)100; \
} STMT_END
#else /* !HAS_MACH_TIME */
#ifdef HAS_GETTIMEOFDAY
typedef struct timeval time_of_day_t;
# define TICKS_PER_SEC 1000000 /* 1 million */
# define get_time_of_day(into) gettimeofday(&into, NULL)
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
ticks = ((e.tv_sec - s.tv_sec) * TICKS_PER_SEC + e.tv_usec - s.tv_usec); \
} STMT_END
#else
static int (*u2time)(pTHX_ UV *) = 0;
typedef UV time_of_day_t[2];
# define TICKS_PER_SEC 1000000 /* 1 million */
# define get_time_of_day(into) (*u2time)(aTHX_ into)
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
ticks = ((e[0] - s[0]) * (typ)TICKS_PER_SEC + e[1] - s[1]); \
} STMT_END
#endif
#endif
#endif
static time_of_day_t start_time;
static time_of_day_t end_time;
static unsigned int last_executed_line;
static unsigned int last_executed_fid;
static char *last_executed_fileptr;
static unsigned int last_block_line;
static unsigned int last_sub_line;
static unsigned int is_profiling; /* disable_profile() & enable_profile() */
static Pid_t last_pid = 0;
static NV cumulative_overhead_ticks = 0.0;
static NV cumulative_subr_ticks = 0.0;
static UV cumulative_subr_seqn = 0;
static int main_runtime_used = 0;
static SV *DB_CHECK_cv;
static SV *DB_INIT_cv;
static SV *DB_END_cv;
static SV *DB_fin_cv;
static const char *class_mop_evaltag = " defined at ";
static int class_mop_evaltag_len = 12;
static unsigned int ticks_per_sec = 0; /* 0 forces error if not set */
static AV *slowop_name_cache;
/* prototypes */
static void output_header(pTHX);
static SV *read_str(pTHX_ NYTP_file ifile, SV *sv);
static unsigned int get_file_id(pTHX_ char*, STRLEN, int created_via);
static void DB_stmt(pTHX_ COP *cop, OP *op);
static void set_option(pTHX_ const char*, const char*);
static int enable_profile(pTHX_ char *file);
static int disable_profile(pTHX);
static void finish_profile(pTHX);
static void finish_profile_nocontext(void);
static void open_output_file(pTHX_ char *);
static int reinit_if_forked(pTHX);
static int parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p, char *sub_name);
static void write_cached_fids(void);
static void write_src_of_files(pTHX);
static void write_sub_line_ranges(pTHX);
static void write_sub_callers(pTHX);
static AV *store_profile_line_entry(pTHX_ SV *rvav, unsigned int line_num,
NV time, int count, unsigned int fid);
/* copy of original contents of PL_ppaddr */
typedef OP * (CPERLscope(*orig_ppaddr_t))(pTHX);
orig_ppaddr_t *PL_ppaddr_orig;
#define run_original_op(type) CALL_FPTR(PL_ppaddr_orig[type])(aTHX)
static OP *pp_entersub_profiler(pTHX);
static OP *pp_subcall_profiler(pTHX_ int type);
static OP *pp_leave_profiler(pTHX);
static HV *sub_callers_hv;
static HV *pkg_fids_hv; /* currently just package names */
/* PL_sawampersand is disabled in 5.17.7+ 1a904fc */
#if (PERL_VERSION < 17) || ((PERL_VERSION == 17) && (PERL_SUBVERSION < 7)) || defined(PERL_SAWAMPERSAND)
static U8 last_sawampersand;
#define CHECK_SAWAMPERSAND(fid,line) STMT_START { \
if (PL_sawampersand != last_sawampersand) { \
if (trace_level >= 1) \
logwarn("Slow regex match variable seen (0x%x->0x%x at %u:%u)\n", PL_sawampersand, last_sawampersand, fid, line); \
/* XXX this is a hack used by test14 to avoid different behaviour \
* pre/post perl 5.17.7 since it's not relevant to the test, which is really \
* about AutoSplit */ \
if (!getenv("DISABLE_NYTPROF_SAWAMPERSAND")) \
NYTP_write_sawampersand(out, fid, line); \
last_sawampersand = (U8)PL_sawampersand; \
} \
} STMT_END
#else
#define CHECK_SAWAMPERSAND(fid,line) (void)0
#endif
/* macros for outputing profile data */
#ifndef HAS_GETPPID
#define getppid() 0
#endif
static FILE *logfh;
/* predeclare to set attribute */
static void logwarn(const char *pat, ...) __attribute__format__(__printf__,1,2);
static void
logwarn(const char *pat, ...)
{
/* we avoid using any perl mechanisms here */
va_list args;
va_start(args, pat);
if (!logfh)
logfh = stderr;
vfprintf(logfh, pat, args);
/* Flush to ensure the log message gets pushed out to the kernel.
* This flush will be expensive but is needed to ensure the log has recent info
* if there's a core dump. Could add an option to disable flushing if needed.
*/
fflush(logfh);
va_end(args);
}
/***********************************
* Devel::NYTProf Functions *
***********************************/
static NV
gettimeofday_nv(void)
{
#ifdef HAS_GETTIMEOFDAY
struct timeval when;
gettimeofday(&when, (struct timezone *) 0);
return when.tv_sec + (when.tv_usec / 1000000.0);
#else
if (u2time) {
UV time_of_day[2];
(*u2time)(aTHX_ &time_of_day);
return time_of_day[0] + (time_of_day[1] / 1000000.0);
}
return (NV)time();
#endif
}
/**
* output file header
*/
static void
output_header(pTHX)
{
/* $0 - application name */
SV *const sv = get_sv("0",GV_ADDWARN);
time_t basetime = PL_basetime;
/* This comes back with a terminating \n, and we don't want that. */
const char *const basetime_str = ctime(&basetime);
const STRLEN basetime_str_len = strlen(basetime_str);
const char version[] = STRINGIFY(PERL_REVISION) "."
STRINGIFY(PERL_VERSION) "." STRINGIFY(PERL_SUBVERSION);
STRLEN len;
const char *argv0 = SvPV(sv, len);
assert(out != NULL);
/* File header with "magic" string, with file major and minor version */
NYTP_write_header(out, NYTP_FILE_MAJOR_VERSION, NYTP_FILE_MINOR_VERSION);
/* Human readable comments and attributes follow
* comments start with '#', end with '\n', and are discarded
* attributes start with ':', a word, '=', then the value, then '\n'
*/
NYTP_write_comment(out, "Perl profile database. Generated by Devel::NYTProf on %.*s",
(int)basetime_str_len - 1, basetime_str);
/* XXX add options, $0, etc, but beware of embedded newlines */
/* XXX would be good to adopt a proper charset & escaping for these */
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("basetime"), (unsigned long)PL_basetime); /* $^T */
NYTP_write_attribute_string(out, STR_WITH_LEN("application"), argv0, len);
/* perl constants: */
NYTP_write_attribute_string(out, STR_WITH_LEN("perl_version"), version, sizeof(version) - 1);
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("nv_size"), sizeof(NV));
/* sanity checks: */
NYTP_write_attribute_string(out, STR_WITH_LEN("xs_version"), STR_WITH_LEN(XS_VERSION));
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("PL_perldb"), PL_perldb);
/* these are really options: */
NYTP_write_attribute_signed(out, STR_WITH_LEN("clock_id"), profile_clock);
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("ticks_per_sec"), ticks_per_sec);
if (1) {
struct NYTP_options_t *opt_p = options;
const struct NYTP_options_t *const opt_end
= options + sizeof(options) / sizeof (struct NYTP_options_t);
do {
NYTP_write_option_iv(out, opt_p->option_name, opt_p->option_iv);
} while (++opt_p < opt_end);
}
#ifdef HAS_ZLIB
if (compression_level) {
NYTP_start_deflate_write_tag_comment(out, compression_level);
}
#endif
NYTP_write_process_start(out, getpid(), getppid(), gettimeofday_nv());
write_cached_fids(); /* empty initially, non-empty after fork */
NYTP_flush(out);
}
static SV *
read_str(pTHX_ NYTP_file ifile, SV *sv) {
STRLEN len;
char *buf;
unsigned char tag;
NYTP_read(ifile, &tag, sizeof(tag), "string prefix");
if (NYTP_TAG_STRING != tag && NYTP_TAG_STRING_UTF8 != tag)
croak("File format error at offset %ld%s, expected string tag but found %d ('%c')",
NYTP_tell(ifile)-1, NYTP_type_of_offset(ifile), tag, tag);
len = read_u32(ifile);
if (sv) {
SvGROW(sv, len+1); /* forces SVt_PV */
}
else {
sv = newSV(len+1); /* +1 to force SVt_PV even for 0 length string */
}
SvPOK_on(sv);
buf = SvPV_nolen(sv);
NYTP_read(ifile, buf, len, "string");
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
if (NYTP_TAG_STRING_UTF8 == tag)
SvUTF8_on(sv);
if (trace_level >= 19) {
STRLEN len2 = len;
const char *newline = "";
if (buf[len2-1] == '\n') {
--len2;
newline = "\\n";
}
logwarn(" read string '%.*s%s'%s\n", (int)len2, SvPV_nolen(sv),
newline, (SvUTF8(sv)) ? " (utf8)" : "");
}
return sv;
}
/**
* An implementation of the djb2 hash function by Dan Bernstein.
*/
static unsigned long
hash (char* _str, unsigned int len)
{
char* str = _str;
unsigned long hash = 5381;
while (len--) {
/* hash * 33 + c */
hash = ((hash << 5) + hash) + *str++;
}
return hash;
}
/**
* Returns a pointer to the ')' after the digits in the (?:re_)?eval prefix.
* As the prefix length is known, this gives the length of the digits.
*/
static const char *
eval_prefix(const char *filename, const char *prefix, STRLEN prefix_len) {
if (memEQ(filename, prefix, prefix_len)
&& isdigit((int)filename[prefix_len])) {
const char *s = filename + prefix_len + 1;
while (isdigit((int)*s))
++s;
if (s[0] == ')')
return s;
}
return NULL;
}
/**
* Return true if filename looks like an eval
*/
static int
filename_is_eval(const char *filename, STRLEN filename_len)
{
if (filename_len < 6)
return 0;
/* typically "(eval N)[...]" sometimes just "(eval N)" */
if (filename[filename_len - 1] != ']' && filename[filename_len - 1] != ')')
return 0;
if (eval_prefix(filename, "(eval ", 6))
return 1;
if (eval_prefix(filename, "(re_eval ", 9))
return 1;
return 0;
}
/**
* Fetch/Store on hash table. entry must always be defined.
* hash_op will find hash_entry in the hash table.
* hash_entry not in table, insert is false: returns NULL
* hash_entry not in table, insert is true: inserts hash_entry and returns hash_entry
* hash_entry in table, insert IGNORED: returns pointer to the actual hash entry
*/
static char
hash_op(Hash_table *hashtable, char *key, int key_len, Hash_entry** retval, bool insert)
{
unsigned long h = hash(key, key_len) % hashtable->size;
Hash_entry* found = hashtable->table[h];
while(NULL != found) {
if (found->key_len == key_len
&& memEQ(found->key, key, key_len)
) {
*retval = found;
return 0;
}
if (NULL == found->next_entry) {
if (insert) {
Hash_entry* e;
Newc(0, e, hashtable->entry_struct_size, char, Hash_entry);
memzero(e, hashtable->entry_struct_size);
e->id = hashtable->next_id++;
e->next_entry = NULL;
e->key_len = key_len;
e->key = (char*)safemalloc(sizeof(char) * key_len + 1);
e->key[key_len] = '\0';
memcpy(e->key, key, key_len);
found->next_entry = e;
*retval = found->next_entry;
hashtable->prior_inserted = hashtable->last_inserted;
hashtable->last_inserted = e;
return 1;
}
else {
*retval = NULL;
return -1;
}
}
found = found->next_entry;
}
if (insert) {
Hash_entry* e;
Newc(0, e, hashtable->entry_struct_size, char, Hash_entry);
memzero(e, hashtable->entry_struct_size);
e->id = hashtable->next_id++;
e->next_entry = NULL;
e->key_len = key_len;
e->key = (char*)safemalloc(sizeof(char) * e->key_len + 1);
e->key[e->key_len] = '\0';
memcpy(e->key, key, key_len);
*retval = hashtable->table[h] = e;
if (!hashtable->first_inserted)
hashtable->first_inserted = e;
hashtable->prior_inserted = hashtable->last_inserted;
hashtable->last_inserted = e;
return 1;
}
*retval = NULL;
return -1;
}
static void
hash_stats(Hash_table *hashtable, int verbosity)
{
int idx = 0;
int max_chain_len = 0;
int buckets = 0;
int items = 0;
if (verbosity)
warn("%s hash: size %d\n", hashtable->name, hashtable->size);
if (!hashtable->table)
return;
for (idx=0; idx < hashtable->size; ++idx) {
int chain_len = 0;
Hash_entry *found = hashtable->table[idx];
if (!found)
continue;
++buckets;
while (NULL != found) {
++chain_len;
++items;
found = found->next_entry;
}
if (verbosity)
warn("%s hash[%3d]: %d items\n", hashtable->name, idx, chain_len);
if (chain_len > max_chain_len)
max_chain_len = chain_len;
}
/* XXX would be nice to show a histogram of chain lenths */
warn("%s hash: %d of %d buckets used, %d items, max chain %d\n",
hashtable->name, buckets, hashtable->size, items, max_chain_len);
}
static void
emit_fid (fid_hash_entry *fid_info)
{
char *file_name = fid_info->he.key;
STRLEN file_name_len = fid_info->he.key_len;
char *file_name_copy = NULL;
if (fid_info->key_abs) {
file_name = fid_info->key_abs;
file_name_len = strlen(file_name);
}
#ifdef WIN32
/* Make sure we only use forward slashes in filenames */
if (memchr(file_name, '\\', file_name_len)) {
STRLEN i;
file_name_copy = (char*)safemalloc(file_name_len);
for (i=0; i<file_name_len; ++i) {
char ch = file_name[i];
file_name_copy[i] = ch == '\\' ? '/' : ch;
}
file_name = file_name_copy;
}
#endif
NYTP_write_new_fid(out, fid_info->he.id, fid_info->eval_fid,
fid_info->eval_line_num, fid_info->fid_flags,
fid_info->file_size, fid_info->file_mtime,
file_name, (I32)file_name_len);
if (file_name_copy)
Safefree(file_name_copy);
}
/* return true if file is a .pm that was actually loaded as a .pmc */
static int
fid_is_pmc(pTHX_ fid_hash_entry *fid_info)
{
int is_pmc = 0;
char *file_name = fid_info->he.key;
STRLEN len = fid_info->he.key_len;
if (fid_info->key_abs) {
file_name = fid_info->key_abs;
len = strlen(file_name);
}
if (len > 3 && memEQs(file_name + len - 3, 3, ".pm")) {
/* ends in .pm, ok, does a newer .pmc exist? */
/* based on doopen_pm() in perl's pp_ctl.c */
SV *const pmcsv = newSV(len + 2);
char *const pmc = SvPVX(pmcsv);
Stat_t pmstat;
Stat_t pmcstat;
memcpy(pmc, file_name, len);
pmc[len] = 'c';
pmc[len + 1] = '\0';
if (PerlLIO_lstat(pmc, &pmcstat) == 0) {
/* .pmc exists, is it newer than the .pm (if that exists) */
/* Keys in the fid_info are explicitly written with a terminating
'\0', so it is safe to pass file_name to a system call. */
if (PerlLIO_lstat(file_name, &pmstat) < 0 ||
pmstat.st_mtime < pmcstat.st_mtime) {
is_pmc = 1; /* hey, maybe it's Larry working on the perl6 comiler */
}
}
SvREFCNT_dec(pmcsv);
}
return is_pmc;
}
static char *
fmt_fid_flags(pTHX_ int fid_flags, char *buf, Size_t len) {
*buf = '\0';
if (fid_flags & NYTP_FIDf_IS_EVAL) my_strlcat(buf, "eval,", len);
if (fid_flags & NYTP_FIDf_IS_FAKE) my_strlcat(buf, "fake,", len);
if (fid_flags & NYTP_FIDf_IS_AUTOSPLIT) my_strlcat(buf, "autosplit,", len);
if (fid_flags & NYTP_FIDf_IS_ALIAS) my_strlcat(buf, "alias,", len);
if (fid_flags & NYTP_FIDf_IS_PMC) my_strlcat(buf, "pmc,", len);
if (fid_flags & NYTP_FIDf_VIA_STMT) my_strlcat(buf, "viastmt,", len);
if (fid_flags & NYTP_FIDf_VIA_SUB) my_strlcat(buf, "viasub,", len);
if (fid_flags & NYTP_FIDf_HAS_SRC) my_strlcat(buf, "hassrc,", len);
if (fid_flags & NYTP_FIDf_SAVE_SRC) my_strlcat(buf, "savesrc,", len);
if (*buf) /* trim trailing comma */
buf[ my_strlcat(buf,"",len)-1 ] = '\0';
return buf;
}
static void
write_cached_fids()
{
fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted;
while (e) {
if ( !(e->fid_flags & NYTP_FIDf_IS_ALIAS) )
emit_fid(e);
e = (fid_hash_entry*)e->he.next_inserted;
}
}
static fid_hash_entry *
find_autosplit_parent(pTHX_ char* file_name)
{
/* extract basename from file_name, then search for most recent entry
* in fidhash that has the same basename
*/
fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted;
fid_hash_entry *match = NULL;
const char *sep = "/";
char *base_end = strstr(file_name, " (autosplit");
char *base_start = rninstr(file_name, base_end, sep, sep+1);
STRLEN base_len;
base_start = (base_start) ? base_start+1 : file_name;
base_len = base_end - base_start;
if (trace_level >= 3)
logwarn("find_autosplit_parent of '%.*s' (%s)\n",
(int)base_len, base_start, file_name);
for ( ; e; e = (fid_hash_entry*)e->he.next_inserted) {
char *e_name;
if (e->fid_flags & NYTP_FIDf_IS_AUTOSPLIT)
continue;
if (trace_level >= 4)
logwarn("find_autosplit_parent: checking '%.*s'\n", e->he.key_len, e->he.key);
/* skip if key is too small to match */
if (e->he.key_len < base_len)
continue;
/* skip if the last base_len bytes don't match the base name */
e_name = e->he.key + e->he.key_len - base_len;
if (memcmp(e_name, base_start, base_len) != 0)
continue;
/* skip if the char before the matched key isn't a separator */
if (e->he.key_len > base_len && *(e_name-1) != *sep)
continue;
if (trace_level >= 3)
logwarn("matched autosplit '%.*s' to parent fid %d '%.*s' (%c|%c)\n",
(int)base_len, base_start, e->he.id, e->he.key_len, e->he.key, *(e_name-1),*sep);
match = e;
/* keep looking, so we'll return the most recently profiled match */
}
return match;
}
#if 0 /* currently unused */
static Hash_entry *
lookup_file_entry(pTHX_ char* file_name, STRLEN file_name_len) {
Hash_entry entry, *found;
entry.key = file_name;
entry.key_len = (unsigned int)file_name_len;
if (hash_op(fidhash, &entry, &found, 0) == 0)
return found;
return NULL;
}
#endif
/**
* Return a unique persistent id number for a file.
* If file name has not been seen before
* then, if created_via is false it returns 0 otherwise it
* assigns a new id and outputs the file and id to the stream.
* If the file name is a synthetic name for an eval then
* get_file_id recurses to process the 'embedded' file name first.
* The created_via flag bit is stored in the fid info
* (currently only used as a diagnostic tool)
*/
static unsigned int
get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
{
fid_hash_entry *found, *parent_entry;
AV *src_av = Nullav;
if (1 != hash_op(&fidhash, file_name, file_name_len, (Hash_entry**)&found, (bool)(created_via ? 1 : 0))) {
/* found existing entry or else didn't but didn't create new one either */
if (trace_level >= 7) {
if (found)
logwarn("fid %d: %.*s\n", found->he.id, found->he.key_len, found->he.key);
else logwarn("fid -: %.*s not profiled\n", (int)file_name_len, file_name);
}
return (found) ? found->he.id : 0;
}
/* inserted new entry */
if (fidhash.prior_inserted)
fidhash.prior_inserted->next_inserted = fidhash.last_inserted;
/* if this is a synthetic filename for a string eval
* ie "(eval 42)[/some/filename.pl:line]"
* then ensure we've already generated a fid for the underlying
* filename, and associate that fid with this eval fid
*/
if ('(' == file_name[0]) { /* first char is '(' */
if (']' == file_name[file_name_len-1]) { /* last char is ']' */
char *start = strchr(file_name, '[');
const char *colon = ":";
/* can't use strchr here (not nul terminated) so use rninstr */
char *end = rninstr(file_name, file_name+file_name_len-1, colon, colon+1);
if (!start || !end || start > end) { /* should never happen */
logwarn("NYTProf unsupported filename syntax '%s'\n", file_name);
return 0;
}
++start; /* move past [ */
/* recurse */
found->eval_fid = get_file_id(aTHX_ start, end - start,
NYTP_FIDf_IS_EVAL | created_via);
found->eval_line_num = atoi(end+1);
}
else if (filename_is_eval(file_name, file_name_len)) {
/* strange eval that doesn't have a filename associated */
/* seen in mod_perl, possibly from eval_sv(sv) api call */
/* also when nameevals=0 option is in effect */
char eval_file[] = "/unknown-eval-invoker";
found->eval_fid = get_file_id(aTHX_ eval_file, sizeof(eval_file) - 1,
NYTP_FIDf_IS_EVAL | NYTP_FIDf_IS_FAKE | created_via
);
found->eval_line_num = 1;
}
}
/* detect Class::MOP #line evals */
/* See _add_line_directive() in Class::MOP::Method::Generated */
if (!found->eval_fid) {
char *tag = ninstr(file_name, file_name+file_name_len, class_mop_evaltag, class_mop_evaltag+class_mop_evaltag_len);
if (tag) {
char *definer = tag + class_mop_evaltag_len;
int len = file_name_len - (definer - file_name);
found->eval_fid = get_file_id(aTHX_ definer, len, created_via);
found->eval_line_num = 1; /* XXX pity Class::MOP doesn't include the line here */
if (trace_level >= 1)
logwarn("Class::MOP eval for '%.*s' (fid %u:%u) from '%.*s'\n",
len, definer, found->eval_fid, found->eval_line_num,
(int)file_name_len, file_name);
}
}
/* is the file is an autosplit, e.g., has a file_name like
* "../../lib/POSIX.pm (autosplit into ../../lib/auto/POSIX/errno.al)"
*/
if ( ')' == file_name[file_name_len-1] && strstr(file_name, " (autosplit ")) {
found->fid_flags |= NYTP_FIDf_IS_AUTOSPLIT;
}
/* if the file is an autosplit
* then we want it to have the same fid as the file it was split from.
* Thankfully that file will almost certainly be in the fid hash,
* so we can find it and copy the details.
* We do this after the string eval check above in the (untested) hope
* that string evals inside autoloaded subs get treated properly! XXX
*/
if (found->fid_flags & NYTP_FIDf_IS_AUTOSPLIT
&& (parent_entry = find_autosplit_parent(aTHX_ file_name))
) {
/* copy some details from parent_entry to found */
found->he.id = parent_entry->he.id;
found->eval_fid = parent_entry->eval_fid;
found->eval_line_num = parent_entry->eval_line_num;
found->file_size = parent_entry->file_size;
found->file_mtime = parent_entry->file_mtime;
found->fid_flags = parent_entry->fid_flags;
/* prevent write_cached_fids() from writing this fid */
found->fid_flags |= NYTP_FIDf_IS_ALIAS;
/* avoid a gap in the fid sequence */
--fidhash.next_id;
/* write a log message if tracing */
if (trace_level >= 2)
logwarn("Use fid %2u (after %2u:%-4u) %x e%u:%u %.*s %s\n",
found->he.id, last_executed_fid, last_executed_line,
found->fid_flags, found->eval_fid, found->eval_line_num,
found->he.key_len, found->he.key, (found->key_abs) ? found->key_abs : "");
/* bail out without calling emit_fid() */
return found->he.id;
}
/* determine absolute path if file_name is relative */
found->key_abs = NULL;
if (!found->eval_fid &&
!(file_name[0] == '-'
&& (file_name_len==1 || (file_name[1]=='e' && file_name_len==2))) &&
#ifdef WIN32
/* XXX should we check for UNC names too? */
(file_name_len < 3 || !isALPHA(file_name[0]) || file_name[1] != ':' ||
(file_name[2] != '/' && file_name[2] != '\\'))
#else
*file_name != '/'
#endif
) {
char file_name_abs[MAXPATHLEN * 2];
/* Note that the current directory may have changed
* between loading the file and profiling it.
* We don't use realpath() or similar here because we want to
* keep the view of symlinks etc. as the program saw them.
*/
if (!getcwd(file_name_abs, sizeof(file_name_abs))) {
/* eg permission */
logwarn("getcwd: %s\n", strerror(errno));
}
else {
#ifdef WIN32
char *p = file_name_abs;
while (*p) {
if ('\\' == *p)
*p = '/';
++p;
}
if (p[-1] != '/')
#else
if (strNE(file_name_abs, "/"))
#endif
{
if (strnEQ(file_name, "./", 2)) {
++file_name;
} else {
#ifndef VMS
strcat(file_name_abs, "/");
#endif
}
}
strncat(file_name_abs, file_name, file_name_len);
found->key_abs = strdup(file_name_abs);
}
}
if (fid_is_pmc(aTHX_ found))
found->fid_flags |= NYTP_FIDf_IS_PMC;
found->fid_flags |= created_via; /* NYTP_FIDf_VIA_STMT or NYTP_FIDf_VIA_SUB */
/* is source code available? */
/* source only available if PERLDB_LINE or PERLDB_SAVESRC is true */
/* which we set if savesrc option is enabled */
if ( (src_av = GvAV(gv_fetchfile_flags(found->he.key, found->he.key_len, 0))) )
if (av_len(src_av) > -1)
found->fid_flags |= NYTP_FIDf_HAS_SRC;
/* flag "perl -e '...'" and "perl -" as string evals */
if (found->he.key[0] == '-' && (found->he.key_len == 1 ||
(found->he.key[1] == 'e' && found->he.key_len == 2)))
found->fid_flags |= NYTP_FIDf_IS_EVAL;
/* if it's a string eval or a synthetic filename from CODE ref in @INC,
* then we'd like to save the src (NYTP_FIDf_HAS_SRC) if it's available
*/
if (found->eval_fid
|| (found->fid_flags & NYTP_FIDf_IS_EVAL)
|| (profile_opts & NYTP_OPTf_SAVESRC)
|| (found->he.key_len > 10 && found->he.key[9] == 'x' && strnEQ(found->he.key, "/loader/0x", 10))
) {
found->fid_flags |= NYTP_FIDf_SAVE_SRC;
}
emit_fid(found);
if (trace_level >= 2) {
char buf[80];
/* including last_executed_fid can be handy for tracking down how
* a file got loaded */
logwarn("New fid %2u (after %2u:%-4u) 0x%02x e%u:%u %.*s %s %s\n",
found->he.id, last_executed_fid, last_executed_line,
found->fid_flags, found->eval_fid, found->eval_line_num,
found->he.key_len, found->he.key, (found->key_abs) ? found->key_abs : "",
fmt_fid_flags(aTHX_ found->fid_flags, buf, sizeof(buf))
);
}
return found->he.id;
}
/**
* Return a unique persistent id number for a string.
*/
static unsigned int
get_str_id(pTHX_ char* str, STRLEN len)
{
str_hash_entry *found;
hash_op(&strhash, str, len, (Hash_entry**)&found, 1);
return found->he.id;
}
static UV
uv_from_av(pTHX_ AV *av, int idx, UV default_uv)
{
SV **svp = av_fetch(av, idx, 0);
UV uv = (!svp || !SvOK(*svp)) ? default_uv : SvUV(*svp);
return uv;
}
static NV
nv_from_av(pTHX_ AV *av, int idx, NV default_nv)
{
SV **svp = av_fetch(av, idx, 0);
NV nv = (!svp || !SvOK(*svp)) ? default_nv : SvNV(*svp);
return nv;
}
static const char *
cx_block_type(PERL_CONTEXT *cx) {
static char buf[20];
switch (CxTYPE(cx)) {
case CXt_NULL: return "CXt_NULL";
case CXt_SUB: return "CXt_SUB";
case CXt_FORMAT: return "CXt_FORMAT";
case CXt_EVAL: return "CXt_EVAL";
case CXt_SUBST: return "CXt_SUBST";
#ifdef CXt_WHEN
case CXt_WHEN: return "CXt_WHEN";
#endif
case CXt_BLOCK: return "CXt_BLOCK";
#ifdef CXt_GIVEN
case CXt_GIVEN: return "CXt_GIVEN";
#endif
#ifdef CXt_LOOP
case CXt_LOOP: return "CXt_LOOP";
#endif
#ifdef CXt_LOOP_FOR
case CXt_LOOP_FOR: return "CXt_LOOP_FOR";
#endif
#ifdef CXt_LOOP_PLAIN
case CXt_LOOP_PLAIN: return "CXt_LOOP_PLAIN";
#endif
#ifdef CXt_LOOP_LAZYSV
case CXt_LOOP_LAZYSV: return "CXt_LOOP_LAZYSV";
#endif
#ifdef CXt_LOOP_LAZYIV
case CXt_LOOP_LAZYIV: return "CXt_LOOP_LAZYIV";
#endif
}
/* short-lived and not thread safe but we only use this for tracing
* and it should never be reached anyway
*/
sprintf(buf, "CXt_%ld", (long)CxTYPE(cx));
return buf;
}
/* based on S_dopoptosub_at() from perl pp_ctl.c */
static int
dopopcx_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock, UV cx_type_mask)
{
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
UV type_bit;
cx = &cxstk[i];
type_bit = 1 << CxTYPE(cx);
if (type_bit & cx_type_mask)
return i;
}
return i; /* == -1 */
}
static COP *
start_cop_of_context(pTHX_ PERL_CONTEXT *cx)
{
OP *start_op, *o;
int type;
int trace = 6;
switch (CxTYPE(cx)) {
case CXt_EVAL:
start_op = (OP*)cx->blk_oldcop;
break;
case CXt_FORMAT:
start_op = CvSTART(cx->blk_sub.cv);
break;
case CXt_SUB:
start_op = CvSTART(cx->blk_sub.cv);
break;
#ifdef CXt_LOOP
case CXt_LOOP:
# if (PERL_VERSION < 10) || (PERL_VERSION == 9 && !defined(CX_LOOP_NEXTOP_GET))
start_op = cx->blk_loop.redo_op;
# else
start_op = cx->blk_loop.my_op->op_redoop;
# endif
break;
#else
# if defined (CXt_LOOP_PLAIN) && defined (CXt_LOOP_FOR) && defined(CXt_LOOP_LAZYIV) && defined (CXt_LOOP_LAZYSV)
/* This is Perl 5.11.0 or later */
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_PLAIN:
case CXt_LOOP_FOR:
start_op = cx->blk_loop.my_op->op_redoop;
break;
# else
# warning "The perl you are using is missing some essential defines. Your results may not be accurate."
# endif
#endif
case CXt_BLOCK:
/* this will be NULL for the top-level 'main' block */
start_op = (OP*)cx->blk_oldcop;
break;
case CXt_SUBST: /* FALLTHRU */
case CXt_NULL: /* FALLTHRU */
default:
start_op = NULL;
break;
}
if (!start_op) {
if (trace_level >= trace)
logwarn("\tstart_cop_of_context: can't find start of %s\n",
cx_block_type(cx));
return NULL;
}
/* find next cop from OP */
o = start_op;
while ( o && (type = (o->op_type) ? o->op_type : (int)o->op_targ) ) {
if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
if (trace_level >= trace)
logwarn("\tstart_cop_of_context %s is %s line %d of %s\n",
cx_block_type(cx), OP_NAME(o), (int)CopLINE((COP*)o),
OutCopFILE((COP*)o));
return (COP*)o;
}
if (trace_level >= trace)
logwarn("\tstart_cop_of_context %s op '%s' isn't a cop, giving up\n",
cx_block_type(cx), OP_NAME(o));
return NULL;
#if 0 /* old code that never worked very well anyway */
if (CxTYPE(cx) == CXt_LOOP) /* e.g. "eval $_ for @ary" */
return NULL;
/* should never get here but we do */
if (trace_level >= trace) {
logwarn("\tstart_cop_of_context %s op '%s' isn't a cop\n",
cx_block_type(cx), OP_NAME(o));
if (trace_level > trace)
do_op_dump(1, PerlIO_stderr(), o);
}
o = o->op_next;
#endif
}
if (trace_level >= 3) {
logwarn("\tstart_cop_of_context: can't find next cop for %s line %ld\n",
cx_block_type(cx), (long)CopLINE(PL_curcop_nytprof));
do_op_dump(1, PerlIO_stderr(), start_op);
}
return NULL;
}
/* Walk up the context stack calling callback
* return first context that callback returns true for
* else return null.
* UV cx_type_mask is a bit flag that specifies what kinds of contexts the
* callback should be called for: (cx_type_mask & (1 << CxTYPE(cx)))
* Use ~0 to stop at all contexts.
* The callback is called with the context pointer and a pointer to
* a copy of the UV cx_type_mask argument (so it can change it on the fly).
*/
static PERL_CONTEXT *
visit_contexts(pTHX_ UV cx_type_mask, int (*callback)(pTHX_ PERL_CONTEXT *cx,
UV *cx_type_mask_ptr))
{
/* modelled on pp_caller() in pp_ctl.c */
register I32 cxix = cxstack_ix;
register PERL_CONTEXT *cx = NULL;
register PERL_CONTEXT *ccstack = cxstack;
PERL_SI *top_si = PL_curstackinfo;
if (trace_level >= 6)
logwarn("visit_contexts: \n");
while (1) {
/* we may be in a higher stacklevel, so dig down deeper */
/* XXX so we'll miss code in sort blocks and signals? */
/* callback should perhaps be moved to dopopcx_at */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
if (trace_level >= 6)
logwarn("Not on main stack (type %d); digging top_si %p->%p, ccstack %p->%p\n",
(int)top_si->si_type, (void*)top_si, (void*)top_si->si_prev,
(void*)ccstack, (void*)top_si->si_cxstack);
top_si = top_si->si_prev;
ccstack = top_si->si_cxstack;
cxix = dopopcx_at(aTHX_ ccstack, top_si->si_cxix, cx_type_mask);
}
if (cxix < 0 || (cxix == 0 && !top_si->si_prev)) {
/* cxix==0 && !top_si->si_prev => top-level BLOCK */
if (trace_level >= 5)
logwarn("visit_contexts: reached top of context stack\n");
return NULL;
}
cx = &ccstack[cxix];
if (trace_level >= 5)
logwarn("visit_context: %s cxix %d (si_prev %p)\n",
cx_block_type(cx), (int)cxix, (void*)top_si->si_prev);
if (callback(aTHX_ cx, &cx_type_mask))
return cx;
/* no joy, look further */
cxix = dopopcx_at(aTHX_ ccstack, cxix - 1, cx_type_mask);
}
return NULL; /* not reached */
}
static int
_cop_in_same_file(COP *a, COP *b)
{
int same = 0;
char *a_file = OutCopFILE(a);
char *b_file = OutCopFILE(b);
if (a_file == b_file)
same = 1;
else
/* fallback to strEQ, surprisingly common (check why) XXX expensive */
if (strEQ(a_file, b_file))
same = 1;
return same;
}
static int
_check_context(pTHX_ PERL_CONTEXT *cx, UV *cx_type_mask_ptr)
{
COP *near_cop;
PERL_UNUSED_ARG(cx_type_mask_ptr);
if (CxTYPE(cx) == CXt_SUB) {
if (PL_debstash && CvSTASH(cx->blk_sub.cv) == PL_debstash)
return 0; /* skip subs in DB package */
near_cop = start_cop_of_context(aTHX_ cx);
/* only use the cop if it's in the same file */
if (_cop_in_same_file(near_cop, PL_curcop_nytprof)) {
last_sub_line = CopLINE(near_cop);
/* treat sub as a block if we've not found a block yet */
if (!last_block_line)
last_block_line = last_sub_line;
}
if (trace_level >= 8) {
GV *sv = CvGV(cx->blk_sub.cv);
logwarn("\tat %d: block %d sub %d for %s %s\n",
last_executed_line, last_block_line, last_sub_line,
cx_block_type(cx), (sv) ? GvNAME(sv) : "");
if (trace_level >= 99)
sv_dump((SV*)cx->blk_sub.cv);
}
return 1; /* stop looking */
}
/* NULL, EVAL, LOOP, SUBST, BLOCK context */
if (trace_level >= 6)
logwarn("\t%s\n", cx_block_type(cx));
/* if we've got a block line, skip this context and keep looking for a sub */
if (last_block_line)
return 0;
/* if we can't get a line number for this context, skip it */
if ((near_cop = start_cop_of_context(aTHX_ cx)) == NULL)
return 0;
/* if this context is in a different file... */
if (!_cop_in_same_file(near_cop, PL_curcop_nytprof)) {
/* if we started in a string eval ... */
if ('(' == *OutCopFILE(PL_curcop_nytprof)) {
/* give up XXX could do better here */
last_block_line = last_sub_line = last_executed_line;
return 1;
}
/* shouldn't happen! */
if (trace_level >= 5)
logwarn("at %d: %s in different file (%s, %s)\n",
last_executed_line, cx_block_type(cx),
OutCopFILE(near_cop), OutCopFILE(PL_curcop_nytprof));
return 1; /* stop looking */
}
last_block_line = CopLINE(near_cop);
if (trace_level >= 5)
logwarn("\tat %d: block %d for %s\n",
last_executed_line, last_block_line, cx_block_type(cx));
return 0;
}
/* copied from perl's S_closest_cop in util.c as used by warn(...) */
static const COP*
closest_cop(pTHX_ const COP *cop, const OP *o)
{
dVAR;
/* Look for PL_op starting from o. cop is the last COP we've seen. */
if (!o || o == PL_op)
return cop;
if (o->op_flags & OPf_KIDS) {
const OP *kid;
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
const COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
* the get the file and line number. */
if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
cop = (const COP *)kid;
/* Keep searching, and return when we've found something. */
new_cop = closest_cop(aTHX_ cop, kid);
if (new_cop)
return new_cop;
}
}
/* Nothing found. */
return NULL;
}
/**
* Main statement profiling function. Called before each breakable statement.
*/
static void
DB_stmt(pTHX_ COP *cop, OP *op)
{
int saved_errno;
char *file;
long elapsed, overflow;
if (!is_profiling || !profile_stmts)
return;
#ifdef MULTIPLICITY
if (orig_my_perl && my_perl != orig_my_perl)
return;
#endif
saved_errno = errno;
get_time_of_day(end_time);
get_ticks_between(long, start_time, end_time, elapsed, overflow);
reinit_if_forked(aTHX);
/* XXX move down into the (file != last_executed_fileptr) block ? */
CHECK_SAWAMPERSAND(last_executed_fid, last_executed_line);
if (last_executed_fid) {
if (profile_blocks)
NYTP_write_time_block(out, elapsed, overflow, last_executed_fid,
last_executed_line, last_block_line,
last_sub_line);
else
NYTP_write_time_line(out, elapsed, overflow, last_executed_fid,
last_executed_line);
if (trace_level >= 5) /* previous fid:line and how much time we spent there */
logwarn("\t@%d:%-4d %2ld ticks (%u, %u)\n",
last_executed_fid, last_executed_line,
elapsed, last_block_line, last_sub_line);
}
if (!cop)
cop = PL_curcop_nytprof;
if ( (last_executed_line = CopLINE(cop)) == 0 ) {
/* Might be a cop that has been optimised away. We can try to find such a
* cop by searching through the optree starting from the sibling of PL_curcop.
* See Perl_vmess in perl's util.c for how warn("...") finds the line number.
*/
cop = (COP*)closest_cop(aTHX_ cop, cop->op_sibling);
if (!cop)
cop = PL_curcop_nytprof;
last_executed_line = CopLINE(cop);
if (!last_executed_line) {
/* perl options, like -n, -p, -Mfoo etc can cause this because perl effectively
* treats those as 'line 0', so we try not to warn in those cases.
*/
char *pkg_name = CopSTASHPV(cop);
int is_preamble = (PL_scopestack_ix <= 7 && strEQ(pkg_name,"main"));
/* op is null when called via finish_profile called by END */
if (!is_preamble && op) {
/* warn() can't either, in the cases I've encountered */
logwarn("Unable to determine line number in %s (ssix%d)\n",
OutCopFILE(cop), (int)PL_scopestack_ix);
if (trace_level > 5)
do_op_dump(1, PerlIO_stderr(), (OP*)cop);
}
last_executed_line = 1; /* don't want zero line numbers in data */
}
}
file = OutCopFILE(cop);
if (!last_executed_fid) { /* first time */
if (trace_level >= 1) {
logwarn("~ first statement profiled at line %d of %s, pid %ld\n",
(int)CopLINE(cop), OutCopFILE(cop), (long)getpid());
}
}
if (file != last_executed_fileptr) { /* cache (hit ratio ~50% e.g. for perlcritic) */
last_executed_fileptr = file;
last_executed_fid = get_file_id(aTHX_ file, strlen(file), NYTP_FIDf_VIA_STMT);
}
if (trace_level >= 7) /* show the fid:line we're about to execute */
logwarn("\t@%d:%-4d... %s\n", last_executed_fid, last_executed_line,
(profile_blocks) ? "looking for block and sub lines" : "");
if (profile_blocks) {
last_block_line = 0;
last_sub_line = 0;
if (op) {
visit_contexts(aTHX_ ~0, &_check_context);
}
/* if we didn't find block or sub scopes then use current line */
if (!last_block_line) last_block_line = last_executed_line;
if (!last_sub_line) last_sub_line = last_executed_line;
}
get_time_of_day(start_time);
/* measure time we've spent measuring so we can discount it */
get_ticks_between(long, end_time, start_time, elapsed, overflow);
cumulative_overhead_ticks += elapsed;
SETERRNO(saved_errno, 0);
return;
}
static void
DB_leave(pTHX_ OP *op, OP *prev_op)
{
int saved_errno, is_multicall;
unsigned int prev_last_executed_fid, prev_last_executed_line;
/* Called _after_ ops that indicate we've completed a statement
* and are returning into the middle of some outer statement.
* Used to ensure that time between now and the _next_ statement
* being entered, is allocated to the outer statement we've
* returned into and not the previous statement.
* PL_curcop has already been updated.
*/
if (!is_profiling || !out || !profile_stmts)
return;
#ifdef MULTIPLICITY
if (orig_my_perl && my_perl != orig_my_perl)
return;
#endif
saved_errno = errno;
prev_last_executed_fid = last_executed_fid;
prev_last_executed_line = last_executed_line;
#if defined(CxMULTICALL) && 0 /* disabled for now */
/* pp_return, pp_leavesub and pp_leavesublv
* return a NULL op when returning from a MULTICALL.
* See Lightweight Callbacks in perlcall.
*/
is_multicall = (!op && cxstack_ix >= 0 && CxMULTICALL(&cxstack[cxstack_ix]));
#else
is_multicall = 0;
#endif
/* measure and output end time of previous statement
* (earlier than it would have been done)
* and switch back to measuring the 'calling' statement
*/
DB_stmt(aTHX_ NULL, op);
/* output a 'discount' marker to indicate the next statement time shouldn't
* increment the count (because the time is not for a new statement but simply
* a continuation of a previously counted statement).
*/
NYTP_write_discount(out);
/* special cases */
if (last_executed_line == prev_last_executed_line
&& last_executed_fid == prev_last_executed_fid
) {
/* XXX OP_UNSTACK needs help */
}
if (trace_level >= 5) {
logwarn("\tleft %u:%u via %s back to %s at %u:%u (b%u s%u) - discounting next statement%s\n",
prev_last_executed_fid, prev_last_executed_line,
OP_NAME_safe(prev_op), OP_NAME_safe(op),
last_executed_fid, last_executed_line, last_block_line, last_sub_line,
(op || is_multicall) ? "" : ", LEAVING PERL"
);
}
SETERRNO(saved_errno, 0);
}
/**
* Sets or toggles the option specified by 'option'.
*/
static void
set_option(pTHX_ const char* option, const char* value)
{
if (!value || !*value)
croak("%s: invalid option", "NYTProf set_option");
if (!value || !*value)
croak("%s: '%s' has no value", "NYTProf set_option", option);
if (strEQ(option, "file")) {
strncpy(PROF_output_file, value, MAXPATHLEN);
}
else if (strEQ(option, "log")) {
FILE *fp = fopen(value, "a");
if (!fp) {
logwarn("Can't open log file '%s' for writing: %s\n",
value, strerror(errno));
return;
}
logfh = fp;
}
else if (strEQ(option, "start")) {
if (strEQ(value,"begin")) profile_start = NYTP_START_BEGIN;
else if (strEQ(value,"init")) profile_start = NYTP_START_INIT;
else if (strEQ(value,"end")) profile_start = NYTP_START_END;
else if (strEQ(value,"no")) profile_start = NYTP_START_NO;
else croak("NYTProf option 'start' has invalid value '%s'\n", value);
}
else if (strEQ(option, "addpid")) {
profile_opts = (atoi(value))
? profile_opts | NYTP_OPTf_ADDPID
: profile_opts & ~NYTP_OPTf_ADDPID;
}
else if (strEQ(option, "optimize") || strEQ(option, "optimise")) {
profile_opts = (atoi(value))
? profile_opts | NYTP_OPTf_OPTIMIZE
: profile_opts & ~NYTP_OPTf_OPTIMIZE;
}
else if (strEQ(option, "savesrc")) {
profile_opts = (atoi(value))
? profile_opts | NYTP_OPTf_SAVESRC
: profile_opts & ~NYTP_OPTf_SAVESRC;
}
else if (strEQ(option, "endatexit")) {
if (atoi(value))
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
}
else if (strEQ(option, "libcexit")) {
if (atoi(value))
atexit(finish_profile_nocontext);
}
else {
struct NYTP_options_t *opt_p = options;
const struct NYTP_options_t *const opt_end
= options + sizeof(options) / sizeof (struct NYTP_options_t);
bool found = FALSE;
do {
if (strEQ(option, opt_p->option_name)) {
opt_p->option_iv = (IV)strtol(value, NULL, 0);
found = TRUE;
break;
}
} while (++opt_p < opt_end);
if (!found) {
logwarn("Unknown NYTProf option: '%s'\n", option);
return;
}
}
if (trace_level)
logwarn("# %s=%s\n", option, value);
}
/**
* Open the output file. This is encapsulated because the code can be reused
* without the environment parsing overhead after each fork.
*/
static void
open_output_file(pTHX_ char *filename)
{
char filename_buf[MAXPATHLEN];
/* 'x' is a GNU C lib extension for O_EXCL which gives us a little
* extra protection, but it isn't POSIX compliant */
const char *mode = (strnEQ(filename, "/dev/", 4) ? "wb" : "wbx");
/* most systems that don't support it will silently ignore it
* but for some we need to remove it to avoid an error */
#ifdef WIN32
mode = "wb";
#endif
#ifdef VMS
mode = "wb";
#endif
if ((profile_opts & NYTP_OPTf_ADDPID)
|| out /* already opened so assume forking */
) {
sprintf(filename_buf, "%s.%d", filename, getpid());
filename = filename_buf;
/* caller is expected to have purged/closed old out if appropriate */
}
/* some protection against multiple processes writing to the same file */
unlink(filename); /* throw away any previous file */
out = NYTP_open(filename, mode);
if (!out) {
int fopen_errno = errno;
const char *hint = "";
if (fopen_errno==EEXIST && !(profile_opts & NYTP_OPTf_ADDPID))
hint = " (enable addpid option to protect against concurrent writes)";
disable_profile(aTHX);
croak("NYTProf failed to open '%s' for writing, error %d: %s%s",
filename, fopen_errno, strerror(fopen_errno), hint);
}
if (trace_level >= 1)
logwarn("~ opened %s at %.6f\n", filename, gettimeofday_nv());
output_header(aTHX);
}
static void
close_output_file(pTHX) {
int result;
NV timeofday;
if (!out)
return;
timeofday = gettimeofday_nv(); /* before write_*() calls */
NYTP_write_attribute_nv(out, STR_WITH_LEN("cumulative_overhead_ticks"), cumulative_overhead_ticks);
write_src_of_files(aTHX);
write_sub_line_ranges(aTHX);
write_sub_callers(aTHX);
/* mark end of profile data for last_pid pid
* which is the pid that this file relates to
*/
NYTP_write_process_end(out, last_pid, timeofday);
if ((result = NYTP_close(out, 0)))
logwarn("Error closing profile data file: %s\n", strerror(result));
out = NULL;
if (trace_level >= 1)
logwarn("~ closed file at %.6f\n", timeofday);
}
static int
reinit_if_forked(pTHX)
{
int open_new_file;
if (getpid() == last_pid)
return 0; /* not forked */
/* we're now the child process */
if (trace_level >= 1)
logwarn("~ new pid %d (was %d) forkdepth %ld\n", getpid(), last_pid, profile_forkdepth);
/* reset state */
last_pid = getpid();
last_executed_fileptr = NULL;
last_executed_fid = 0; /* don't count the fork in the child */
if (sub_callers_hv)
hv_clear(sub_callers_hv);
open_new_file = (out) ? 1 : 0;
if (open_new_file) {
/* data that was unflushed in the parent when it forked
* is now duplicated unflushed in this child,
* so discard it when we close the inherited filehandle.
*/
int result = NYTP_close(out, 1);
if (result)
logwarn("Error closing profile data file: %s\n", strerror(result));
out = NULL;
/* if we fork while profiling then ensure we'll get a distinct filename */
profile_opts |= NYTP_OPTf_ADDPID;
}
if (profile_forkdepth == 0) { /* parent doesn't want children profiled */
disable_profile(aTHX);
open_new_file = 0;
}
else /* count down another generation */
--profile_forkdepth;
if (open_new_file)
open_output_file(aTHX_ PROF_output_file);
return 1; /* have forked */
}
/******************************************
* Sub caller and inclusive time tracking
******************************************/
static AV *
new_sub_call_info_av(pTHX)
{
AV *av = newAV();
av_store(av, NYTP_SCi_CALL_COUNT, newSVuv(1));
av_store(av, NYTP_SCi_INCL_RTIME, newSVnv(0.0));
av_store(av, NYTP_SCi_EXCL_RTIME, newSVnv(0.0));
av_store(av, NYTP_SCi_INCL_TICKS, newSVnv(0.0));
av_store(av, NYTP_SCi_EXCL_TICKS, newSVnv(0.0));
/* others allocated when needed */
return av;
}
/* subroutine profiler subroutine entry structure. Represents a call
* from one sub to another (the arc between the nodes, if you like)
*/
typedef struct subr_entry_st subr_entry_t;
struct subr_entry_st {
unsigned int already_counted;
U32 subr_prof_depth;
long unsigned subr_call_seqn;
I32 prev_subr_entry_ix; /* ix to callers subr_entry */
time_of_day_t initial_call_timeofday;
struct tms initial_call_cputimes;
NV initial_overhead_ticks;
NV initial_subr_ticks;
unsigned int caller_fid;
int caller_line;
const char *caller_subpkg_pv;
SV *caller_subnam_sv;
CV *called_cv;
int called_cv_depth;
const char *called_is_xs; /* NULL, "xsub", or "syop" */
const char *called_subpkg_pv;
SV *called_subnam_sv;
/* ensure all items are initialized in first phase of pp_subcall_profiler */
int hide_subr_call_time; /* eg for CORE:accept */
};
/* save stack index to the current subroutine entry structure */
static I32 subr_entry_ix = 0;
#define subr_entry_ix_ptr(ix) ((ix) ? SSPTR(ix, subr_entry_t *) : NULL)
static void
append_linenum_to_begin(pTHX_ subr_entry_t *subr_entry) {
UV line = 0;
SV *fullnamesv;
SV *DBsv;
char *subname = SvPVX(subr_entry->called_subnam_sv);
STRLEN pkg_len;
STRLEN total_len;
/* If sub is a BEGIN then append the line number to our name
* so multiple BEGINs (either explicit or implicit, e.g., "use")
* in the same file/package can be distinguished.
*/
if (!subname || *subname != 'B' || strNE(subname,"BEGIN"))
return;
/* get, and delete, the entry for this sub in the PL_DBsub hash */
pkg_len = strlen(subr_entry->called_subpkg_pv);
total_len = pkg_len + 2 /* :: */ + 5; /* BEGIN */
fullnamesv = newSV(total_len + 1); /* +1 for '\0' */
memcpy(SvPVX(fullnamesv), subr_entry->called_subpkg_pv, pkg_len);
memcpy(SvPVX(fullnamesv) + pkg_len, "::BEGIN", 7 + 1); /* + 1 for '\0' */
SvCUR_set(fullnamesv, total_len);
SvPOK_on(fullnamesv);
DBsv = hv_delete(GvHV(PL_DBsub), SvPVX(fullnamesv), (I32)total_len, 1);
if (DBsv && parse_DBsub_value(aTHX_ DBsv, NULL, &line, NULL, SvPVX(fullnamesv))) {
(void)SvREFCNT_inc(DBsv); /* was made mortal by hv_delete */
sv_catpvf(fullnamesv, "@%u", (unsigned int)line);
if (hv_fetch(GvHV(PL_DBsub), SvPV_nolen(fullnamesv), (I32)SvCUR(fullnamesv), 0)) {
static unsigned int dup_begin_seqn;
sv_catpvf(fullnamesv, ".%u", ++dup_begin_seqn);
}
(void) hv_store(GvHV(PL_DBsub), SvPV_nolen(fullnamesv), (I32)SvCUR(fullnamesv), DBsv, 0);
/* As we know the length of fullnamesv *before* the concatenation, we
can calculate the length and offset of the formatted addition, and
hence directly string append it, rather than duplicating the call to
a *printf function. */
sv_catpvn(subr_entry->called_subnam_sv, SvPVX(fullnamesv) + total_len,
SvCUR(fullnamesv) - total_len);
}
SvREFCNT_dec(fullnamesv);
}
static char *
subr_entry_summary(pTHX_ subr_entry_t *subr_entry, int state)
{
static char buf[80]; /* XXX */
sprintf(buf, "(seix %d%s%d, ac%u)",
(int)subr_entry->prev_subr_entry_ix,
(state) ? "<-" : "->",
(int)subr_entry_ix,
subr_entry->already_counted
);
return buf;
}
static void
subr_entry_destroy(pTHX_ subr_entry_t *subr_entry)
{
if ((trace_level >= 6 || subr_entry->already_counted>1)
/* ignore the typical second (fallback) destroy */
&& !(subr_entry->prev_subr_entry_ix == subr_entry_ix && subr_entry->already_counted==1)
) {
logwarn("%2u << %s::%s done %s\n",
(unsigned int)subr_entry->subr_prof_depth,
subr_entry->called_subpkg_pv,
(subr_entry->called_subnam_sv && SvOK(subr_entry->called_subnam_sv))
? SvPV_nolen(subr_entry->called_subnam_sv)
: "?",
subr_entry_summary(aTHX_ subr_entry, 1));
}
if (subr_entry->caller_subnam_sv) {
sv_free(subr_entry->caller_subnam_sv);
subr_entry->caller_subnam_sv = Nullsv;
}
if (subr_entry->called_subnam_sv) {
sv_free(subr_entry->called_subnam_sv);
subr_entry->called_subnam_sv = Nullsv;
}
if (subr_entry->prev_subr_entry_ix <= subr_entry_ix)
subr_entry_ix = subr_entry->prev_subr_entry_ix;
else
logwarn("skipped attempt to raise subr_entry_ix from %d to %d\n",
(int)subr_entry_ix, (int)subr_entry->prev_subr_entry_ix);
}
static void
incr_sub_inclusive_time(pTHX_ subr_entry_t *subr_entry)
{
int saved_errno = errno;
char called_subname_pv[500]; /* XXX */
char *called_subname_pv_end = called_subname_pv;
char subr_call_key[500]; /* XXX */
int subr_call_key_len;
NV overhead_ticks, called_sub_ticks;
SV *incl_time_sv, *excl_time_sv;
NV incl_subr_ticks, excl_subr_ticks;
SV *sv_tmp;
AV *subr_call_av;
time_of_day_t sub_end_time;
long ticks, overflow;
/* an undef SV is a special marker used by subr_entry_setup */
if (subr_entry->called_subnam_sv && !SvOK(subr_entry->called_subnam_sv)) {
if (trace_level)
logwarn("Don't know name of called sub, assuming xsub/builtin exited via an exception (which isn't handled yet)\n");
subr_entry->already_counted++;
}
/* For xsubs we get called both explicitly when the xsub returns, and by
* the destructor. (That way if the xsub leaves via an exception then we'll
* still get called, albeit a little later than we'd like.)
*/
if (subr_entry->already_counted) {
subr_entry_destroy(aTHX_ subr_entry);
return;
}
subr_entry->already_counted++;
/* statement overheads we've accumulated since we entered the sub */
overhead_ticks = cumulative_overhead_ticks - subr_entry->initial_overhead_ticks;
/* ticks spent in subroutines called by this subroutine */
called_sub_ticks = cumulative_subr_ticks - subr_entry->initial_subr_ticks;
/* calculate ticks since we entered the sub */
get_time_of_day(sub_end_time);
get_ticks_between(NV, subr_entry->initial_call_timeofday, sub_end_time, ticks, overflow);
incl_subr_ticks = (overflow*ticks_per_sec) + ticks;
/* subtract statement measurement overheads */
incl_subr_ticks -= overhead_ticks;
if (subr_entry->hide_subr_call_time) {
/* account for the time spent in the sub as if it was statement
* profiler overhead. That has the effect of neatly subtracting
* the time from all the sub calls up the call stack.
*/
cumulative_overhead_ticks += incl_subr_ticks;
incl_subr_ticks = 0;
called_sub_ticks = 0;
}
/* exclusive = inclusive - time spent in subroutines called by this subroutine */
excl_subr_ticks = incl_subr_ticks - called_sub_ticks;
subr_call_key_len = sprintf(subr_call_key, "%s::%s[%u:%d]",
subr_entry->caller_subpkg_pv,
(subr_entry->caller_subnam_sv) ? SvPV_nolen(subr_entry->caller_subnam_sv) : "(null)",
subr_entry->caller_fid, subr_entry->caller_line);
if (subr_call_key_len >= sizeof(subr_call_key))
croak("panic: NYTProf buffer overflow on %s\n", subr_call_key);
/* compose called_subname_pv as "${pkg}::${sub}" avoiding sprintf */
STMT_START {
STRLEN len;
const char *p;
p = subr_entry->called_subpkg_pv;
while (*p)
*called_subname_pv_end++ = *p++;
*called_subname_pv_end++ = ':';
*called_subname_pv_end++ = ':';
if (subr_entry->called_subnam_sv) {
/* We create this SV, so we know that it is well-formed, and has a
trailing '\0' */
p = SvPV(subr_entry->called_subnam_sv, len);
}
else {
/* C string constants have a trailing '\0'. */
p = "(null)"; len = 6;
}
memcpy(called_subname_pv_end, p, len + 1);
called_subname_pv_end += len;
if (called_subname_pv_end >= called_subname_pv+sizeof(called_subname_pv))
croak("panic: called_subname_pv buffer overflow on '%s'\n", called_subname_pv);
} STMT_END;
/* { called_subname => { "caller_subname[fid:line]" => [ count, incl_time, ... ] } } */
sv_tmp = *hv_fetch(sub_callers_hv, called_subname_pv, (I32)(called_subname_pv_end - called_subname_pv), 1);
if (!SvROK(sv_tmp)) { /* autoviv hash ref - is first call of this called subname from anywhere */
HV *hv = newHV();
sv_setsv(sv_tmp, newRV_noinc((SV *)hv));
if (subr_entry->called_is_xs) {
/* create dummy item with fid=0 & line=0 to act as flag to indicate xs */
AV *av = new_sub_call_info_av(aTHX);
av_store(av, NYTP_SCi_CALL_COUNT, newSVuv(0));
sv_setsv(*hv_fetch(hv, "[0:0]", 5, 1), newRV_noinc((SV *)av));
if ( ('s' == *subr_entry->called_is_xs) /* "sop" (slowop) */
|| (subr_entry->called_cv && SvTYPE(subr_entry->called_cv) == SVt_PVCV)
) {
/* We just use an empty string as the filename for xsubs
* because CvFILE() isn't reliable on perl 5.8.[78]
* and the name of the .c file isn't very useful anyway.
* The reader can try to associate the xsubs with the
* corresonding .pm file using the package part of the subname.
*/
SV *sv = *hv_fetch(GvHV(PL_DBsub), called_subname_pv, (I32)(called_subname_pv_end - called_subname_pv), 1);
if (!SvOK(sv))
sv_setpvs(sv, ":0-0"); /* empty file name */
if (trace_level >= 2)
logwarn("Marking '%s' as %s\n", called_subname_pv, subr_entry->called_is_xs);
}
}
}
/* drill-down to array of sub call information for this subr_call_key */
sv_tmp = *hv_fetch((HV*)SvRV(sv_tmp), subr_call_key, subr_call_key_len, 1);
if (!SvROK(sv_tmp)) { /* first call from this subname[fid:line] - autoviv array ref */
subr_call_av = new_sub_call_info_av(aTHX);
sv_setsv(sv_tmp, newRV_noinc((SV *)subr_call_av));
if (subr_entry->called_subpkg_pv) { /* note that a sub in this package was called */
SV *pf_sv = *hv_fetch(pkg_fids_hv, subr_entry->called_subpkg_pv, (I32)strlen(subr_entry->called_subpkg_pv), 1);
if (SvTYPE(pf_sv) == SVt_NULL) { /* log when first created */
sv_upgrade(pf_sv, SVt_PV);
if (trace_level >= 3)
logwarn("Noting that subs in package '%s' were called\n",
subr_entry->called_subpkg_pv);
}
}
}
else {
subr_call_av = (AV *)SvRV(sv_tmp);
sv_inc(AvARRAY(subr_call_av)[NYTP_SCi_CALL_COUNT]);
}
if (trace_level >= 5) {
logwarn("%2u <- %s %"NVgf" excl = %"NVgf"t incl - %"NVgf"t (%"NVgf"-%"NVgf"), oh %"NVff"-%"NVff"=%"NVff"t, d%d @%d:%d #%lu %p\n",
(unsigned int)subr_entry->subr_prof_depth, called_subname_pv,
excl_subr_ticks, incl_subr_ticks,
called_sub_ticks,
cumulative_subr_ticks, subr_entry->initial_subr_ticks,
cumulative_overhead_ticks, subr_entry->initial_overhead_ticks, overhead_ticks,
(int)subr_entry->called_cv_depth,
subr_entry->caller_fid, subr_entry->caller_line,
subr_entry->subr_call_seqn, (void*)subr_entry);
}
/* only count inclusive time for the outer-most calls */
if (subr_entry->called_cv_depth <= 1) {
incl_time_sv = *av_fetch(subr_call_av, NYTP_SCi_INCL_TICKS, 1);
sv_setnv(incl_time_sv, SvNV(incl_time_sv)+incl_subr_ticks);
}
else { /* recursing into an already entered sub */
/* measure max depth and accumulate incl time separately */
SV *reci_time_sv = *av_fetch(subr_call_av, NYTP_SCi_RECI_RTIME, 1);
SV *max_depth_sv = *av_fetch(subr_call_av, NYTP_SCi_REC_DEPTH, 1);
sv_setnv(reci_time_sv, (SvOK(reci_time_sv)) ? SvNV(reci_time_sv)+(incl_subr_ticks/ticks_per_sec) : (incl_subr_ticks/ticks_per_sec));
/* we track recursion depth here, which is called_cv_depth-1 */
if (!SvOK(max_depth_sv) || subr_entry->called_cv_depth-1 > SvIV(max_depth_sv))
sv_setiv(max_depth_sv, subr_entry->called_cv_depth-1);
}
excl_time_sv = *av_fetch(subr_call_av, NYTP_SCi_EXCL_TICKS, 1);
sv_setnv(excl_time_sv, SvNV(excl_time_sv)+excl_subr_ticks);
if (opt_calls && out) {
NYTP_write_call_return(out, subr_entry->subr_prof_depth, called_subname_pv, incl_subr_ticks, excl_subr_ticks);
}
subr_entry_destroy(aTHX_ subr_entry);
cumulative_subr_ticks += excl_subr_ticks;
SETERRNO(saved_errno, 0);
}
static void /* wrapper called at scope exit due to save_destructor below */
incr_sub_inclusive_time_ix(pTHX_ void *subr_entry_ix_void)
{
/* recover the I32 ix that was stored as a void pointer */
I32 save_ix = (I32)PTR2IV(subr_entry_ix_void);
incr_sub_inclusive_time(aTHX_ subr_entry_ix_ptr(save_ix));
}
static CV *
resolve_sub_to_cv(pTHX_ SV *sv, GV **subname_gv_ptr)
{
GV *dummy_gv;
HV *stash;
CV *cv;
if (!subname_gv_ptr)
subname_gv_ptr = &dummy_gv;
else
*subname_gv_ptr = Nullgv;
/* copied from top of perl's pp_entersub */
/* modified to return either CV or else a GV */
/* or a NULL in cases that pp_entersub would croak */
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
char *sym;
if (sv == &PL_sv_yes) { /* unfound import, ignore */
return NULL;
}
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
goto got_rv;
sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
}
else
sym = SvPV_nolen(sv);
if (!sym)
return NULL;
if (PL_op->op_private & HINT_STRICT_REFS)
return NULL;
cv = get_cv(sym, TRUE);
break;
}
got_rv:
{
SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
}
cv = (CV*)SvRV(sv);
if (SvTYPE(cv) == SVt_PVCV)
break;
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
return NULL;
case SVt_PVCV:
cv = (CV*)sv;
break;
case SVt_PVGV:
if (!(isGV_with_GP(sv) && (cv = GvCVu((GV*)sv))))
cv = sv_2cv(sv, &stash, subname_gv_ptr, FALSE);
if (!cv) /* would autoload in this situation */
return NULL;
break;
}
if (cv && !*subname_gv_ptr && CvGV(cv) && isGV_with_GP(CvGV(cv))) {
*subname_gv_ptr = CvGV(cv);
}
return cv;
}
static CV*
current_cv(pTHX_ I32 ix, PERL_SI *si)
{
/* returning the current cv */
/* logic based on perl's S_deb_curcv in dump.c */
/* see also http://search.cpan.org/dist/Devel-StackBlech/ */
PERL_CONTEXT *cx;
if (!si)
si = PL_curstackinfo;
if (ix < 0) {
/* caller isn't on the same stack so we'll walk the stacks as well */
if (si->si_type != PERLSI_MAIN)
return current_cv(aTHX_ si->si_prev->si_cxix, si->si_prev);
if (trace_level >= 9)
logwarn("finding current_cv(%d,%p) si_type %d - context stack empty\n",
(int)ix, (void*)si, (int)si->si_type);
return Nullcv; /* PL_main_cv ? */
}
cx = &si->si_cxstack[ix];
if (trace_level >= 9)
logwarn("finding current_cv(%d,%p) - cx_type %d %s, si_type %d\n",
(int)ix, (void*)si, CxTYPE(cx), cx_block_type(cx), (int)si->si_type);
/* the common case of finding the caller on the same stack */
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
return cx->blk_sub.cv;
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
return current_cv(aTHX_ ix - 1, si); /* recurse up stack */
else if (ix == 0 && si->si_type == PERLSI_MAIN)
return PL_main_cv;
else if (ix > 0) /* more on this stack? */
return current_cv(aTHX_ ix - 1, si); /* recurse up stack */
/* caller isn't on the same stack so we'll walk the stacks as well */
if (si->si_type != PERLSI_MAIN) {
return current_cv(aTHX_ si->si_prev->si_cxix, si->si_prev);
}
return Nullcv;
}
static I32
subr_entry_setup(pTHX_ COP *prev_cop, subr_entry_t *clone_subr_entry, OPCODE op_type, SV *subr_sv)
{
int saved_errno = errno;
subr_entry_t *subr_entry;
I32 prev_subr_entry_ix;
subr_entry_t *caller_subr_entry;
const char *found_caller_by;
char *file;
/* allocate struct to save stack (very efficient) */
/* XXX "warning: cast from pointer to integer of different size" with use64bitall=define */
prev_subr_entry_ix = subr_entry_ix;
subr_entry_ix = SSNEWa(sizeof(*subr_entry), MEM_ALIGNBYTES);
if (subr_entry_ix <= prev_subr_entry_ix) {
/* one cause of this is running NYTProf with threads */
logwarn("NYTProf panic: stack is confused, giving up! (Try running with subs=0)\n");
/* limit the damage */
disable_profile(aTHX);
return prev_subr_entry_ix;
}
subr_entry = subr_entry_ix_ptr(subr_entry_ix);
Zero(subr_entry, 1, subr_entry_t);
subr_entry->prev_subr_entry_ix = prev_subr_entry_ix;
caller_subr_entry = subr_entry_ix_ptr(prev_subr_entry_ix);
subr_entry->subr_prof_depth = (caller_subr_entry)
? caller_subr_entry->subr_prof_depth+1 : 1;
get_time_of_day(subr_entry->initial_call_timeofday);
subr_entry->initial_overhead_ticks = cumulative_overhead_ticks;
subr_entry->initial_subr_ticks = cumulative_subr_ticks;
subr_entry->subr_call_seqn = (unsigned long)(++cumulative_subr_seqn);
/* try to work out what sub's being called in advance
* mainly for xsubs because otherwise they're transparent
* because xsub calls don't get a new context
*/
if (op_type == OP_ENTERSUB || op_type == OP_GOTO) {
GV *called_gv = Nullgv;
subr_entry->called_cv = resolve_sub_to_cv(aTHX_ subr_sv, &called_gv);
if (called_gv) {
char *p = HvNAME(GvSTASH(called_gv));
subr_entry->called_subpkg_pv = p;
subr_entry->called_subnam_sv = newSVpv(GvNAME(called_gv), 0);
/* detect calls to POSIX::_exit */
if ('P'==*p++ && 'O'==*p++ && 'S'==*p++ && 'I'==*p++ && 'X'==*p++ && 0==*p) {
char *s = GvNAME(called_gv);
if ('_'==*s++ && 'e'==*s++ && 'x'==*s++ && 'i'==*s++ && 't'==*s++ && 0==*s) {
finish_profile(aTHX);
}
}
}
else {
/* resolve_sub_to_cv couldn't work out what's being called,
* possibly because it's something that'll cause pp_entersub to croak
* anyway. So we mark the subr_entry in a particular way and hope that
* pp_subcall_profiler() can fill in the details.
* If there is an exception then we'll wind up in incr_sub_inclusive_time
* which will see this mark and ignore the call.
*/
subr_entry->called_subnam_sv = newSV(0);
}
subr_entry->called_is_xs = NULL; /* work it out later */
}
else { /* slowop */
/* pretend slowops (builtins) are xsubs */
const char *slowop_name = PL_op_name[op_type];
if (profile_slowops == 1) { /* 1 == put slowops into 1 package */
subr_entry->called_subpkg_pv = "CORE";
subr_entry->called_subnam_sv = newSVpv(slowop_name, 0);
}
else { /* 2 == put slowops into multiple packages */
SV **opname = NULL;
SV *sv;
if (!slowop_name_cache)
slowop_name_cache = newAV();
opname = av_fetch(slowop_name_cache, op_type, TRUE);
if (!opname)
croak("panic: opname cache read for '%s' (%d)\n", slowop_name, op_type);
sv = *opname;
if(!SvOK(sv)) {
const STRLEN len = strlen(slowop_name);
sv_grow(sv, 5 + len + 1);
memcpy(SvPVX(sv), "CORE:", 5);
memcpy(SvPVX(sv) + 5, slowop_name, len + 1);
SvCUR_set(sv, 5 + len);
SvPOK_on(sv);
}
subr_entry->called_subnam_sv = SvREFCNT_inc(sv);
subr_entry->called_subpkg_pv = CopSTASHPV(PL_curcop);
}
subr_entry->called_cv_depth = 1; /* an approximation for slowops */
subr_entry->called_is_xs = "sop";
/* XXX make configurable eg for wait(), and maybe even subs like FCGI::Accept
* so perhaps use $hide_sub_calls->{$package}{$subname} to make it general.
* Then the logic would have to move out of this block.
*/
if (OP_ACCEPT == op_type)
subr_entry->hide_subr_call_time = 1;
}
/* These refer to the last perl statement executed, so aren't
* strictly correct where an opcode or xsub is making the call,
* but they're still more useful than nothing.
* In reports the references line shows calls made by the
* opcode or xsub that's called at that line.
*/
file = OutCopFILE(prev_cop);
subr_entry->caller_fid = (file == last_executed_fileptr)
? last_executed_fid
: get_file_id(aTHX_ file, strlen(file), NYTP_FIDf_VIA_SUB);
subr_entry->caller_line = CopLINE(prev_cop);
/* Gather details about the calling subroutine */
if (clone_subr_entry) {
subr_entry->caller_subpkg_pv = clone_subr_entry->caller_subpkg_pv;
subr_entry->caller_subnam_sv = SvREFCNT_inc(clone_subr_entry->caller_subnam_sv);
found_caller_by = "(cloned)";
}
else
/* Should we calculate the caller or can we reuse the caller_subr_entry?
* Sometimes we'll have a caller_subr_entry but it won't have the name yet.
* For example if the caller is an xsub that's callback into perl.
*/
if (profile_findcaller /* user wants us to calculate each time */
|| !caller_subr_entry /* we don't have a caller struct */
|| !caller_subr_entry->called_subpkg_pv /* we don't have caller details */
|| !caller_subr_entry->called_subnam_sv
|| !SvOK(caller_subr_entry->called_subnam_sv)
) {
/* get the current CV and determine the current sub name from that */
CV *caller_cv = current_cv(aTHX_ cxstack_ix, NULL);
subr_entry->caller_subnam_sv = newSV(0); /* XXX add cache/stack thing for these SVs */
if (0) {
logwarn(" .. caller_subr_entry %p(%s::%s) cxstack_ix=%d: caller_cv=%p\n",
(void*)caller_subr_entry,
caller_subr_entry ? caller_subr_entry->called_subpkg_pv : "(null)",
(caller_subr_entry && caller_subr_entry->called_subnam_sv && SvOK(caller_subr_entry->called_subnam_sv))
? SvPV_nolen(caller_subr_entry->called_subnam_sv) : "(null)",
(int)cxstack_ix, (void*)caller_cv
);
}
if (caller_cv == PL_main_cv) {
/* PL_main_cv is run-time main (compile-time, eg 'use', is a main::BEGIN) */
/* We don't record timing data for main::RUNTIME because timing data
* is stored per calling location, and there is no calling location.
* XXX Currently we don't output a subinfo for main::RUNTIME unless
* some sub is called from main::RUNTIME. That may change.
*/
subr_entry->caller_subpkg_pv = "main";
sv_setpvs(subr_entry->caller_subnam_sv, "RUNTIME"); /* *cough* */
++main_runtime_used;
}
else if (caller_cv == 0) {
/* should never happen - but does in PostgreSQL 8.4.1 plperl
* possibly because perl_run() has already returned
*/
subr_entry->caller_subpkg_pv = "main";
sv_setpvs(subr_entry->caller_subnam_sv, "NULL"); /* *cough* */
}
else {
HV *stash_hv = NULL;
GV *gv = CvGV(caller_cv);
GV *egv = GvEGV(gv);
if (!egv)
gv = egv;
if (gv && (stash_hv = GvSTASH(gv))) {
subr_entry->caller_subpkg_pv = HvNAME(stash_hv);
sv_setpvn(subr_entry->caller_subnam_sv,GvNAME(gv),GvNAMELEN(gv));
}
else {
logwarn("Can't determine name of calling sub (GV %p, Stash %p, CV flags %d) at %s line %d\n",
(void*)gv, (void*)stash_hv, (int)CvFLAGS(caller_cv),
OutCopFILE(prev_cop), (int)CopLINE(prev_cop));
sv_dump((SV*)caller_cv);
subr_entry->caller_subpkg_pv = "__UNKNOWN__";
sv_setpvs(subr_entry->caller_subnam_sv, "__UNKNOWN__");
}
}
found_caller_by = (profile_findcaller) ? "" : "(calculated)";
}
else {
subr_entry_t *caller_se = caller_subr_entry;
int caller_is_op = caller_se->called_is_xs && strEQ(caller_se->called_is_xs,"sop");
/* if the caller is an op then use the caller of that op as our caller.
* that makes more sense from the users perspective (and is consistent
* with the findcaller=1 option).
* XXX disabled for now because (I'm pretty sure) it needs a corresponding
* change in incr_sub_inclusive_time otherwise the incl/excl times are distorted.
*/
if (0 && caller_is_op) {
subr_entry->caller_subpkg_pv = caller_se->caller_subpkg_pv;
subr_entry->caller_subnam_sv = SvREFCNT_inc(caller_se->caller_subnam_sv);
}
else {
subr_entry->caller_subpkg_pv = caller_se->called_subpkg_pv;
subr_entry->caller_subnam_sv = SvREFCNT_inc(caller_se->called_subnam_sv);
}
found_caller_by = "(inherited)";
}
if (trace_level >= 4) {
logwarn("%2u >> %s at %u:%d from %s::%s %s %s\n",
(unsigned int)subr_entry->subr_prof_depth,
PL_op_name[op_type],
subr_entry->caller_fid, subr_entry->caller_line,
subr_entry->caller_subpkg_pv,
SvPV_nolen(subr_entry->caller_subnam_sv),
found_caller_by,
subr_entry_summary(aTHX_ subr_entry, 0)
);
}
/* This is our safety-net destructor. For perl subs an identical destructor
* will be pushed onto the stack _inside_ the scope we're interested in.
* That destructor will be more accurate than this one. This one is here
* mainly to catch exceptions thrown from xs subs and slowops.
*/
save_destructor_x(incr_sub_inclusive_time_ix, INT2PTR(void *, (IV)subr_entry_ix));
if (opt_calls >= 2 && out) {
NYTP_write_call_entry(out, subr_entry->caller_fid, subr_entry->caller_line);
}
SETERRNO(saved_errno, 0);
return subr_entry_ix;
}
static OP *
pp_entersub_profiler(pTHX)
{
return pp_subcall_profiler(aTHX_ 0);
}
static OP *
pp_slowop_profiler(pTHX)
{
return pp_subcall_profiler(aTHX_ 1);
}
static OP *
pp_subcall_profiler(pTHX_ int is_slowop)
{
int saved_errno = errno;
OP *op;
COP *prev_cop = PL_curcop; /* not PL_curcop_nytprof here */
OP *next_op = PL_op->op_next; /* op to execute after sub returns */
/* pp_entersub can be called with PL_op->op_type==0 */
OPCODE op_type = (is_slowop || (opcode) PL_op->op_type == OP_GOTO) ? (opcode) PL_op->op_type : OP_ENTERSUB;
CV *called_cv;
dSP;
SV *sub_sv = *SP;
I32 this_subr_entry_ix = 0; /* local copy (needed for goto) */
subr_entry_t *subr_entry;
/* pre-conditions */
if (!profile_subs /* not profiling subs */
/* don't profile if currently disabled */
|| !is_profiling
/* don't profile calls to non-existant import() methods */
/* or our DB::_INIT as that makes tests perl version sensitive */
|| (op_type==OP_ENTERSUB && (sub_sv == &PL_sv_yes || sub_sv == DB_CHECK_cv || sub_sv == DB_INIT_cv
|| sub_sv == DB_END_cv || sub_sv == DB_fin_cv))
/* don't profile other kinds of goto */
|| (op_type==OP_GOTO &&
( !(SvROK(sub_sv) && SvTYPE(SvRV(sub_sv)) == SVt_PVCV)
|| !subr_entry_ix ) /* goto out of sub whose entry wasn't profiled */
)
#ifdef MULTIPLICITY
|| (orig_my_perl && my_perl != orig_my_perl)
#endif
) {
return run_original_op(op_type);
}
if (!profile_stmts) {
reinit_if_forked(aTHX);
CHECK_SAWAMPERSAND(last_executed_fid, last_executed_line);
}
if (trace_level >= 99) {
logwarn("profiling a call [op %ld, %s, seix %d]\n",
(long)op_type, PL_op_name[op_type], (int)subr_entry_ix);
/* crude, but the only way to deal with the miriad logic at the
* start of pp_entersub (which ought to be available as separate sub)
*/
sv_dump(sub_sv);
}
/* Life would be so much simpler if we could reliably tell, at this point,
* what sub was going to get called. But we can't in many cases.
* So we gather up as much into as possible before the call.
*/
if (op_type != OP_GOTO) {
/* For normal subs, pp_entersub enters the sub and returns the
* first op *within* the sub (typically a nextstate/dbstate).
* For XS subs, pp_entersub executes the entire sub
* and returns the op *after* the sub (PL_op->op_next).
* Other ops we profile (eg slowops) act like xsubs.
*/
called_cv = NULL;
this_subr_entry_ix = subr_entry_setup(aTHX_ prev_cop, NULL, op_type, sub_sv);
/* This call may exit via an exception, in which case the
* remaining code below doesn't get executed and the sub call
* details are discarded. For perl subs that just means we don't
* see calls the failed with "Unknown sub" errors, etc.
* For xsubs it's a more significant issue. Especially if the
* xsub calls back into perl.
*/
SETERRNO(saved_errno, 0);
op = run_original_op(op_type);
saved_errno = errno;
}
else {
/* goto &sub opcode acts like a return followed by a call all in one.
* When this op starts executing, the 'current' subr_entry that was
* pushed onto the savestack by pp_subcall_profiler will be 'already_counted'
* so the profiling of that call will be handled naturally for us.
* So far so good.
* Before it gets destroyed we'll take a copy of the subr_entry.
* Then tell subr_entry_setup() to use our copy as a template so it'll
* seem like the sub we goto'd was called by the same sub that called
* the one that executed the goto. Except that we do use the fid:line
* of the goto statement. That way the call graph makes sense and the
* 'calling location' make sense. Got all that?
*/
/* save a copy of prev_cop - see t/test18-goto2.p */
COP prev_cop_copy = *prev_cop;
/* save a copy of the subr_entry of the sub we're goto'ing out of */
/* so we can reuse the caller _* info after it's destroyed */
subr_entry_t goto_subr_entry;
subr_entry_t *src = subr_entry_ix_ptr(subr_entry_ix);
Copy(src, &goto_subr_entry, 1, subr_entry_t);
/* XXX if the goto op or goto'd xsub croaks then this'll leak */
/* we can't mortalize here because we're about to leave scope */
(void)SvREFCNT_inc(goto_subr_entry.caller_subnam_sv);
(void)SvREFCNT_inc(goto_subr_entry.called_subnam_sv);
(void)SvREFCNT_inc(sub_sv);
/* grab the CvSTART of the called sub since it's available */
called_cv = (CV*)SvRV(sub_sv);
/* if goto &sub then op will be the first op of the called sub
* if goto &xsub then op will be the first op after the call to the
* op we're goto'ing out of.
*/
SETERRNO(saved_errno, 0);
op = run_original_op(op_type); /* perform the goto &sub */
saved_errno = errno;
/* now we're in goto'd sub, mortalize the REFCNT_inc's done above */
sv_2mortal(goto_subr_entry.caller_subnam_sv);
sv_2mortal(goto_subr_entry.called_subnam_sv);
this_subr_entry_ix = subr_entry_setup(aTHX_ &prev_cop_copy, &goto_subr_entry, op_type, sub_sv);
SvREFCNT_dec(sub_sv);
}
subr_entry = subr_entry_ix_ptr(this_subr_entry_ix);
/* detect wierdness/corruption */
assert(subr_entry->caller_fid < fidhash.next_id);
/* Check if this call has already been counted because the op performed
* a leave_scope(). E.g., OP_SUBSTCONT at end of s/.../\1/
* or Scope::Upper's unwind()
*/
if (subr_entry->already_counted) {
if (trace_level >= 9)
logwarn("%2u -- %s::%s already counted %s\n",
(unsigned int)subr_entry->subr_prof_depth,
subr_entry->called_subpkg_pv,
(subr_entry->called_subnam_sv && SvOK(subr_entry->called_subnam_sv))
? SvPV_nolen(subr_entry->called_subnam_sv)
: "?",
subr_entry_summary(aTHX_ subr_entry, 1));
assert(subr_entry->already_counted < 3);
goto skip_sub_profile;
}
if (is_slowop) {
/* already fully handled by subr_entry_setup */
}
else {
char *stash_name = NULL;
const char *is_xs = NULL;
if (op_type == OP_GOTO) {
/* use the called_cv that was the arg to the goto op */
is_xs = (CvISXSUB(called_cv)) ? "xsub" : NULL;
}
else
if (op != next_op) { /* have entered a sub */
/* use cv of sub we've just entered to get name */
called_cv = cxstack[cxstack_ix].blk_sub.cv;
is_xs = NULL;
}
else { /* have returned from XS so use sub_sv for name */
/* determine the original fully qualified name for sub */
/* CV or NULL */
GV *gv = NULL;
called_cv = resolve_sub_to_cv(aTHX_ sub_sv, &gv);
if (!called_cv && gv) { /* XXX no test case for this */
stash_name = HvNAME(GvSTASH(gv));
sv_setpv(subr_entry->called_subnam_sv, GvNAME(gv));
if (trace_level >= 0)
logwarn("Assuming called sub is named %s::%s at %s line %d (please report as a bug)\n",
stash_name, SvPV_nolen(subr_entry->called_subnam_sv),
OutCopFILE(prev_cop), (int)CopLINE(prev_cop));
}
is_xs = "xsub";
}
if (called_cv && CvGV(called_cv)) {
GV *gv = CvGV(called_cv);
/* Class::MOP can create CvGV where SvTYPE of GV is SVt_NULL */
if (SvTYPE(gv) == SVt_PVGV && GvSTASH(gv)) {
/* for a plain call of an imported sub the GV is of the current
* package, so we dig to find the original package
*/
stash_name = HvNAME(GvSTASH(gv));
sv_setpv(subr_entry->called_subnam_sv, GvNAME(gv));
}
else if (trace_level >= 1) {
logwarn("NYTProf is confused about CV %p called as %s at %s line %d (please report as a bug)\n",
(void*)called_cv, SvPV_nolen(sub_sv), OutCopFILE(prev_cop), (int)CopLINE(prev_cop));
/* looks like Class::MOP doesn't give the CV GV stash a name */
if (trace_level >= 2) {
sv_dump((SV*)called_cv); /* coredumps in Perl_do_gvgv_dump, looks line GvXPVGV is false, presumably on a Class::MOP wierdo sub */
sv_dump((SV*)gv);
}
}
}
/* called_subnam_sv should have been set by now - else we're getting desperate */
if (!SvOK(subr_entry->called_subnam_sv)) {
const char *what = (is_xs) ? is_xs : "sub";
if (!called_cv) { /* should never get here as pp_entersub would have croaked */
logwarn("unknown entersub %s '%s' (please report this as a bug)\n", what, SvPV_nolen(sub_sv));
stash_name = CopSTASHPV(PL_curcop);
sv_setpvf(subr_entry->called_subnam_sv, "__UNKNOWN__[%s,%s])", what, SvPV_nolen(sub_sv));
}
else { /* unnamed CV, e.g. seen in mod_perl/Class::MOP. XXX do better? */
stash_name = HvNAME(CvSTASH(called_cv));
sv_setpvf(subr_entry->called_subnam_sv, "__UNKNOWN__[%s,0x%p]", what, (void*)called_cv);
if (trace_level)
logwarn("unknown entersub %s assumed to be anon called_cv '%s'\n",
what, SvPV_nolen(sub_sv));
}
if (trace_level >= 9)
sv_dump(sub_sv);
}
subr_entry->called_subpkg_pv = stash_name;
if (*SvPVX(subr_entry->called_subnam_sv) == 'B')
append_linenum_to_begin(aTHX_ subr_entry);
/* if called was xsub then we've already left it, so use depth+1 */
subr_entry->called_cv_depth = (called_cv) ? CvDEPTH(called_cv)+(is_xs?1:0) : 0;
subr_entry->called_cv = called_cv;
subr_entry->called_is_xs = is_xs;
}
/* ignore our own DB::_INIT sub - only shows up with 5.8.9+ & 5.10.1+ */
if (subr_entry->called_is_xs
&& subr_entry->called_subpkg_pv[0] == 'D'
&& subr_entry->called_subpkg_pv[1] == 'B'
&& subr_entry->called_subpkg_pv[2] == '\0'
) {
STRLEN len;
char *p = SvPV(subr_entry->called_subnam_sv, len);
if(*p == '_' && (memEQs(p, len, "_CHECK") || memEQs(p, len, "_INIT") || memEQs(p, len, "_END"))) {
subr_entry->already_counted++;
goto skip_sub_profile;
}
}
/* catch profile_subs being turned off by disable_profile call */
if (!profile_subs)
subr_entry->already_counted++;
if (trace_level >= 4) {
logwarn("%2u ->%4s %s::%s from %s::%s @%u:%u (d%d, oh %"NVff"t, sub %"NVff"s) #%lu\n",
(unsigned int)subr_entry->subr_prof_depth,
(subr_entry->called_is_xs) ? subr_entry->called_is_xs : "sub",
subr_entry->called_subpkg_pv,
subr_entry->called_subnam_sv ? SvPV_nolen(subr_entry->called_subnam_sv) : "(null)",
subr_entry->caller_subpkg_pv,
subr_entry->caller_subnam_sv ? SvPV_nolen(subr_entry->caller_subnam_sv) : "(null)",
subr_entry->caller_fid, subr_entry->caller_line,
subr_entry->called_cv_depth,
subr_entry->initial_overhead_ticks,
subr_entry->initial_subr_ticks / ticks_per_sec,
subr_entry->subr_call_seqn
);
}
if (subr_entry->called_is_xs) {
/* for xsubs/builtins we've already left the sub, so end the timing now
* rather than wait for the calling scope to get cleaned up.
*/
incr_sub_inclusive_time(aTHX_ subr_entry);
}
else {
/* push a destructor hook onto the context stack to ensure we account
* for time in the sub when we leave it, even if via an exception.
*/
save_destructor_x(incr_sub_inclusive_time_ix, INT2PTR(void *, (IV)this_subr_entry_ix));
}
skip_sub_profile:
SETERRNO(saved_errno, 0);
return op;
}
static OP *
pp_stmt_profiler(pTHX) /* handles OP_DBSTATE, OP_SETSTATE, etc */
{
OP *op = run_original_op(PL_op->op_type);
DB_stmt(aTHX_ NULL, op);
return op;
}
static OP *
pp_leave_profiler(pTHX) /* handles OP_LEAVESUB, OP_LEAVEEVAL, etc */
{
OP *prev_op = PL_op;
OP *op = run_original_op(PL_op->op_type);
DB_leave(aTHX_ op, prev_op);
return op;
}
static OP *
pp_fork_profiler(pTHX) /* handles OP_FORK */
{
OP *op = run_original_op(PL_op->op_type);
reinit_if_forked(aTHX);
return op;
}
static OP *
pp_exit_profiler(pTHX) /* handles OP_EXIT, OP_EXEC, etc */
{
DB_leave(aTHX_ NULL, PL_op); /* call DB_leave *before* run_original_op() */
if (PL_op->op_type == OP_EXEC)
finish_profile(aTHX); /* this is the last chance we'll get */
return run_original_op(PL_op->op_type);
}
static int
enable_profile(pTHX_ char *file)
{
/* enable the run-time aspects to profiling */
int prev_is_profiling = is_profiling;
#ifdef MULTIPLICITY
if (orig_my_perl && my_perl != orig_my_perl) {
if (trace_level)
logwarn("~ enable_profile call from different interpreter ignored\n");
return 0;
}
#endif
if (profile_usecputime) {
warn("The NYTProf usecputime option has been removed (try using clock=N if possible)");
return 0;
}
if (trace_level)
logwarn("~ enable_profile (previously %s) to %s\n",
prev_is_profiling ? "enabled" : "disabled",
(file && *file) ? file : PROF_output_file);
reinit_if_forked(aTHX);
if (file && *file && strNE(file, PROF_output_file)) {
/* caller wants output to go to a new file */
close_output_file(aTHX);
strncpy(PROF_output_file, file, sizeof(PROF_output_file)-1);
}
if (!out) {
open_output_file(aTHX_ PROF_output_file);
}
last_executed_fileptr = NULL; /* discard cached OutCopFILE */
is_profiling = 1; /* enable NYTProf profilers */
if (opt_use_db_sub) /* set PL_DBsingle if required */
sv_setiv(PL_DBsingle, 1);
/* discard time spent since profiler was disabled */
get_time_of_day(start_time);
return prev_is_profiling;
}
static int
disable_profile(pTHX)
{
int prev_is_profiling = is_profiling;
#ifdef MULTIPLICITY
if (orig_my_perl && my_perl != orig_my_perl) {
if (trace_level)
logwarn("~ disable_profile call from different interpreter ignored\n");
return 0;
}
#endif
if (is_profiling) {
if (opt_use_db_sub)
sv_setiv(PL_DBsingle, 0);
if (out)
NYTP_flush(out);
is_profiling = 0;
}
if (trace_level)
logwarn("~ disable_profile (previously %s, pid %d, trace %ld)\n",
prev_is_profiling ? "enabled" : "disabled", getpid(), trace_level);
return prev_is_profiling;
}
static void
finish_profile(pTHX)
{
/* can be called after the perl interp is destroyed, via libcexit */
int saved_errno = errno;
#ifdef MULTIPLICITY
if (orig_my_perl && my_perl != orig_my_perl)
if (trace_level) {
logwarn("~ finish_profile call from different interpreter ignored\n");
return;
}
#endif
if (trace_level >= 1)
logwarn("~ finish_profile (overhead %gt, is_profiling %d)\n",
cumulative_overhead_ticks, is_profiling);
/* write data for final statement, unless DB_leave has already */
if (!profile_leave || opt_use_db_sub)
DB_stmt(aTHX_ NULL, NULL);
disable_profile(aTHX);
close_output_file(aTHX);
if (trace_level >= 2) {
hash_stats(&fidhash, 0);
hash_stats(&strhash, 0);
}
/* reset sub profiler data */
if (HvKEYS(sub_callers_hv)) {
/* HvKEYS check avoids hv_clear() if interp has been destroyed RT#86548 */
hv_clear(sub_callers_hv);
}
/* reset other state */
cumulative_overhead_ticks = 0;
cumulative_subr_ticks = 0;
SETERRNO(saved_errno, 0);
}
static void
finish_profile_nocontext()
{
/* can be called after the perl interp is destroyed, via libcexit */
dTHX;
finish_profile(aTHX);
}
static void
_init_profiler_clock(pTHX)
{
#ifdef HAS_CLOCK_GETTIME
if (profile_clock == -1) { /* auto select */
# ifdef CLOCK_MONOTONIC
profile_clock = CLOCK_MONOTONIC;
# else
profile_clock = CLOCK_REALTIME;
# endif
}
/* downgrade to CLOCK_REALTIME if desired clock not available */
if (clock_gettime(profile_clock, &start_time) != 0) {
if (trace_level)
logwarn("~ clock_gettime clock %ld not available (%s) using CLOCK_REALTIME instead\n",
(long)profile_clock, strerror(errno));
profile_clock = CLOCK_REALTIME;
/* check CLOCK_REALTIME as well, just in case */
if (clock_gettime(profile_clock, &start_time) != 0)
croak("clock_gettime CLOCK_REALTIME not available (%s), aborting",
strerror(errno));
}
#else
if (profile_clock != -1) { /* user tried to select different clock */
logwarn("clock %ld not available (clock_gettime not supported on this system)\n", (long)profile_clock);
profile_clock = -1;
}
#endif
ticks_per_sec = TICKS_PER_SEC;
}
/* Initial setup - should only be called once */
static int
init_profiler(pTHX)
{
#ifndef HAS_GETTIMEOFDAY
SV **svp;
#endif
#ifdef MULTIPLICITY
if (!orig_my_perl) {
if (1)
orig_my_perl = my_perl;
}
else if (orig_my_perl && orig_my_perl != my_perl) {
logwarn("NYTProf: perl interpreter address changed after init (threads/multiplicity not supported)\n");
return 0;
}
#endif
/* Save the process id early. We monitor it to detect forks */
last_pid = getpid();
DB_CHECK_cv = (SV*)GvCV(gv_fetchpv("DB::_CHECK", FALSE, SVt_PVCV));
DB_INIT_cv = (SV*)GvCV(gv_fetchpv("DB::_INIT", FALSE, SVt_PVCV));
DB_END_cv = (SV*)GvCV(gv_fetchpv("DB::_END", FALSE, SVt_PVCV));
DB_fin_cv = (SV*)GvCV(gv_fetchpv("DB::finish_profile", FALSE, SVt_PVCV));
if (opt_use_db_sub) {
PL_perldb |= PERLDBf_LINE; /* line-by-line profiling via DB::DB (if $DB::single true) */
PL_perldb |= PERLDBf_SINGLE; /* start (after BEGINs) with single-step on XXX still needed? */
}
if (profile_opts & NYTP_OPTf_OPTIMIZE)
PL_perldb &= ~PERLDBf_NOOPT;
else PL_perldb |= PERLDBf_NOOPT;
if (profile_opts & NYTP_OPTf_SAVESRC) {
/* ask perl to keep the source lines so we can copy them */
PL_perldb |= PERLDBf_SAVESRC | PERLDBf_SAVESRC_NOSUBS;
}
if (!opt_nameevals)
PL_perldb &= PERLDBf_NAMEEVAL;
if (!opt_nameanonsubs)
PL_perldb &= PERLDBf_NAMEANON;
if (opt_perldb) /* force a PL_perldb value - for testing only, not documented */
PL_perldb = opt_perldb;
_init_profiler_clock(aTHX);
if (trace_level)
logwarn("~ init_profiler for pid %d, clock %ld, tps %d, start %d, perldb 0x%lx, exitf 0x%lx\n",
last_pid, (long)profile_clock, ticks_per_sec, profile_start,
(long unsigned)PL_perldb, (long unsigned)PL_exit_flags);
if (get_hv("DB::sub", 0) == NULL) {
logwarn("NYTProf internal error - perl not in debug mode\n");
return 0;
}
#ifndef HAS_GETTIMEOFDAY
require_pv("Time/HiRes.pm"); /* before opcode redirection */
svp = hv_fetch(PL_modglobal, "Time::U2time", 12, 0);
if (!svp || !SvIOK(*svp)) croak("Time::HiRes is required");
u2time = INT2PTR(int(*)(pTHX_ UV*), SvIV(*svp));
if (trace_level)
logwarn("NYTProf using Time::HiRes %p\n", u2time);
#endif
/* create file id mapping hash */
fidhash.table = (Hash_entry**)safemalloc(sizeof(Hash_entry*) * fidhash.size);
memset(fidhash.table, 0, sizeof(Hash_entry*) * fidhash.size);
/* redirect opcodes for statement profiling */
Newxc(PL_ppaddr_orig, OP_max, void *, orig_ppaddr_t);
Copy(PL_ppaddr, PL_ppaddr_orig, OP_max, void *);
if (profile_stmts && !opt_use_db_sub) {
PL_ppaddr[OP_NEXTSTATE] = pp_stmt_profiler;
PL_ppaddr[OP_DBSTATE] = pp_stmt_profiler;
#ifdef OP_SETSTATE
PL_ppaddr[OP_SETSTATE] = pp_stmt_profiler;
#endif
if (profile_leave) {
PL_ppaddr[OP_LEAVESUB] = pp_leave_profiler;
PL_ppaddr[OP_LEAVESUBLV] = pp_leave_profiler;
PL_ppaddr[OP_LEAVE] = pp_leave_profiler;
PL_ppaddr[OP_LEAVELOOP] = pp_leave_profiler;
PL_ppaddr[OP_LEAVEWRITE] = pp_leave_profiler;
PL_ppaddr[OP_LEAVEEVAL] = pp_leave_profiler;
PL_ppaddr[OP_LEAVETRY] = pp_leave_profiler;
PL_ppaddr[OP_RETURN] = pp_leave_profiler;
/* natural end of simple loop */
PL_ppaddr[OP_UNSTACK] = pp_leave_profiler;
/* OP_NEXT is missing because that jumps to OP_UNSTACK */
/* OP_EXIT and OP_EXEC need special handling */
PL_ppaddr[OP_EXIT] = pp_exit_profiler;
PL_ppaddr[OP_EXEC] = pp_exit_profiler;
}
}
/* calls reinit_if_forked() asap after a fork */
PL_ppaddr[OP_FORK] = pp_fork_profiler;
if (profile_slowops) {
/* XXX this should turn into a loop over an array that maps
* opcodes to the subname we'll use: OP_PRTF => "printf"
*/
#include "slowops.h"
}
/* redirect opcodes for caller tracking */
if (!sub_callers_hv)
sub_callers_hv = newHV();
if (!pkg_fids_hv)
pkg_fids_hv = newHV();
PL_ppaddr[OP_ENTERSUB] = pp_entersub_profiler;
PL_ppaddr[OP_GOTO] = pp_entersub_profiler;
if (!PL_checkav) PL_checkav = newAV();
if (!PL_initav) PL_initav = newAV();
if (!PL_endav) PL_endav = newAV();
/* pre-extend PL_endav to reduce the chance of DB::_END realloc'ing
* it while END blocks are executed (which could upset some embedded
* applications that don't handle PL_endav carefully, like mod_perl)
*/
av_extend(PL_endav, av_len(PL_endav)+30);
if (profile_start == NYTP_START_BEGIN) {
enable_profile(aTHX_ NULL);
} else {
/* handled by _INIT */
av_push(PL_initav, SvREFCNT_inc(get_cv("DB::_INIT", GV_ADDWARN)));
}
if (PL_minus_c) {
av_push(PL_checkav, SvREFCNT_inc(get_cv("DB::_CHECK", GV_ADDWARN)));
} else {
av_push(PL_endav, SvREFCNT_inc(get_cv("DB::_END", GV_ADDWARN)));
}
/* seed first run time */
get_time_of_day(start_time);
if (trace_level >= 1)
logwarn("~ init_profiler done\n");
return 1;
}
/************************************
* Devel::NYTProf::Reader Functions *
************************************/
static void
add_entry(pTHX_ AV *dest_av, unsigned int file_num, unsigned int line_num,
NV time, unsigned int eval_file_num, unsigned int eval_line_num, int count)
{
/* get ref to array of per-line data */
unsigned int fid = (eval_line_num) ? eval_file_num : file_num;
SV *line_time_rvav = *av_fetch(dest_av, fid, 1);
if (!SvROK(line_time_rvav)) /* autoviv */
sv_setsv(line_time_rvav, newRV_noinc((SV*)newAV()));
store_profile_line_entry(aTHX_ line_time_rvav, line_num, time, count, fid);
}
static AV *
store_profile_line_entry(pTHX_ SV *rvav, unsigned int line_num, NV time,
int count, unsigned int fid)
{
SV *time_rvav = *av_fetch((AV*)SvRV(rvav), line_num, 1);
AV *line_av;
if (!SvROK(time_rvav)) { /* autoviv */
line_av = newAV();
sv_setsv(time_rvav, newRV_noinc((SV*)line_av));
av_store(line_av, 0, newSVnv(time));
av_store(line_av, 1, newSViv(count));
/* if eval then 2 is used for lines within the string eval */
if (embed_fid_line) { /* used to optimize reporting */
av_store(line_av, 3, newSVuv(fid));
av_store(line_av, 4, newSVuv(line_num));
}
}
else {
SV *time_sv;
line_av = (AV*)SvRV(time_rvav);
time_sv = *av_fetch(line_av, 0, 1);
sv_setnv(time_sv, time + SvNV(time_sv));
if (count) {
SV *sv = *av_fetch(line_av, 1, 1);
(count == 1) ? sv_inc(sv) : sv_setiv(sv, (IV)time + SvIV(sv));
}
}
return line_av;
}
/* Given a fully-qualified name, return the length of the package name.
* As most callers get len via the hash API, they will have an I32, where
* "negative" length signifies UTF-8. As we're only dealing with looking for
* ASCII here, it doesn't matter to use which encoding sub_name is in, but it
* reduces total code by doing the abs(len) in here.
*/
static STRLEN
pkg_name_len(pTHX_ char *sub_name, I32 len)
{
/* pTHX_ needed for old rninstr in old perl versions */
const char *delim = "::";
/* find end of package name */
char *colon = rninstr(sub_name, sub_name+(len > 0 ? len : -len), delim, delim+2);
if (!colon || colon == sub_name)
return 0; /* no :: delimiter */
return (colon - sub_name);
}
/* Given a fully-qualified sub_name lookup the package name portion in
* the pkg_fids_hv hash. Return Nullsv if there's no package name or no
* correponding entry, else returns the SV.
*
* About pkg_fids_hv:
* pp_subcall_profiler() creates undef entries for a package
* name the first time a sub in the package is called.
* write_sub_line_ranges() updates the SV with the filename associated
* with the package, or at least its best guess.
*/
static SV *
sub_pkg_filename_sv(pTHX_ char *sub_name, I32 len)
{
SV **svp;
STRLEN pkg_len = pkg_name_len(aTHX_ sub_name, len);
if (!pkg_len)
return Nullsv; /* no :: delimiter */
svp = hv_fetch(pkg_fids_hv, sub_name, (I32)pkg_len, 0);
if (!svp)
return Nullsv; /* not a package we've profiled sub calls into */
return *svp;
}
static int
parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p, char *sub_name) {
/* "filename:first-last" */
char *filename = SvPV_nolen(sv);
char *first = strrchr(filename, ':'); /* find last colon */
char *last;
int first_is_neg = 0;
if (first && filename_len_p)
*filename_len_p = first - filename;
if (!first++) /* start of first number, if colon was found */
return 0;
if ('-' == *first) { /* first number is negative */
++first;
first_is_neg = 1;
}
last = strchr(first, '-'); /* find separator dash */
if (!last || !grok_number(first, last-first, first_line_p))
return 0;
if (first_is_neg) {
warn("Negative first line number in %%DB::sub entry '%s' for %s\n",
filename, sub_name);
*first_line_p = 0;
}
if ('-' == *++last) { /* skip past dash, is next char a minus? */
warn("Negative last line number in %%DB::sub entry '%s' for %s\n",
filename, sub_name);
last = (char *)"0";
}
if (last_line_p)
*last_line_p = atoi(last);
return 1;
}
static void
write_sub_line_ranges(pTHX)
{
char *sub_name;
I32 sub_name_len;
SV *file_lines_sv;
HV *hv = GvHV(PL_DBsub);
unsigned int fid;
if (trace_level >= 1)
logwarn("~ writing sub line ranges - prescan\n");
/* Skim through PL_DBsub hash to build a package to filename hash
* by associating the package part of the sub_name in the key
* with the filename part of the value.
* but only for packages we already know we're interested in
*/
hv_iterinit(hv);
while (NULL != (file_lines_sv = hv_iternextsv(hv, &sub_name, &sub_name_len))) {
STRLEN file_lines_len;
char *filename = SvPV(file_lines_sv, file_lines_len);
char *first;
STRLEN filename_len;
SV *pkg_filename_sv;
/* This is a heuristic, and might not be robust, but it seems that
it's possible to get problematically bogus entries in this hash.
Specifically, setting the 'lvalue' attribute on an XS subroutine
during a bootstrap can cause op.c to load attributes, and in turn
cause a DynaLoader::BEGIN entry in %DB::sub associated with the
.pm file of the XS sub's module, not DynaLoader. This has the result
that if we try to associate XSUBs with filenames using %DB::sub,
we can go very wrong.
Fortunately all "wrong" entries so far spotted have a line range
with a non-zero start, and a zero end. This cannot be legal, so we
ignore those.
*/
if (file_lines_len > 4
&& filename[file_lines_len - 2] == '-' && filename[file_lines_len - 1] == '0'
&& filename[file_lines_len - 4] != ':' && filename[file_lines_len - 3] != '0')
continue; /* ignore filenames from %DB::sub that match /:[^0]-0$/ */
first = strrchr(filename, ':');
filename_len = (first) ? first - filename : 0;
/* get sv for package-of-subname to filename mapping */
pkg_filename_sv = sub_pkg_filename_sv(aTHX_ sub_name, sub_name_len);
if (!pkg_filename_sv) /* we don't know package */
continue;
/* already got a cached filename for this package XXX should allow multiple */
if (SvOK(pkg_filename_sv)) {
STRLEN cached_len;
char *cached_filename = SvPV(pkg_filename_sv, cached_len);
/*
* if the cached filename is an eval and the current one isn't
* then we should cache the current one instead
*/
if (filename_len > 0
&& filename_is_eval(cached_filename, cached_len)
&& !filename_is_eval(filename, filename_len)
) {
if (trace_level >= 3)
logwarn("Package '%.*s' (of sub %.*s) association promoted from '%.*s' to '%.*s'\n",
(int)pkg_name_len(aTHX_ sub_name, sub_name_len), sub_name,
(int)sub_name_len, sub_name,
(int)cached_len, cached_filename,
(int)filename_len, filename);
sv_setpvn(pkg_filename_sv, filename, filename_len);
continue;
}
if (trace_level >= 3
&& strnNE(SvPV_nolen(pkg_filename_sv), filename, filename_len)
&& !filename_is_eval(filename, filename_len)
) {
/* eg utf8::SWASHNEW is already associated with .../utf8.pm not .../utf8_heavy.pl */
logwarn("Package '%.*s' (of sub %.*s) not associated with '%.*s' because already associated with '%s'\n",
(int)pkg_name_len(aTHX_ sub_name, sub_name_len), sub_name,
(int)sub_name_len, sub_name,
(int)filename_len, filename,
SvPV_nolen(pkg_filename_sv)
);
}
continue;
}
/* ignore if filename is empty (eg xs) */
if (!filename_len) {
if (trace_level >= 3)
logwarn("Sub %.*s has no filename associated (%s)\n",
(int)sub_name_len, sub_name, filename);
continue;
}
/* associate the filename with the package */
sv_setpvn(pkg_filename_sv, filename, filename_len);
/* ensure a fid is assigned since we don't allow it below */
fid = get_file_id(aTHX_ filename, filename_len, NYTP_FIDf_VIA_SUB);
if (trace_level >= 3)
logwarn("Associating package of %s with %.*s (fid %d)\n",
sub_name, (int)filename_len, filename, fid );
}
if (main_runtime_used) { /* Create fake entry for main::RUNTIME sub */
char runtime[] = "main::RUNTIME";
const I32 runtime_len = sizeof(runtime) - 1;
SV *sv = *hv_fetch(hv, runtime, runtime_len, 1);
/* get name of file that contained first profiled sub in 'main::' */
SV *pkg_filename_sv = sub_pkg_filename_sv(aTHX_ runtime, runtime_len);
if (!pkg_filename_sv) { /* no subs in main, so guess */
sv_setpvn(sv, fidhash.first_inserted->key, fidhash.first_inserted->key_len);
}
else if (SvOK(pkg_filename_sv)) {
sv_setsv(sv, pkg_filename_sv);
}
else {
sv_setpvn(sv, "", 0);
}
sv_catpvs(sv, ":1-1");
}
if (trace_level >= 1)
logwarn("~ writing sub line ranges of %ld subs\n", (long)HvKEYS(hv));
/* Iterate over PL_DBsub writing out fid and source line range of subs.
* If filename is missing (i.e., because it's an xsub so has no source file)
* then use the filename of another sub in the same package.
*/
while (NULL != (file_lines_sv = hv_iternextsv(hv, &sub_name, &sub_name_len))) {
/* "filename:first-last" */
char *filename = SvPV_nolen(file_lines_sv);
STRLEN filename_len;
UV first_line, last_line;
if (!parse_DBsub_value(aTHX_ file_lines_sv, &filename_len, &first_line, &last_line, sub_name)) {
logwarn("Can't parse %%DB::sub entry for %s '%s'\n", sub_name, filename);
continue;
}
if (!filename_len) { /* no filename, so presumably a fake entry for xsub */
/* do we know a filename that contains subs in the same package */
SV *pkg_filename_sv = sub_pkg_filename_sv(aTHX_ sub_name, sub_name_len);
if (pkg_filename_sv && SvOK(pkg_filename_sv)) {
filename = SvPV(pkg_filename_sv, filename_len);
if (trace_level >= 2)
logwarn("Sub %s is xsub, we'll associate it with filename %.*s\n",
sub_name, (int)filename_len, filename);
}
}
fid = get_file_id(aTHX_ filename, filename_len, 0);
if (!fid) {
if (trace_level >= 4)
logwarn("Sub %s has no fid assigned (for file '%.*s')\n",
sub_name, (int)filename_len, filename);
continue; /* no point in writing subs in files we've not profiled */
}
if (trace_level >= 2)
logwarn("Sub %s fid %u lines %lu..%lu\n",
sub_name, fid, (unsigned long)first_line, (unsigned long)last_line);
NYTP_write_sub_info(out, fid, sub_name, sub_name_len, (unsigned long)first_line,
(unsigned long)last_line);
}
}
static void
write_sub_callers(pTHX)
{
char *called_subname;
I32 called_subname_len;
SV *fid_line_rvhv;
int negative_time_calls = 0;
if (!sub_callers_hv)
return;
if (trace_level >= 1)
logwarn("~ writing sub callers for %ld subs\n", (long)HvKEYS(sub_callers_hv));
hv_iterinit(sub_callers_hv);
while (NULL != (fid_line_rvhv = hv_iternextsv(sub_callers_hv, &called_subname, &called_subname_len))) {
HV *fid_lines_hv;
char *caller_subname;
I32 caller_subname_len;
SV *sv;
if (!SvROK(fid_line_rvhv) || SvTYPE(SvRV(fid_line_rvhv))!=SVt_PVHV) {
logwarn("bad entry %s in sub_callers_hv\n", called_subname);
continue;
}
fid_lines_hv = (HV*)SvRV(fid_line_rvhv);
if (0) {
logwarn("Callers of %s:\n", called_subname);
/* level, *file, *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim */
do_sv_dump(0, Perl_debug_log, fid_line_rvhv, 0, 5, 0, 100);
}
/* iterate over callers to this sub ({ "subname[fid:line]" => [ ... ] }) */
hv_iterinit(fid_lines_hv);
while (NULL != (sv = hv_iternextsv(fid_lines_hv, &caller_subname, &caller_subname_len))) {
NV sc[NYTP_SCi_elements];
AV *av = (AV *)SvRV(sv);
int trace = (trace_level >= 3);
UV count;
UV depth;
unsigned int fid = 0, line = 0;
const char *fid_line_delim = "[";
char *fid_line_start = rninstr(caller_subname, caller_subname+caller_subname_len, fid_line_delim, fid_line_delim+1);
if (!fid_line_start) {
logwarn("bad fid_lines_hv key '%s'\n", caller_subname);
continue;
}
if (2 != sscanf(fid_line_start+1, "%u:%u", &fid, &line)) {
logwarn("bad fid_lines_hv format '%s'\n", caller_subname);
continue;
}
/* trim length to effectively hide the [fid:line] suffix */
caller_subname_len = (I32)(fid_line_start-caller_subname);
/* catch negative line numbers that have been stored unsigned */
if (line > 2147483600) { /* ~2**31 */
logwarn("%s called by %.*s at fid %u line %u - crazy line number changed to 0\n",
called_subname, (int)caller_subname_len, caller_subname, fid, line);
line = 0;
}
count = uv_from_av(aTHX_ av, NYTP_SCi_CALL_COUNT, 0);
sc[NYTP_SCi_CALL_COUNT] = count * 1.0;
sc[NYTP_SCi_INCL_RTIME] = nv_from_av(aTHX_ av, NYTP_SCi_INCL_TICKS, 0.0) / ticks_per_sec;
sc[NYTP_SCi_EXCL_RTIME] = nv_from_av(aTHX_ av, NYTP_SCi_EXCL_TICKS, 0.0) / ticks_per_sec;
sc[NYTP_SCi_RECI_RTIME] = nv_from_av(aTHX_ av, NYTP_SCi_RECI_RTIME, 0.0);
depth = uv_from_av(aTHX_ av, NYTP_SCi_REC_DEPTH , 0);
sc[NYTP_SCi_REC_DEPTH] = depth * 1.0;
NYTP_write_sub_callers(out, fid, line,
caller_subname, caller_subname_len,
(unsigned int)count,
sc[NYTP_SCi_INCL_RTIME],
sc[NYTP_SCi_EXCL_RTIME],
sc[NYTP_SCi_RECI_RTIME],
(unsigned int)depth,
called_subname, called_subname_len);
/* sanity check - early warning */
if (sc[NYTP_SCi_INCL_RTIME] < 0.0 || sc[NYTP_SCi_EXCL_RTIME] < 0.0) {
++negative_time_calls;
if (trace_level) {
logwarn("%s call has negative time: incl %"NVff"s, excl %"NVff"s:\n",
called_subname, sc[NYTP_SCi_INCL_RTIME], sc[NYTP_SCi_EXCL_RTIME]);
trace = 1;
}
}
if (trace) {
if (!fid && !line) {
logwarn("%s is xsub\n", called_subname);
}
else {
logwarn("%s called by %.*s at %u:%u: count %ld (i%"NVff"s e%"NVff"s, d%d ri%"NVff"s)\n",
called_subname, (int)caller_subname_len, caller_subname, fid, line,
(long)sc[NYTP_SCi_CALL_COUNT], sc[NYTP_SCi_INCL_RTIME], sc[NYTP_SCi_EXCL_RTIME],
(int)sc[NYTP_SCi_REC_DEPTH], sc[NYTP_SCi_RECI_RTIME]);
}
}
}
}
if (negative_time_calls) {
logwarn("Warning: %d subroutine calls had negative time! See TROUBLESHOOTING in the documentation. (Clock %ld)\n",
negative_time_calls, (long)profile_clock);
}
}
static void
write_src_of_files(pTHX)
{
fid_hash_entry *e;
int t_has_src = 0;
int t_save_src = 0;
int t_no_src = 0;
long t_lines = 0;
if (trace_level >= 1)
logwarn("~ writing file source code\n");
for (e = (fid_hash_entry*)fidhash.first_inserted; e; e = (fid_hash_entry*)e->he.next_inserted) {
I32 lines;
int line;
AV *src_av = GvAV(gv_fetchfile_flags(e->he.key, e->he.key_len, 0));
if ( !(e->fid_flags & NYTP_FIDf_HAS_SRC) ) {
const char *hint = "";
++t_no_src;
if (src_av && av_len(src_av) > -1) /* sanity check */
hint = " (NYTP_FIDf_HAS_SRC not set but src available!)";
if (trace_level >= 3 || *hint)
logwarn("fid %d has no src saved for %.*s%s\n",
e->he.id, e->he.key_len, e->he.key, hint);
continue;
}
if (!src_av) { /* sanity check */
++t_no_src;
logwarn("fid %d has no src but NYTP_FIDf_HAS_SRC is set! (%.*s)\n",
e->he.id, e->he.key_len, e->he.key);
continue;
}
++t_has_src;
if ( !(e->fid_flags & NYTP_FIDf_SAVE_SRC) ) {
continue;
}
++t_save_src;
lines = av_len(src_av); /* -1 is empty, 1 is 1 line etc, 0 shouldn't happen */
if (trace_level >= 3)
logwarn("fid %d has %ld src lines for %.*s\n",
e->he.id, (long)lines, e->he.key_len, e->he.key);
for (line = 1; line <= lines; ++line) { /* lines start at 1 */
SV **svp = av_fetch(src_av, line, 0);
STRLEN len = 0;
const char *src = (svp) ? SvPV(*svp, len) : "";
/* outputting the tag and fid for each (non empty) line
* is a little inefficient, but not enough to worry about */
NYTP_write_src_line(out, e->he.id, line, src, (I32)len); /* includes newline */
if (trace_level >= 8) {
logwarn("fid %d src line %d: %s%s", e->he.id, line, src,
(len && src[len-1]=='\n') ? "" : "\n");
}
++t_lines;
}
}
if (trace_level >= 2)
logwarn("~ wrote %ld source lines for %d files (%d skipped without savesrc option, %d others had no source available)\n",
t_lines, t_save_src, t_has_src-t_save_src, t_no_src);
}
static void
normalize_eval_seqn(pTHX_ SV *sv) {
/* in-place-edit any eval sequence numbers to 0 */
STRLEN len;
char *start = SvPV(sv, len);
char *first_space;
return; /* disabled, again */
/* effectively does
s/(
\( # first character is literal (
(?:re_)?eval\ # eval or re_eval followed by space
) # [capture that]
[0-9]+ # digits
(?=\)) # look ahead for literal )
/$1 0/xg # and rebuild, replacing the digts with 0
*/
/* Assumption is that space is the least common character in a filename. */
for (; len >= 8 && (first_space = (char *)memchr(start, ' ', len));
(len -= first_space +1 - start), (start = first_space + 1)) {
char *first_digit;
char *close;
if (!((first_space - start >= 5
&& memEQ(first_space - 5, "(eval", 5))
|| (first_space - start >= 8
&& memEQ(first_space - 8, "(re_eval", 8)))) {
/* Fixed string not found. Try again. */
continue;
}
first_digit = first_space + 1;
if (*first_digit < '0' || *first_digit > '9')
continue;
close = first_digit + 1;
while (*close >= '0' && *close <= '9')
++close;
if (*close != ')')
continue;
if (trace_level >= 15)
logwarn("recognized eval in name at '%s' in %s\n", first_digit, start);
*first_digit++ = '0';
/* first_digit now points to the target of the move. */
if (close != first_digit) {
/* 2 or more digits */
memmove(first_digit, close,
start + len + 1 /* pointer beyond the trailing '\0' */
- close); /* pointer to the ) */
len -= (close - first_digit);
SvCUR_set(sv, SvCUR(sv) - (close - first_digit));
}
if (trace_level >= 15)
logwarn("edited it to: %s\n", start);
}
}
static AV *
lookup_subinfo_av(pTHX_ SV *subname_sv, HV *sub_subinfo_hv)
{
/* { 'pkg::sub' => [
* fid, first_line, last_line, incl_time
* ], ... }
*/
HE *he = hv_fetch_ent(sub_subinfo_hv, subname_sv, 1, 0);
SV *sv = HeVAL(he);
if (!SvROK(sv)) { /* autoviv */
AV *av = newAV();
SV *rv = newRV_noinc((SV *)av);
/* 0: fid - may be undef
* 1: start_line - may be undef if not known and not known to be xs
* 2: end_line - ditto
* typically due to an xsub that was called but exited via an exception
*/
sv_setsv(*av_fetch(av, NYTP_SIi_SUB_NAME, 1), newSVsv(subname_sv));
sv_setuv(*av_fetch(av, NYTP_SIi_CALL_COUNT, 1), 0); /* call count */
sv_setnv(*av_fetch(av, NYTP_SIi_INCL_RTIME, 1), 0.0); /* incl_time */
sv_setnv(*av_fetch(av, NYTP_SIi_EXCL_RTIME, 1), 0.0); /* excl_time */
sv_setsv(*av_fetch(av, NYTP_SIi_PROFILE, 1), &PL_sv_undef); /* ref to profile */
sv_setuv(*av_fetch(av, NYTP_SIi_REC_DEPTH, 1), 0); /* rec_depth */
sv_setnv(*av_fetch(av, NYTP_SIi_RECI_RTIME, 1), 0.0); /* reci_time */
sv_setsv(sv, rv);
}
return (AV *)SvRV(sv);
}
static void
store_attrib_sv(pTHX_ HV *attr_hv, const char *text, I32 text_len, SV *value_sv)
{
(void)hv_store(attr_hv, text, text_len, value_sv, 0);
if (trace_level >= 1)
logwarn(": %.*s = '%s'\n", (int) text_len, text, SvPV_nolen(value_sv));
}
#if 0 /* not used at the moment */
static int
eval_outer_fid(pTHX_
AV *fid_fileinfo_av,
unsigned int fid,
int recurse,
unsigned int *eval_file_num_ptr,
unsigned int *eval_line_num_ptr
) {
unsigned int outer_fid;
AV *av;
SV *fid_info_rvav = *av_fetch(fid_fileinfo_av, fid, 1);
if (!SvROK(fid_info_rvav)) /* should never happen */
return 0;
av = (AV *)SvRV(fid_info_rvav);
outer_fid = (unsigned int)SvUV(*av_fetch(av,NYTP_FIDi_EVAL_FID,1));
if (!outer_fid)
return 0;
if (outer_fid == fid) {
logwarn("Possible corruption: eval_outer_fid of %d is %d!\n", fid, outer_fid);
return 0;
}
if (eval_file_num_ptr)
*eval_file_num_ptr = outer_fid;
if (eval_line_num_ptr)
*eval_line_num_ptr = (unsigned int)SvUV(*av_fetch(av,NYTP_FIDi_EVAL_LINE,1));
if (recurse)
eval_outer_fid(aTHX_ fid_fileinfo_av, outer_fid, recurse, eval_file_num_ptr, eval_line_num_ptr);
return 1;
}
#endif
typedef struct loader_state_base {
unsigned long input_chunk_seqn;
} Loader_state_base;
typedef void (*loader_callback)(Loader_state_base *cb_data, const nytp_tax_index tag, ...);
typedef struct loader_state_callback {
Loader_state_base base_state;
#ifdef MULTIPLICITY
PerlInterpreter *interp;
#endif
CV *cb[nytp_tag_max];
SV *cb_args[11]; /* must be large enough for the largest callback argument list */
SV *tag_names[nytp_tag_max];
SV *input_chunk_seqn_sv;
} Loader_state_callback;
typedef struct loader_state_profiler {
Loader_state_base base_state;
#ifdef MULTIPLICITY
PerlInterpreter *interp;
#endif
unsigned int last_file_num;
unsigned int last_line_num;
int statement_discount;
UV total_stmts_discounted;
UV total_stmts_measured;
NV total_stmts_duration;
UV total_sub_calls;
AV *fid_line_time_av;
AV *fid_block_time_av;
AV *fid_sub_time_av;
AV *fid_srclines_av;
AV *fid_fileinfo_av;
HV *sub_subinfo_hv;
HV *live_pids_hv;
HV *attr_hv;
HV *option_hv;
HV *file_info_stash;
/* these times don't reflect profile_enable & profile_disable calls */
NV profiler_start_time;
NV profiler_end_time;
NV profiler_duration;
} Loader_state_profiler;
static void
load_discount_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
PERL_UNUSED_ARG(tag);
if (trace_level >= 8)
logwarn("discounting next statement after %u:%d\n",
state->last_file_num, state->last_line_num);
if (state->statement_discount)
logwarn("multiple statement discount after %u:%d\n",
state->last_file_num, state->last_line_num);
++state->statement_discount;
++state->total_stmts_discounted;
}
static void
load_time_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
char trace_note[80] = "";
SV *fid_info_rvav;
NV seconds;
unsigned int eval_file_num = 0;
unsigned int eval_line_num = 0;
I32 ticks;
unsigned int file_num;
unsigned int line_num;
va_start(args, tag);
ticks = va_arg(args, I32);
file_num = va_arg(args, unsigned int);
line_num = va_arg(args, unsigned int);
seconds = (NV)ticks / ticks_per_sec;
fid_info_rvav = *av_fetch(state->fid_fileinfo_av, file_num, 1);
if (!SvROK(fid_info_rvav)) { /* should never happen */
if (!SvOK(fid_info_rvav)) { /* only warn once */
logwarn("Fid %u used but not defined\n", file_num);
sv_setsv(fid_info_rvav, &PL_sv_no);
}
}
if (trace_level >= 8) {
const char *new_file_name = "";
if (file_num != state->last_file_num && SvROK(fid_info_rvav))
new_file_name = SvPV_nolen(*av_fetch((AV *)SvRV(fid_info_rvav), NYTP_FIDi_FILENAME, 1));
logwarn("Read %d:%-4d %2ld ticks%s %s\n",
file_num, line_num, (long)ticks, trace_note, new_file_name);
}
add_entry(aTHX_ state->fid_line_time_av, file_num, line_num,
seconds, eval_file_num, eval_line_num,
1 - state->statement_discount
);
if (tag == nytp_time_block) {
unsigned int block_line_num = va_arg(args, unsigned int);
unsigned int sub_line_num = va_arg(args, unsigned int);
if (!state->fid_block_time_av)
state->fid_block_time_av = newAV();
add_entry(aTHX_ state->fid_block_time_av, file_num, block_line_num,
seconds, eval_file_num, eval_line_num,
1 - state->statement_discount
);
if (!state->fid_sub_time_av)
state->fid_sub_time_av = newAV();
add_entry(aTHX_ state->fid_sub_time_av, file_num, sub_line_num,
seconds, eval_file_num, eval_line_num,
1 - state->statement_discount
);
if (trace_level >= 8)
logwarn("\tblock %u, sub %u\n", block_line_num, sub_line_num);
}
va_end(args);
state->total_stmts_measured++;
state->total_stmts_duration += seconds;
state->statement_discount = 0;
state->last_file_num = file_num;
state->last_line_num = line_num;
}
static void
load_new_fid_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
AV *av;
SV *rv;
SV **svp;
SV *filename_sv;
unsigned int file_num;
unsigned int eval_file_num;
unsigned int eval_line_num;
unsigned int fid_flags;
unsigned int file_size;
unsigned int file_mtime;
va_start(args, tag);
file_num = va_arg(args, unsigned int);
eval_file_num = va_arg(args, unsigned int);
eval_line_num = va_arg(args, unsigned int);
fid_flags = va_arg(args, unsigned int);
file_size = va_arg(args, unsigned int);
file_mtime = va_arg(args, unsigned int);
filename_sv = va_arg(args, SV *);
va_end(args);
if (trace_level >= 2) {
char buf[80];
char parent_fid[80];
if (eval_file_num || eval_line_num)
sprintf(parent_fid, " (is eval at %u:%u)", eval_file_num, eval_line_num);
else
sprintf(parent_fid, " (file sz%d mt%d)", file_size, file_mtime);
logwarn("Fid %2u is %s%s 0x%x(%s)\n",
file_num, SvPV_nolen(filename_sv), parent_fid,
fid_flags, fmt_fid_flags(aTHX_ fid_flags, buf, sizeof(buf)));
}
/* [ name, eval_file_num, eval_line_num, fid, flags, size, mtime, ... ]
*/
av = newAV();
rv = newRV_noinc((SV*)av);
sv_bless(rv, state->file_info_stash);
svp = av_fetch(state->fid_fileinfo_av, file_num, 1);
if (SvOK(*svp)) { /* should never happen, perhaps file is corrupt */
AV *old_av = (AV *)SvRV(*av_fetch(state->fid_fileinfo_av, file_num, 1));
SV *old_name = *av_fetch(old_av, 0, 1);
logwarn("Fid %d redefined from %s to %s\n", file_num,
SvPV_nolen(old_name), SvPV_nolen(filename_sv));
}
sv_setsv(*svp, rv);
av_store(av, NYTP_FIDi_FILENAME, filename_sv); /* av now owns the sv */
if (eval_file_num) {
SV *has_evals;
/* this eval fid refers to the fid that contained the eval */
SV *eval_fi = *av_fetch(state->fid_fileinfo_av, eval_file_num, 1);
if (!SvROK(eval_fi)) { /* should never happen */
char buf[80];
logwarn("Eval '%s' (fid %d, flags:%s) has unknown invoking fid %d\n",
SvPV_nolen(filename_sv), file_num,
fmt_fid_flags(aTHX_ fid_flags, buf, sizeof(buf)), eval_file_num);
/* so make it look like a real file instead of an eval */
av_store(av, NYTP_FIDi_EVAL_FI, NULL);
eval_file_num = 0;
eval_line_num = 0;
}
else {
av_store(av, NYTP_FIDi_EVAL_FI, sv_rvweaken(newSVsv(eval_fi)));
/* the fid that contained the eval has a list of eval fids */
has_evals = *av_fetch((AV *)SvRV(eval_fi), NYTP_FIDi_HAS_EVALS, 1);
if (!SvROK(has_evals)) /* autoviv */
sv_setsv(has_evals, newRV_noinc((SV*)newAV()));
av_push((AV *)SvRV(has_evals), sv_rvweaken(newSVsv(rv)));
}
}
else {
av_store(av, NYTP_FIDi_EVAL_FI, NULL);
}
av_store(av, NYTP_FIDi_EVAL_FID, (eval_file_num) ? newSVuv(eval_file_num) : &PL_sv_no);
av_store(av, NYTP_FIDi_EVAL_LINE, (eval_file_num) ? newSVuv(eval_line_num) : &PL_sv_no);
av_store(av, NYTP_FIDi_FID, newSVuv(file_num));
av_store(av, NYTP_FIDi_FLAGS, newSVuv(fid_flags));
av_store(av, NYTP_FIDi_FILESIZE, newSVuv(file_size));
av_store(av, NYTP_FIDi_FILEMTIME, newSVuv(file_mtime));
av_store(av, NYTP_FIDi_PROFILE, NULL);
av_store(av, NYTP_FIDi_HAS_EVALS, NULL);
av_store(av, NYTP_FIDi_SUBS_DEFINED, newRV_noinc((SV*)newHV()));
av_store(av, NYTP_FIDi_SUBS_CALLED, newRV_noinc((SV*)newHV()));
}
static void
load_src_line_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
unsigned int file_num;
unsigned int line_num;
SV *src;
AV *file_av;
va_start(args, tag);
file_num = va_arg(args, unsigned int);
line_num = va_arg(args, unsigned int);
src = va_arg(args, SV *);
va_end(args);
/* first line in the file seen */
if (!av_exists(state->fid_srclines_av, file_num)) {
file_av = newAV();
av_store(state->fid_srclines_av, file_num, newRV_noinc((SV*)file_av));
}
else {
file_av = (AV *)SvRV(*av_fetch(state->fid_srclines_av, file_num, 1));
}
av_store(file_av, line_num, src);
if (trace_level >= 8) {
logwarn("Fid %2u:%u src: %s\n", file_num, line_num, SvPV_nolen(src));
}
}
static void
load_sub_info_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
unsigned int fid;
unsigned int first_line;
unsigned int last_line;
SV *subname_sv;
int skip_subinfo_store = 0;
STRLEN subname_len;
char *subname_pv;
AV *av;
SV *sv;
va_start(args, tag);
fid = va_arg(args, unsigned int);
first_line = va_arg(args, unsigned int);
last_line = va_arg(args, unsigned int);
subname_sv = va_arg(args, SV *);
va_end(args);
normalize_eval_seqn(aTHX_ subname_sv);
subname_pv = SvPV(subname_sv, subname_len);
if (trace_level >= 2)
logwarn("Sub %s fid %u lines %u..%u\n",
subname_pv, fid, first_line, last_line);
av = lookup_subinfo_av(aTHX_ subname_sv, state->sub_subinfo_hv);
if (SvOK(*av_fetch(av, NYTP_SIi_FID, 1))) {
/* We've already seen this subroutine name.
* Should only happen for anon subs in string evals so we warn
* for other cases.
*/
if (!instr(subname_pv, "__ANON__[(eval"))
logwarn("Sub %s already defined!\n", subname_pv);
/* We could always discard the fid+first_line+last_line here,
* because we already have them stored, but for consistency
* (and for the stability of the tests) we'll prefer the lowest fid
*/
if (fid > SvUV(*av_fetch(av, NYTP_SIi_FID, 1)))
skip_subinfo_store = 1;
/* Finally, note that the fileinfo NYTP_FIDi_SUBS_DEFINED hash,
* updated below, does get an entry for the sub *from each fid*
* (ie string eval) that defines the subroutine.
*/
}
if (!skip_subinfo_store) {
sv_setuv(*av_fetch(av, NYTP_SIi_FID, 1), fid);
sv_setuv(*av_fetch(av, NYTP_SIi_FIRST_LINE, 1), first_line);
sv_setuv(*av_fetch(av, NYTP_SIi_LAST_LINE, 1), last_line);
}
/* add sub to NYTP_FIDi_SUBS_DEFINED hash */
sv = SvRV(*av_fetch(state->fid_fileinfo_av, fid, 1));
sv = SvRV(*av_fetch((AV *)sv, NYTP_FIDi_SUBS_DEFINED, 1));
(void)hv_store((HV *)sv, subname_pv, (I32)subname_len, newRV_inc((SV*)av), 0);
}
static void
load_sub_callers_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
unsigned int fid;
unsigned int line;
SV *caller_subname_sv;
unsigned int count;
NV incl_time;
NV excl_time;
NV reci_time;
unsigned int rec_depth;
SV *called_subname_sv;
char text[MAXPATHLEN*2];
SV *sv;
AV *subinfo_av;
int len;
va_start(args, tag);
fid = va_arg(args, unsigned int);
line = va_arg(args, unsigned int);
count = va_arg(args, unsigned int);
incl_time = va_arg(args, NV);
excl_time = va_arg(args, NV);
reci_time = va_arg(args, NV);
rec_depth = va_arg(args, unsigned int);
called_subname_sv = va_arg(args, SV *);
caller_subname_sv = va_arg(args, SV *);
va_end(args);
normalize_eval_seqn(aTHX_ caller_subname_sv);
normalize_eval_seqn(aTHX_ called_subname_sv);
if (trace_level >= 6)
logwarn("Sub %s called by %s %u:%u: count %d, incl %"NVff", excl %"NVff"\n",
SvPV_nolen(called_subname_sv), SvPV_nolen(caller_subname_sv),
fid, line, count, incl_time, excl_time);
subinfo_av = lookup_subinfo_av(aTHX_ called_subname_sv, state->sub_subinfo_hv);
/* subinfo_av's NYTP_SIi_CALLED_BY element is a hash ref:
* { caller_fid => { caller_line => [ count, incl_time, ... ] } }
*/
sv = *av_fetch(subinfo_av, NYTP_SIi_CALLED_BY, 1);
if (!SvROK(sv)) /* autoviv */
sv_setsv(sv, newRV_noinc((SV*)newHV()));
len = sprintf(text, "%u", fid);
sv = *hv_fetch((HV*)SvRV(sv), text, len, 1);
if (!SvROK(sv)) /* autoviv */
sv_setsv(sv, newRV_noinc((SV*)newHV()));
/* XXX gets called with fid=0 to indicate is_xsub
* That's a hack that should be removed once we have per-sub flags
*/
if (fid) {
SV *fi;
AV *av;
len = sprintf(text, "%u", line);
sv = *hv_fetch((HV*)SvRV(sv), text, len, 1);
if (!SvROK(sv)) /* autoviv */
sv_setsv(sv, newRV_noinc((SV*)newAV()));
else if (trace_level)
/* calls to sub1 from the same fid:line could have different caller
* subs due to evals or if profile_findcaller is off.
*/
logwarn("Merging extra sub caller info for %s called at %d:%d\n",
SvPV_nolen(called_subname_sv), fid, line);
av = (AV *)SvRV(sv);
sv = *av_fetch(av, NYTP_SCi_CALL_COUNT, 1);
sv_setuv(sv, (SvOK(sv)) ? SvUV(sv) + count : count);
sv = *av_fetch(av, NYTP_SCi_INCL_RTIME, 1);
sv_setnv(sv, (SvOK(sv)) ? SvNV(sv) + incl_time : incl_time);
sv = *av_fetch(av, NYTP_SCi_EXCL_RTIME, 1);
sv_setnv(sv, (SvOK(sv)) ? SvNV(sv) + excl_time : excl_time);
sv = *av_fetch(av, NYTP_SCi_INCL_TICKS, 1);
sv_setnv(sv, 0.0);
sv = *av_fetch(av, NYTP_SCi_EXCL_TICKS, 1);
sv_setnv(sv, 0.0);
sv = *av_fetch(av, NYTP_SCi_RECI_RTIME, 1);
sv_setnv(sv, (SvOK(sv)) ? SvNV(sv) + reci_time : reci_time);
sv = *av_fetch(av, NYTP_SCi_REC_DEPTH, 1);
if (!SvOK(sv) || SvUV(sv) < rec_depth) /* max() */
sv_setuv(sv, rec_depth);
/* XXX temp hack way to store calling subname */
sv = *av_fetch(av, NYTP_SCi_CALLING_SUB, 1);
if (!SvROK(sv)) /* autoviv */
sv_setsv(sv, newRV_noinc((SV*)newHV()));
(void)hv_fetch_ent((HV *)SvRV(sv), caller_subname_sv, 1, 0);
/* also reference this sub call info array from the calling fileinfo
* fi->[NYTP_FIDi_SUBS_CALLED] => { line => { subname => [ ... ] } }
*/
fi = SvRV(*av_fetch(state->fid_fileinfo_av, fid, 1));
fi = *av_fetch((AV *)fi, NYTP_FIDi_SUBS_CALLED, 1);
fi = *hv_fetch((HV*)SvRV(fi), text, len, 1);
if (!SvROK(fi)) /* autoviv */
sv_setsv(fi, newRV_noinc((SV*)newHV()));
fi = HeVAL(hv_fetch_ent((HV *)SvRV(fi), called_subname_sv, 1, 0));
if (1) { /* ref a clone of the sub call info array */
AV *av2 = av_make(AvFILL(av)+1, AvARRAY(av));
av = av2;
}
sv_setsv(fi, newRV_inc((SV *)av));
}
else { /* is meta-data about sub */
/* line == 0: is_xs - set line range to 0,0 as marker */
sv_setiv(*av_fetch(subinfo_av, NYTP_SIi_FIRST_LINE, 1), 0);
sv_setiv(*av_fetch(subinfo_av, NYTP_SIi_LAST_LINE, 1), 0);
}
/* accumulate per-sub totals into subinfo */
sv = *av_fetch(subinfo_av, NYTP_SIi_CALL_COUNT, 1);
sv_setuv(sv, count + (SvOK(sv) ? SvUV(sv) : 0));
sv = *av_fetch(subinfo_av, NYTP_SIi_INCL_RTIME, 1);
sv_setnv(sv, incl_time + (SvOK(sv) ? SvNV(sv) : 0.0));
sv = *av_fetch(subinfo_av, NYTP_SIi_EXCL_RTIME, 1);
sv_setnv(sv, excl_time + (SvOK(sv) ? SvNV(sv) : 0.0));
/* sub rec_depth - record the maximum */
sv = *av_fetch(subinfo_av, NYTP_SIi_REC_DEPTH, 1);
if (!SvOK(sv) || rec_depth > SvUV(sv))
sv_setuv(sv, rec_depth);
sv = *av_fetch(subinfo_av, NYTP_SIi_RECI_RTIME, 1);
sv_setnv(sv, reci_time + (SvOK(sv) ? SvNV(sv) : 0.0));
state->total_sub_calls += count;
}
static void
load_pid_start_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
unsigned int pid;
unsigned int ppid;
NV start_time;
char text[MAXPATHLEN*2];
int len;
va_start(args, tag);
pid = va_arg(args, unsigned int);
ppid = va_arg(args, unsigned int);
start_time = va_arg(args, NV);
va_end(args);
state->profiler_start_time = start_time;
len = sprintf(text, "%d", pid);
(void)hv_store(state->live_pids_hv, text, len, newSVuv(ppid), 0);
if (trace_level)
logwarn("Start of profile data for pid %s (ppid %d, %"IVdf" pids live) at %"NVff"\n",
text, ppid, HvKEYS(state->live_pids_hv), start_time);
store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_start_time"),
newSVnv(start_time));
}
static void
load_pid_end_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
unsigned int pid;
NV end_time;
char text[MAXPATHLEN*2];
int len;
va_start(args, tag);
pid = va_arg(args, unsigned int);
end_time = va_arg(args, NV);
va_end(args);
state->profiler_end_time = end_time;
len = sprintf(text, "%d", pid);
if (!hv_delete(state->live_pids_hv, text, len, 0))
logwarn("Inconsistent pids in profile data (pid %d not introduced)\n",
pid);
if (trace_level)
logwarn("End of profile data for pid %s (%"IVdf" remaining) at %"NVff"\n", text,
HvKEYS(state->live_pids_hv), state->profiler_end_time);
store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_end_time"),
newSVnv(end_time));
state->profiler_duration += state->profiler_end_time - state->profiler_start_time;
store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_duration"),
newSVnv(state->profiler_duration));
}
static void
load_attribute_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
char *key;
unsigned long key_len;
unsigned int key_utf8;
char *value;
unsigned long value_len;
unsigned int value_utf8;
va_start(args, tag);
key = va_arg(args, char *);
key_len = va_arg(args, unsigned long);
key_utf8 = va_arg(args, unsigned int);
value = va_arg(args, char *);
value_len = va_arg(args, unsigned long);
value_utf8 = va_arg(args, unsigned int);
va_end(args);
store_attrib_sv(aTHX_ state->attr_hv, key,
key_utf8 ? -(I32)key_len : key_len,
newSVpvn_flags(value, value_len,
value_utf8 ? SVf_UTF8 : 0));
}
static void
load_option_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
dTHXa(state->interp);
va_list args;
char *key;
unsigned long key_len;
unsigned int key_utf8;
char *value;
unsigned long value_len;
unsigned int value_utf8;
SV *value_sv;
va_start(args, tag);
key = va_arg(args, char *);
key_len = va_arg(args, unsigned long);
key_utf8 = va_arg(args, unsigned int);
value = va_arg(args, char *);
value_len = va_arg(args, unsigned long);
value_utf8 = va_arg(args, unsigned int);
va_end(args);
value_sv = newSVpvn_flags(value, value_len, value_utf8 ? SVf_UTF8 : 0);
(void)hv_store(state->option_hv, key, key_utf8 ? -(I32)key_len : key_len, value_sv, 0);
if (trace_level >= 1)
logwarn("! %.*s = '%s'\n", (int) key_len, key, SvPV_nolen(value_sv));
}
struct perl_callback_info_t {
const char *description;
STRLEN len;
const char *args;
};
static struct perl_callback_info_t callback_info[nytp_tag_max] =
{
{STR_WITH_LEN("[no tag]"), NULL},
{STR_WITH_LEN("VERSION"), "uu"},
{STR_WITH_LEN("ATTRIBUTE"), "33"},
{STR_WITH_LEN("OPTION"), "33"},
{STR_WITH_LEN("COMMENT"), "3"},
{STR_WITH_LEN("TIME_BLOCK"), "iuuuu"},
{STR_WITH_LEN("TIME_LINE"), "iuu"},
{STR_WITH_LEN("DISCOUNT"), ""},
{STR_WITH_LEN("NEW_FID"), "uuuuuuS"},
{STR_WITH_LEN("SRC_LINE"), "uuS"},
{STR_WITH_LEN("SUB_INFO"), "uuus"},
{STR_WITH_LEN("SUB_CALLERS"), "uuunnnuss"},
{STR_WITH_LEN("PID_START"), "uun"},
{STR_WITH_LEN("PID_END"), "un"},
{STR_WITH_LEN("[string]"), NULL},
{STR_WITH_LEN("[string utf8]"), NULL},
{STR_WITH_LEN("START_DEFLATE"), ""},
{STR_WITH_LEN("SUB_ENTRY"), "uu"},
{STR_WITH_LEN("SUB_RETURN"), "unns"}
};
static void
load_perl_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_callback *state = (Loader_state_callback *)cb_data;
dTHXa(state->interp);
dSP;
va_list args;
SV **cb_args = state->cb_args;
int i = 0;
char type;
const char *arglist = callback_info[tag].args;
const char *const description = callback_info[tag].description;
if (!arglist) {
if (description)
croak("Type '%s' passed to perl callback incorrectly", description);
else
croak("Unknown type %d passed to perl callback", tag);
}
if (!state->cb[tag])
return;
if (trace_level >= 9) {
logwarn("\tcallback %s[%s] \n", description, arglist);
}
sv_setuv_mg(state->input_chunk_seqn_sv, state->base_state.input_chunk_seqn);
va_start(args, tag);
PUSHMARK(SP);
XPUSHs(state->tag_names[tag]);
while ((type = *arglist++)) {
switch(type) {
case 'u':
{
unsigned int u = va_arg(args, unsigned int);
sv_setuv(cb_args[i], u);
XPUSHs(cb_args[i++]);
break;
}
case 'i':
{
I32 i32 = va_arg(args, I32);
sv_setuv(cb_args[i], i32);
XPUSHs(cb_args[i++]);
break;
}
case 'n':
{
NV n = va_arg(args, NV);
sv_setnv(cb_args[i], n);
XPUSHs(cb_args[i++]);
break;
}
case 's':
{
SV *sv = va_arg(args, SV *);
sv_setsv(cb_args[i], sv);
XPUSHs(cb_args[i++]);
break;
}
case 'S':
{
SV *sv = va_arg(args, SV *);
XPUSHs(sv_2mortal(sv));
break;
}
case '3':
{
char *p = va_arg(args, char *);
unsigned long len = va_arg(args, unsigned long);
unsigned int utf8 = va_arg(args, unsigned int);
sv_setpvn(cb_args[i], p, len);
if (utf8)
SvUTF8_on(cb_args[i]);
else
SvUTF8_off(cb_args[i]);
XPUSHs(cb_args[i++]);
break;
}
default:
croak("Bad type '%c' in perl callback", type);
}
}
va_end(args);
assert(i <= C_ARRAY_LENGTH(state->cb_args));
PUTBACK;
call_sv((SV *)state->cb[tag], G_DISCARD);
}
static loader_callback perl_callbacks[nytp_tag_max] =
{
0,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback,
load_perl_callback
};
static loader_callback processing_callbacks[nytp_tag_max] =
{
0,
0, /* version */
load_attribute_callback,
load_option_callback,
0, /* comment */
load_time_callback,
load_time_callback,
load_discount_callback,
load_new_fid_callback,
load_src_line_callback,
load_sub_info_callback,
load_sub_callers_callback,
load_pid_start_callback,
load_pid_end_callback,
0, /* string */
0, /* string utf8 */
0, /* sub entry */
0, /* sub return */
0 /* start deflate */
};
/**
* Process a profile output file and return the results in a hash like
* { fid_fileinfo => [ [file, other...info ], ... ], # index by [fid]
* fid_line_time => [ [...],[...],.. ] # index by [fid][line]
* }
* The value of each [fid][line] is an array ref containing:
* [ number of calls, total time spent ]
* lines containing string evals also get an extra element
* [ number of calls, total time spent, [...] ]
* which is an reference to an array containing the [calls,time]
* data for each line of the string eval.
*/
static void
load_profile_data_from_stream(loader_callback *callbacks,
Loader_state_base *state, NYTP_file in)
{
dTHX;
int file_major, file_minor;
SV *tmp_str1_sv = newSVpvn("",0);
SV *tmp_str2_sv = newSVpvn("",0);
size_t buffer_len = MAXPATHLEN * 2;
char *buffer = (char *)safemalloc(buffer_len);
if (1) {
if (!NYTP_gets(in, &buffer, &buffer_len))
croak("NYTProf data format error while reading header");
if (2 != sscanf(buffer, "NYTProf %d %d\n", &file_major, &file_minor))
croak("NYTProf data format error while parsing header");
if (file_major != NYTP_FILE_MAJOR_VERSION)
croak("NYTProf data format version %d.%d is not supported by NYTProf %s (which expects version %d.%d)",
file_major, file_minor, XS_VERSION, NYTP_FILE_MAJOR_VERSION, NYTP_FILE_MINOR_VERSION);
if (file_minor > NYTP_FILE_MINOR_VERSION)
warn("NYTProf data format version %d.%d is newer than that understood by this NYTProf %s, so errors are likely",
file_major, file_minor, XS_VERSION);
}
if (callbacks[nytp_version])
callbacks[nytp_version](state, nytp_version, file_major, file_minor);
while (1) {
/* Loop "forever" until EOF. We can only check the EOF flag *after* we
attempt a read. */
char c;
if (NYTP_read_unchecked(in, &c, sizeof(c)) != sizeof(c)) {
if (NYTP_eof(in))
break;
croak("Profile format error '%s' whilst reading tag at %ld",
NYTP_fstrerror(in), NYTP_tell(in));
}
state->input_chunk_seqn++;
if (trace_level >= 9)
logwarn("Chunk %lu token is %d ('%c') at %ld%s\n",
state->input_chunk_seqn, c, c, NYTP_tell(in)-1,
NYTP_type_of_offset(in));
switch (c) {
case NYTP_TAG_DISCOUNT:
{
callbacks[nytp_discount](state, nytp_discount);
break;
}
case NYTP_TAG_TIME_LINE: /*FALLTHRU*/
case NYTP_TAG_TIME_BLOCK:
{
I32 ticks = read_i32(in);
unsigned int file_num = read_u32(in);
unsigned int line_num = read_u32(in);
unsigned int block_line_num = 0;
unsigned int sub_line_num = 0;
nytp_tax_index tag = nytp_time_line;
if (c == NYTP_TAG_TIME_BLOCK) {
block_line_num = read_u32(in);
sub_line_num = read_u32(in);
tag = nytp_time_block;
}
/* Because it happens that the two "optional" arguments are
last, a single call will work. */
callbacks[tag](state, tag, ticks, file_num, line_num,
block_line_num, sub_line_num);
break;
}
case NYTP_TAG_NEW_FID: /* file */
{
SV *filename_sv;
unsigned int file_num = read_u32(in);
unsigned int eval_file_num = read_u32(in);
unsigned int eval_line_num = read_u32(in);
unsigned int fid_flags = read_u32(in);
unsigned int file_size = read_u32(in);
unsigned int file_mtime = read_u32(in);
filename_sv = read_str(aTHX_ in, NULL);
callbacks[nytp_new_fid](state, nytp_new_fid, file_num,
eval_file_num, eval_line_num,
fid_flags, file_size, file_mtime,
filename_sv);
break;
}
case NYTP_TAG_SRC_LINE:
{
unsigned int file_num = read_u32(in);
unsigned int line_num = read_u32(in);
SV *src = read_str(aTHX_ in, NULL);
callbacks[nytp_src_line](state, nytp_src_line, file_num,
line_num, src);
break;
}
case NYTP_TAG_SUB_ENTRY:
{
unsigned int file_num = read_u32(in);
unsigned int line_num = read_u32(in);
if (callbacks[nytp_sub_entry])
callbacks[nytp_sub_entry](state, nytp_sub_entry, file_num, line_num);
break;
}
case NYTP_TAG_SUB_RETURN:
{
unsigned int depth = read_u32(in);
NV incl_time = read_nv(in);
NV excl_time = read_nv(in);
SV *subname = read_str(aTHX_ in, tmp_str1_sv);
if (callbacks[nytp_sub_return])
callbacks[nytp_sub_return](state, nytp_sub_return, depth, incl_time, excl_time, subname);
break;
}
case NYTP_TAG_SUB_INFO:
{
unsigned int fid = read_u32(in);
SV *subname_sv = read_str(aTHX_ in, tmp_str1_sv);
unsigned int first_line = read_u32(in);
unsigned int last_line = read_u32(in);
callbacks[nytp_sub_info](state, nytp_sub_info, fid,
first_line, last_line, subname_sv);
break;
}
case NYTP_TAG_SUB_CALLERS:
{
unsigned int fid = read_u32(in);
unsigned int line = read_u32(in);
SV *caller_subname_sv = read_str(aTHX_ in, tmp_str2_sv);
unsigned int count = read_u32(in);
NV incl_time = read_nv(in);
NV excl_time = read_nv(in);
NV reci_time = read_nv(in);
unsigned int rec_depth = read_u32(in);
SV *called_subname_sv = read_str(aTHX_ in, tmp_str1_sv);
callbacks[nytp_sub_callers](state, nytp_sub_callers, fid,
line, count, incl_time, excl_time,
reci_time, rec_depth,
called_subname_sv,
caller_subname_sv);
break;
}
case NYTP_TAG_PID_START:
{
unsigned int pid = read_u32(in);
unsigned int ppid = read_u32(in);
NV start_time = read_nv(in);
callbacks[nytp_pid_start](state, nytp_pid_start, pid, ppid,
start_time);
break;
}
case NYTP_TAG_PID_END:
{
unsigned int pid = read_u32(in);
NV end_time = read_nv(in);
callbacks[nytp_pid_end](state, nytp_pid_end, pid, end_time);
break;
}
case NYTP_TAG_ATTRIBUTE:
{
char *value, *key_end;
char *end = NYTP_gets(in, &buffer, &buffer_len);
if (NULL == end)
/* probably EOF */
croak("Profile format error reading attribute");
--end; /* End, as returned, points 1 after the \n */
if ((NULL == (value = (char *)memchr(buffer, '=', end - buffer)))) {
logwarn("attribute malformed '%s'\n", buffer);
continue;
}
key_end = value++;
callbacks[nytp_attribute](state, nytp_attribute, buffer,
(unsigned long)(key_end - buffer),
0, value,
(unsigned long)(end - value), 0);
if (memEQs(buffer, key_end - buffer, "ticks_per_sec")) {
ticks_per_sec = (unsigned int)atoi(value);
}
else if (memEQs(buffer, key_end - buffer, "nv_size")) {
if (sizeof(NV) != atoi(value))
croak("Profile data created by incompatible perl config (NV size %d but ours is %d)",
atoi(value), (int)sizeof(NV));
}
break;
}
case NYTP_TAG_OPTION:
{
char *value, *key_end;
char *end = NYTP_gets(in, &buffer, &buffer_len);
if (NULL == end)
/* probably EOF */
croak("Profile format error reading attribute");
--end; /* end, as returned, points 1 after the \n */
if ((NULL == (value = (char *)memchr(buffer, '=', end - buffer)))) {
logwarn("option malformed '%s'\n", buffer);
continue;
}
key_end = value++;
callbacks[nytp_option](state, nytp_option, buffer,
(unsigned long)(key_end - buffer),
0, value,
(unsigned long)(end - value), 0);
break;
}
case NYTP_TAG_COMMENT:
{
char *end = NYTP_gets(in, &buffer, &buffer_len);
if (!end)
/* probably EOF */
croak("Profile format error reading comment");
if (callbacks[nytp_comment])
callbacks[nytp_comment](state, nytp_comment, buffer,
(unsigned long)(end - buffer), 0);
if (trace_level >= 1)
logwarn("# %s", buffer); /* includes \n */
break;
}
case NYTP_TAG_START_DEFLATE:
{
#ifdef HAS_ZLIB
if (callbacks[nytp_start_deflate]) {
callbacks[nytp_start_deflate](state, nytp_start_deflate);
}
NYTP_start_inflate(in);
#else
croak("File uses compression but compression is not supported by this build of NYTProf");
#endif
break;
}
default:
croak("File format error: token %d ('%c'), chunk %lu, pos %ld%s",
c, c, state->input_chunk_seqn, NYTP_tell(in)-1,
NYTP_type_of_offset(in));
}
}
sv_free(tmp_str1_sv);
sv_free(tmp_str2_sv);
Safefree(buffer);
}
static HV*
load_profile_to_hv(pTHX_ NYTP_file in)
{
Loader_state_profiler state;
HV *profile_hv;
HV *profile_modes;
Zero(&state, 1, Loader_state_profiler);
state.total_stmts_duration = 0.0;
state.profiler_start_time = 0.0;
state.profiler_start_time = 0.0;
state.profiler_end_time = 0.0;
state.profiler_duration = 0.0;
#ifdef MULTIPLICITY
state.interp = my_perl;
#endif
state.fid_line_time_av = newAV();
state.fid_srclines_av = newAV();
state.fid_fileinfo_av = newAV();
state.sub_subinfo_hv = newHV();
state.live_pids_hv = newHV();
state.attr_hv = newHV();
state.option_hv = newHV();
state.file_info_stash = gv_stashpv("Devel::NYTProf::FileInfo", GV_ADDWARN);
av_extend(state.fid_fileinfo_av, 64); /* grow them up front. */
av_extend(state.fid_srclines_av, 64);
av_extend(state.fid_line_time_av, 64);
load_profile_data_from_stream(processing_callbacks,
(Loader_state_base *)&state, in);
if (HvKEYS(state.live_pids_hv)) {
logwarn("Profile data incomplete, no terminator for %"IVdf" pids %s\n",
HvKEYS(state.live_pids_hv),
"(refer to TROUBLESHOOTING in the documentation)");
store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("complete"),
&PL_sv_no);
}
else {
store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("complete"),
&PL_sv_yes);
}
sv_free((SV*)state.live_pids_hv);
if (state.statement_discount) /* discard unused statement_discount */
state.total_stmts_discounted -= state.statement_discount;
store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_stmts_measured"),
newSVnv(state.total_stmts_measured));
store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_stmts_discounted"),
newSVnv(state.total_stmts_discounted));
store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_stmts_duration"),
newSVnv(state.total_stmts_duration));
store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_sub_calls"),
newSVnv(state.total_sub_calls));
if (1) {
int show_summary_stats = (trace_level >= 1);
if (state.profiler_end_time
&& state.total_stmts_duration > state.profiler_duration * 1.1) {
logwarn("The sum of the statement timings is %.1"NVff"%% of the total time profiling."
" (Values slightly over 100%% can be due simply to cumulative timing errors,"
" whereas larger values can indicate a problem with the clock used.)\n",
state.total_stmts_duration / state.profiler_duration * 100);
show_summary_stats = 1;
}
if (show_summary_stats)
logwarn("Summary: statements profiled %lu (=%lu-%lu), sum of time %"NVff"s, profile spanned %"NVff"s\n",
(unsigned long)(state.total_stmts_measured - state.total_stmts_discounted),
(unsigned long)state.total_stmts_measured, (unsigned long)state.total_stmts_discounted,
state.total_stmts_duration,
state.profiler_end_time - state.profiler_start_time);
}
profile_hv = newHV();
profile_modes = newHV();
(void)hv_stores(profile_hv, "attribute",
newRV_noinc((SV*)state.attr_hv));
(void)hv_stores(profile_hv, "option",
newRV_noinc((SV*)state.option_hv));
(void)hv_stores(profile_hv, "fid_fileinfo",
newRV_noinc((SV*)state.fid_fileinfo_av));
(void)hv_stores(profile_hv, "fid_srclines",
newRV_noinc((SV*)state.fid_srclines_av));
(void)hv_stores(profile_hv, "fid_line_time",
newRV_noinc((SV*)state.fid_line_time_av));
(void)hv_stores(profile_modes, "fid_line_time", newSVpvs("line"));
if (state.fid_block_time_av) {
(void)hv_stores(profile_hv, "fid_block_time",
newRV_noinc((SV*)state.fid_block_time_av));
(void)hv_stores(profile_modes, "fid_block_time", newSVpvs("block"));
}
if (state.fid_sub_time_av) {
(void)hv_stores(profile_hv, "fid_sub_time",
newRV_noinc((SV*)state.fid_sub_time_av));
(void)hv_stores(profile_modes, "fid_sub_time", newSVpvs("sub"));
}
(void)hv_stores(profile_hv, "sub_subinfo",
newRV_noinc((SV*)state.sub_subinfo_hv));
(void)hv_stores(profile_hv, "profile_modes",
newRV_noinc((SV*)profile_modes));
return profile_hv;
}
static void
load_profile_to_callback(pTHX_ NYTP_file in, SV *cb)
{
Loader_state_callback state;
int i;
HV *cb_hv = NULL;
CV *default_cb = NULL;
if (SvTYPE(cb) == SVt_PVHV) {
/* A default callback is stored with an empty key. */
SV **svp;
cb_hv = (HV *)cb;
svp = hv_fetch(cb_hv, "", 0, 0);
if (svp) {
if (!SvROK(*svp) && SvTYPE(SvRV(*svp)) != SVt_PVCV)
croak("Default callback is not a CODE reference");
default_cb = (CV *)SvRV(*svp);
}
} else if (SvTYPE(cb) == SVt_PVCV) {
default_cb = (CV *) cb;
} else
croak("Not a CODE or HASH reference");
#ifdef MULTIPLICITY
state.interp = my_perl;
#endif
state.base_state.input_chunk_seqn = 0;
state.input_chunk_seqn_sv = save_scalar(gv_fetchpv(".", GV_ADD, SVt_IV));
i = C_ARRAY_LENGTH(state.tag_names);
while (--i) {
if (callback_info[i].args) {
state.tag_names[i]
= newSVpvn_flags(callback_info[i].description,
callback_info[i].len, SVs_TEMP);
SvREADONLY_on(state.tag_names[i]);
/* Don't steal the string buffer. */
SvTEMP_off(state.tag_names[i]);
} else
state.tag_names[i] = NULL;
if (cb_hv) {
SV **svp = hv_fetch(cb_hv, callback_info[i].description,
(I32)(callback_info[i].len), 0);
if (svp) {
if (!SvROK(*svp) && SvTYPE(SvRV(*svp)) != SVt_PVCV)
croak("Callback for %s is not a CODE reference",
callback_info[i].description);
state.cb[i] = (CV *)SvRV(*svp);
} else
state.cb[i] = default_cb;
} else
state.cb[i] = default_cb;
}
for (i = 0; i < C_ARRAY_LENGTH(state.cb_args); i++)
state.cb_args[i] = sv_newmortal();
load_profile_data_from_stream(perl_callbacks, (Loader_state_base *)&state,
in);
}
struct int_constants_t {
const char *name;
int value;
};
static struct int_constants_t int_constants[] = {
/* NYTP_FIDf_* */
{"NYTP_FIDf_IS_PMC", NYTP_FIDf_IS_PMC},
{"NYTP_FIDf_VIA_STMT", NYTP_FIDf_VIA_STMT},
{"NYTP_FIDf_VIA_SUB", NYTP_FIDf_VIA_SUB},
{"NYTP_FIDf_IS_AUTOSPLIT", NYTP_FIDf_IS_AUTOSPLIT},
{"NYTP_FIDf_HAS_SRC", NYTP_FIDf_HAS_SRC},
{"NYTP_FIDf_SAVE_SRC", NYTP_FIDf_SAVE_SRC},
{"NYTP_FIDf_IS_ALIAS", NYTP_FIDf_IS_ALIAS},
{"NYTP_FIDf_IS_FAKE", NYTP_FIDf_IS_FAKE},
{"NYTP_FIDf_IS_EVAL", NYTP_FIDf_IS_EVAL},
/* NYTP_FIDi_* */
{"NYTP_FIDi_FILENAME", NYTP_FIDi_FILENAME},
{"NYTP_FIDi_EVAL_FID", NYTP_FIDi_EVAL_FID},
{"NYTP_FIDi_EVAL_LINE", NYTP_FIDi_EVAL_LINE},
{"NYTP_FIDi_FID", NYTP_FIDi_FID},
{"NYTP_FIDi_FLAGS", NYTP_FIDi_FLAGS},
{"NYTP_FIDi_FILESIZE", NYTP_FIDi_FILESIZE},
{"NYTP_FIDi_FILEMTIME", NYTP_FIDi_FILEMTIME},
{"NYTP_FIDi_PROFILE", NYTP_FIDi_PROFILE},
{"NYTP_FIDi_EVAL_FI", NYTP_FIDi_EVAL_FI},
{"NYTP_FIDi_HAS_EVALS", NYTP_FIDi_HAS_EVALS},
{"NYTP_FIDi_SUBS_DEFINED", NYTP_FIDi_SUBS_DEFINED},
{"NYTP_FIDi_SUBS_CALLED", NYTP_FIDi_SUBS_CALLED},
{"NYTP_FIDi_elements", NYTP_FIDi_elements},
/* NYTP_SIi_* */
{"NYTP_SIi_FID", NYTP_SIi_FID},
{"NYTP_SIi_FIRST_LINE", NYTP_SIi_FIRST_LINE},
{"NYTP_SIi_LAST_LINE", NYTP_SIi_LAST_LINE},
{"NYTP_SIi_CALL_COUNT", NYTP_SIi_CALL_COUNT},
{"NYTP_SIi_INCL_RTIME", NYTP_SIi_INCL_RTIME},
{"NYTP_SIi_EXCL_RTIME", NYTP_SIi_EXCL_RTIME},
{"NYTP_SIi_SUB_NAME", NYTP_SIi_SUB_NAME},
{"NYTP_SIi_PROFILE", NYTP_SIi_PROFILE},
{"NYTP_SIi_REC_DEPTH", NYTP_SIi_REC_DEPTH},
{"NYTP_SIi_RECI_RTIME", NYTP_SIi_RECI_RTIME},
{"NYTP_SIi_CALLED_BY", NYTP_SIi_CALLED_BY},
{"NYTP_SIi_elements", NYTP_SIi_elements},
/* NYTP_SCi_* */
{"NYTP_SCi_CALL_COUNT", NYTP_SCi_CALL_COUNT},
{"NYTP_SCi_INCL_RTIME", NYTP_SCi_INCL_RTIME},
{"NYTP_SCi_EXCL_RTIME", NYTP_SCi_EXCL_RTIME},
{"NYTP_SCi_INCL_TICKS", NYTP_SCi_INCL_TICKS},
{"NYTP_SCi_EXCL_TICKS", NYTP_SCi_EXCL_TICKS},
{"NYTP_SCi_RECI_RTIME", NYTP_SCi_RECI_RTIME},
{"NYTP_SCi_REC_DEPTH", NYTP_SCi_REC_DEPTH},
{"NYTP_SCi_CALLING_SUB", NYTP_SCi_CALLING_SUB},
{"NYTP_SCi_elements", NYTP_SCi_elements},
/* others */
{"NYTP_DEFAULT_COMPRESSION", default_compression_level},
{"NYTP_FILE_MAJOR_VERSION", NYTP_FILE_MAJOR_VERSION},
{"NYTP_FILE_MINOR_VERSION", NYTP_FILE_MINOR_VERSION},
};
/***********************************
* Perl XS Code Below Here *
***********************************/
MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Constants
PROTOTYPES: DISABLE
BOOT:
{
HV *stash = gv_stashpv("Devel::NYTProf::Constants", GV_ADDWARN);
struct int_constants_t *constant = int_constants;
const struct int_constants_t *end = constant + C_ARRAY_LENGTH(int_constants);
do {
/* 5.8.x and earlier don't declare newCONSTSUB() as const char *, even
though it is. */
newCONSTSUB(stash, (char *) constant->name, newSViv(constant->value));
} while (++constant < end);
newCONSTSUB(stash, "NYTP_ZLIB_VERSION", newSVpv(ZLIB_VERSION, 0));
}
MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Util
PROTOTYPES: DISABLE
void
trace_level()
PPCODE:
XSRETURN_IV(trace_level);
MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Test
PROTOTYPES: DISABLE
void
example_xsub(const char *unused="", SV *action=Nullsv, SV *arg=Nullsv)
CODE:
if (!action)
XSRETURN(0);
if (SvROK(action) && SvTYPE(SvRV(action))==SVt_PVCV) {
/* perl <= 5.8.8 doesn't use OP_ENTERSUB so won't be seen by NYTProf */
PUSHMARK(SP);
call_sv(action, G_VOID|G_DISCARD);
}
else if (strEQ(SvPV_nolen(action),"eval"))
eval_pv(SvPV_nolen(arg), TRUE);
else if (strEQ(SvPV_nolen(action),"die"))
croak("example_xsub(die)");
logwarn("example_xsub: unknown action '%s'\n", SvPV_nolen(action));
void
example_xsub_eval(...)
CODE:
PERL_UNUSED_VAR(items);
/* to enable testing of string evals in embedded environments
* where there's no caller file information available.
* Only it doesn't actually do that because perl knows
* what it's executing at the time eval_pv() gets called.
* We need a better test, closer to true embedded.
*/
eval_pv("Devel::NYTProf::Test::example_xsub()", 1);
void
set_errno(int e)
CODE:
SETERRNO(e, 0);
void
ticks_for_usleep(long u_seconds)
PPCODE:
NV elapsed = -1;
NV overflow = -1;
#ifdef HAS_SELECT
time_of_day_t s_time;
time_of_day_t e_time;
struct timeval timebuf;
timebuf.tv_sec = (long)(u_seconds / 1000000);
timebuf.tv_usec = u_seconds - (timebuf.tv_sec * 1000000);
if (!last_pid)
_init_profiler_clock(aTHX);
get_time_of_day(s_time);
PerlSock_select(0, 0, 0, 0, &timebuf);
get_time_of_day(e_time);
get_ticks_between(NV, s_time, e_time, elapsed, overflow);
#else
PERL_UNUSED_VAR(u_seconds);
#endif
EXTEND(SP, 4);
PUSHs(sv_2mortal(newSVnv(elapsed)));
PUSHs(sv_2mortal(newSVnv(overflow)));
PUSHs(sv_2mortal(newSVnv(ticks_per_sec)));
PUSHs(sv_2mortal(newSViv(profile_clock)));
MODULE = Devel::NYTProf PACKAGE = DB
PROTOTYPES: DISABLE
void
DB_profiler(...)
CODE:
/* this sub gets aliased as "DB::DB" by NYTProf.pm if use_db_sub is true */
PERL_UNUSED_VAR(items);
if (opt_use_db_sub)
DB_stmt(aTHX_ NULL, PL_op);
else
logwarn("DB::DB called unexpectedly\n");
void
set_option(const char *opt, const char *value)
C_ARGS:
aTHX_ opt, value
int
init_profiler()
C_ARGS:
aTHX
int
enable_profile(char *file = NULL)
C_ARGS:
aTHX_ file
POSTCALL:
/* if profiler was previously disabled */
/* then arrange for the enable_profile call to be noted */
if (!RETVAL) {
DB_stmt(aTHX_ PL_curcop, PL_op);
}
int
disable_profile()
C_ARGS:
aTHX
void
finish_profile(...)
ALIAS:
_finish = 1
C_ARGS:
aTHX
INIT:
PERL_UNUSED_ARG(ix);
PERL_UNUSED_ARG(items);
void
_INIT()
CODE:
if (profile_start == NYTP_START_INIT) {
enable_profile(aTHX_ NULL);
}
else if (profile_start == NYTP_START_END) {
SV *enable_profile_sv = (SV *)get_cv("DB::enable_profile", GV_ADDWARN);
if (trace_level >= 1)
logwarn("~ enable_profile deferred until END\n");
if (!PL_endav)
PL_endav = newAV();
av_unshift(PL_endav, 1); /* we want to be first */
av_store(PL_endav, 0, SvREFCNT_inc(enable_profile_sv));
}
av_extend(PL_endav, av_len(PL_endav)+20); /* see PL_endav in init_profiler() */
if (trace_level >= 1)
logwarn("~ INIT done\n");
void
_END()
ALIAS:
_CHECK = 1
CODE:
/* we want to END { finish_profile() } but we want it to be the last END
* block run, so we don't push it into PL_endav until END phase has started,
* so it's likely to be the last thing run. Do this once, else we could end
* up in an infinite loop arms race with something else trying the same
* strategy.
*/
CV *finish_profile_cv = get_cv("DB::finish_profile", GV_ADDWARN);
if (1) { /* defer */
if (!PL_checkav) PL_checkav = newAV();
if (!PL_endav) PL_endav = newAV();
av_push((ix == 1 ? PL_checkav : PL_endav), SvREFCNT_inc(finish_profile_cv));
}
else { /* immediate */
call_sv((SV *)finish_profile_cv, G_VOID);
}
if (trace_level >= 1)
logwarn("~ %s done\n", ix == 1 ? "CHECK" : "END");
MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Data
PROTOTYPES: DISABLE
HV*
load_profile_data_from_file(file,cb=NULL)
char *file;
SV* cb;
PREINIT:
int result;
NYTP_file in;
CODE:
if (trace_level)
logwarn("reading profile data from file %s\n", file);
in = NYTP_open(file, "rb");
if (in == NULL) {
croak("Failed to open input '%s': %s", file, strerror(errno));
}
if (cb && SvROK(cb)) {
load_profile_to_callback(aTHX_ in, SvRV(cb));
RETVAL = (HV*) &PL_sv_undef;
}
else {
RETVAL = load_profile_to_hv(aTHX_ in);
}
if ((result = NYTP_close(in, 0)))
logwarn("Error closing profile data file: %s\n", strerror(result));
OUTPUT:
RETVAL