Skip to content

Commit

Permalink
fix remaining cperl tests
Browse files Browse the repository at this point in the history 
workaround cperl not storing main:: prefixes
in %DBsub keys. add it manually for perl5 compat.

add . to @inc in core to be able to expand the test filenames.

use alloca() for the first time in cperl (cperl only though)

silence hashiter warning since v5.29.1c:
  "Attempt to change hash while iterating over it" in SubInfo
   while (each %$cb) { delete $cb->{$line} }

skipped tests with cperl5.28:
t/42-global.t        (Wstat: 8192 Tests: 289 Failed: 32)
t/70-subname.t       (Wstat: 4096 Tests: 57 Failed: 16)
t/test40pmc.t        (Wstat: 4096 Tests: 113 Failed: 16)
t/test50-disable.t   (Wstat: 7168 Tests: 113 Failed: 28)
t/test51-enable.t    (Wstat: 19456 Tests: 161 Failed: 76)
t/test60-subname.t   (Wstat: 7168 Tests: 65 Failed: 28)
t/test62-subcaller1.t (Wstat: 7168 Tests: 65 Failed: 28)
  • Loading branch information
@rurban
rurban committed Jun 15, 2019
1 parent 24f0ccc commit 1ae676a
Show file tree
Hide file tree
Showing 14 changed files with 164 additions and 60 deletions.
2 changes: 1 addition & 1 deletion NYTProf.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,5 +19,5 @@
#ifndef strEQc
#define strEQc(s,c) memEQ(s, ("" c ""), sizeof(c))
#define strNEc(s,c) memNE(s, ("" c ""), sizeof(c))
#define memNEc(s,c) memNE(s, ("" c ""), sizeof(c)-1)
#endif

113 changes: 94 additions & 19 deletions NYTProf.xs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -115,6 +115,21 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, cons
#endif
#include <stdio.h>

#ifdef USE_CPERL
# ifdef WIN32
# define HAVE_ALLOCA
# include <malloc.h>
# define alloca _alloca
# elif defined(__linux__) || defined(__APPLE__)
# define HAVE_ALLOCA
# include <alloca.h>
# elif defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) \
defined(__bsdi__) || defined(__DragonFly__)
/* in stdlib.h */
# define HAVE_ALLOCA
# endif
#endif

#ifdef HAS_ZLIB
#include <zlib.h>
#define default_compression_level 6
Expand Down Expand Up @@ -496,7 +511,7 @@ 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_subcall_profiler(pTHX_ int is_slowop);
static OP *pp_leave_profiler(pTHX);
static HV *sub_callers_hv;
static HV *pkg_fids_hv; /* currently just package names */
Expand Down Expand Up @@ -1157,10 +1172,10 @@ get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
) {
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.
*/
* 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));
Expand Down Expand Up @@ -1223,7 +1238,7 @@ get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
if (trace_level >= 2) {
char buf[80];
/* including last_executed_fid can be handy for tracking down how
* a file got loaded */
* 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,
Expand Down Expand Up @@ -2060,7 +2075,7 @@ append_linenum_to_begin(pTHX_ subr_entry_t *subr_entry) {

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);
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);
Expand Down Expand Up @@ -2117,9 +2132,13 @@ subr_entry_destroy(pTHX_ subr_entry_t *subr_entry)
}
if (subr_entry->prev_subr_entry_ix <= subr_entry_ix)
subr_entry_ix = subr_entry->prev_subr_entry_ix;
else
else {
#ifdef USE_CPERL
if (trace_level)
#endif
logwarn("skipped attempt to raise subr_entry_ix from %d to %d\n",
(int)subr_entry_ix, (int)subr_entry->prev_subr_entry_ix);
(int)subr_entry_ix, (int)subr_entry->prev_subr_entry_ix);
}
}


Expand Down Expand Up @@ -2707,8 +2726,7 @@ pp_subcall_profiler(pTHX_ int is_slowop)
/* 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
: PL_op->op_type
? PL_op->op_type : OP_ENTERSUB;
: PL_op->op_type ? (opcode) PL_op->op_type : OP_ENTERSUB;

CV *called_cv;
dSP;
Expand Down Expand Up @@ -3333,9 +3351,9 @@ init_profiler(pTHX)
PL_ppaddr[OP_ENTERSUB] = pp_entersub_profiler;
#ifdef USE_CPERL /* since cperl-5.22.1 */
PL_ppaddr[OP_ENTERXSSUB] = pp_entersub_profiler;
/* TODO: cperl-5.29?
# if PERL_VERSION_GE(5,29,0)
PL_ppaddr[OP_ENTERFFI] = pp_entersub_profiler;
*/
# endif
#endif
PL_ppaddr[OP_GOTO] = pp_entersub_profiler;

Expand Down Expand Up @@ -3453,8 +3471,17 @@ 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 */
if (!pkg_len) {
#ifdef USE_CPERL
/* cperl doesn't store the main:: prefix in PL_DBsub hash keys */
svp = hv_fetch(pkg_fids_hv, "main", 4, 0);
if (!svp)
return Nullsv;
return *svp;
#else
return Nullsv; /* no :: delimiter */
#endif
}
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 */
Expand Down Expand Up @@ -3526,6 +3553,8 @@ write_sub_line_ranges(pTHX)
STRLEN filename_len;
SV *pkg_filename_sv;

/* Note: cperl doesn't store main:: prefixes in the PL_DBsub */

/* 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
Expand All @@ -3551,8 +3580,34 @@ write_sub_line_ranges(pTHX)
/* 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 */
if (!pkg_filename_sv) { /* we don't know package */
if (trace_level >= 4)
logwarn("Sub %.*s has no known package (%s) - ignored\n",
(int)sub_name_len, sub_name, filename);
continue;
}

/* cperl sub without main:: prefix */
#ifdef USE_CPERL
if (!pkg_name_len(aTHX_ sub_name, sub_name_len)) {
/* Note that even __ANON__ gets stuffed into main:: */
char *tmp_sub;
# ifdef HAVE_ALLOCA
if (sub_name_len < 4096)
tmp_sub = (char*)alloca(sub_name_len + 7);
else
# endif
/* let it leak for now */
tmp_sub = (char*)safemalloc(sub_name_len + 7);
strcpy(tmp_sub, "main::");
strcat(tmp_sub, sub_name);
sub_name = tmp_sub;
sub_name_len += 6;
if (trace_level >= 8)
logwarn("cperl sub %.*s got main:: added (%s)\n",
(int)sub_name_len, sub_name, filename);
}
#endif

/* already got a cached filename for this package XXX should allow multiple */
if (SvOK(pkg_filename_sv)) {
Expand Down Expand Up @@ -3643,6 +3698,26 @@ write_sub_line_ranges(pTHX)
STRLEN filename_len;
UV first_line, last_line;

#ifdef USE_CPERL
if (!pkg_name_len(aTHX_ sub_name, sub_name_len)) {
char *tmp_sub;
# ifdef HAVE_ALLOCA
if (sub_name_len < 4096)
tmp_sub = (char*)alloca(sub_name_len + 7);
else
# endif
/* let it leak for now */
tmp_sub = (char*)safemalloc(sub_name_len + 7);
strcpy(tmp_sub, "main::");
strcat(tmp_sub, sub_name);
sub_name = tmp_sub;
sub_name_len += 6;
if (trace_level >= 8)
logwarn("cperl sub %.*s got main:: added (%s)\n",
(int)sub_name_len, sub_name, filename);
}
#endif

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;
Expand All @@ -3653,9 +3728,9 @@ write_sub_line_ranges(pTHX)
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);
if (trace_level >= 2)
logwarn("Sub %s is xsub, we'll associate it with filename %.*s\n",
sub_name, (int)filename_len, filename);
}
}

Expand Down
5 changes: 1 addition & 4 deletions lib/Devel/NYTProf/Data.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,10 +53,7 @@ use Scalar::Util qw(blessed);
use Devel::NYTProf::Core;
use Devel::NYTProf::FileInfo;
use Devel::NYTProf::SubInfo;
use Devel::NYTProf::Util qw(
make_path_strip_editor strip_prefix_from_paths get_abs_paths_alternation_regex
trace_level
);
use Devel::NYTProf::Util qw( trace_level );

our $VERSION = '4.02';

Expand Down
4 changes: 4 additions & 0 deletions lib/Devel/NYTProf/FileInfo.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -437,6 +437,10 @@ sub filename_without_inc {
strip_prefix_from_paths([$self->profile->inc], $f,
qr/(?: ^ | \[ | \sdefined\sat\s )/x
);
#if ($f->[0] =~ /^\//) {
# warn "filename_without_inc: $f->[0], " .
# "INC=", join(":", $self->profile->inc);
#}
return $f->[0];
}

Expand Down
3 changes: 1 addition & 2 deletions lib/Devel/NYTProf/SubInfo.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -184,11 +184,10 @@ sub _alter_called_by_fileinfo {
# merge $cb into $new_cb
while ( my ($line, $cb_li) = each %$cb ) {
my $dst_line_info = $new_cb->{$line} ||= [];
_merge_in_caller_info($dst_line_info, delete $cb->{$line},
_merge_in_caller_info($dst_line_info, $cb->{$line},
tag => "$line:".$self->subname,
);
}

}
}

Expand Down
21 changes: 13 additions & 8 deletions t/22-readstream.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,12 +10,13 @@ use NYTProfTest;
use Devel::NYTProf::ReadStream qw(for_chunks);

my $pre589 = ($] < 5.008009 or $] eq "5.010000");
my $cperl = $^V =~ /c$/;

(my $base = __FILE__) =~ s/\.t$//;

# generate an nytprof out file
my $out = 'nytprof_readstream.out';
$ENV{NYTPROF} = "calls=2:blocks=1:file=$out";
$ENV{NYTPROF} = "calls=2:blocks=1:file=$out:compress=0";
unlink $out;

run_perl_command(qq{-d:NYTProf -e "sub A { };" -e "1;" -e "A() $Devel::NYTProf::StrEvalTestPad"});
Expand Down Expand Up @@ -48,7 +49,7 @@ is_deeply(\@seqn, [0..@seqn-1], "chunk seq");

#use Data::Dumper; warn Dumper \%prof;

is_deeply $prof{VERSION}, [ [ 5, 0 ] ];
is_deeply $prof{VERSION}, [ [ 5, 0 ] ], 'VERSION';

# check for expected tags
# but not START_DEFLATE as that'll be missing if there's no zlib
Expand Down Expand Up @@ -81,15 +82,12 @@ cmp_ok $attr{basetime}, '>=', $^T, 'basetime';
my @sub_info_sorted = sort { $a->[3] cmp $b->[3] } @{$prof{SUB_INFO}};
#diag Dumper( $prof{SUB_INFO} );
is_deeply \@sub_info_sorted, [
$^V =~ /c$/ ? (
[1, 1, 1, "A"],
[1, 0, 0, "BEGIN"],
) : (
(
[1, 1, 1, "main::A"],
[1, 0, 0, "main::BEGIN"],
[1, 1, 1, "main::RUNTIME"],
)
];
], 'SUB_INFO sorted args';

#diag 'SUB_CALLERS: ',Dumper( $prof{SUB_CALLERS} );
if ($prof{SUB_CALLERS}->[2]) { # skip the ANON import@ caller
Expand All @@ -100,7 +98,7 @@ $prof{SUB_CALLERS}[0][$_] = 0 for (3,4);
#diag 'filtered SUB_CALLERS: ',Dumper( $prof{SUB_CALLERS} );
is_deeply $prof{SUB_CALLERS}, [
[ 1, 3, 1, 0, 0, '0', 0, 'main::A', 'main::RUNTIME' ]
];
], 'SUB_CALLERS args';

#diag 'SUB_ENTRY: ',Dumper( $prof{SUB_ENTRY} );
if ($prof{SUB_ENTRY}[1]) { # skip the ANON import@ entries
Expand All @@ -116,4 +114,11 @@ if ($prof{SUB_RETURN}->[1]) { # skip the ANON import@ call
$prof{SUB_RETURN}[0][$_] = 0 for (1,2);
is_deeply $prof{SUB_RETURN}, [ [ 1, 0, 0, 'main::A' ] ], 'SUB_RETURN args';

# fid_flags 308 0x134 (first seen VIA_STMT for perl5, VIA_SUB for cperl)
my $fid_flags = $prof{NEW_FID}[0][3] | ($cperl ? 4 : 2);
is_deeply $prof{NEW_FID}, [
# fid, file_num, eval_file_num, fid_flags, file_size, file_mtime, filename
[ 1, 0, 0, $fid_flags, 0, 0, '-e' ]
], 'NEW_FID args';

done_testing();
Loading

0 comments on commit 1ae676a

Please sign in to comment.