Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'master' of github.com:rurban/perl-compiler

  • Loading branch information...
commit 937c43d219db662bcc1d41d3f581f585847ab05e 2 parents 03f0d02 + deb074e
@rurban authored
View
10 ByteLoader/bytecode.h
@@ -313,15 +313,9 @@ static int bget_swab = 0;
SV * const repointer = &PL_sv_undef; \
av_push(PL_regex_padav, repointer); \
cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \
+ PL_regex_pad = AvARRAY(PL_regex_padav); \
PM_SETRE(cPMOPx(o), \
CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags)); \
- PL_regex_pad = AvARRAY(PL_regex_padav); \
- if (SvCUR(PL_regex_pad[0])) { \
- SV * const repointer = PL_regex_pad[0]; \
- if (SvCUR(repointer) % sizeof(IV)) { \
- SvCUR_set(repointer, SvEND(repointer)); \
- } \
- } \
} \
} STMT_END
#endif
@@ -329,7 +323,7 @@ static int bget_swab = 0;
/* see op.c:newPMOP
* Must use a SV now. build it on the fly from the given pv.
* TODO: 5.11 could use newSVpvn_flags with SVf_TEMP
- * PM_SETRE adjust no PL_regex_pad, so repoint manually.
+ * PM_SETRE does not adjust PL_regex_pad, so repoint manually.
*/
#define BSET_pregcomp(o, arg) \
STMT_START { \
View
39 lib/B/C.pm
@@ -262,7 +262,7 @@ my %all_bc_pkg = map {$_=>1} qw(B B::AV B::BINOP B::BM B::COP B::CV B::FAKEOP
warnings warnings::register DB next maybe maybe::next FileHandle fields
AutoLoader Carp Symbol PerlIO PerlIO::scalar SelectSaver ExtUtils
ExtUtils::Constant ExtUtils::Constant::ProxySubs threads base IO::File
- IO::Seekable IO::Handle IO DynaLoader XSLoader O );
+ IO::Seekable IO::Handle IO DynaLoader XSLoader O);
# Note: BEGIN-time sideffect-only packages like strict, vars or constant even
# without functions should not be deleted, so they are not listed here.
@@ -880,10 +880,14 @@ sub force_dynpackage {
my $pv = shift;
no strict 'refs';
if (!$skip_package{$pv} and $pv !~ /^B::/) { # XXX only loaded at run-time
- if (!$INC{packname_inc($pv)}) {
+ if (!$INC{inc_packname($pv)}) {
eval "require $pv;";
if (!$@) {
- warn "load \"$pv\"\n" if $debug{meth};
+ if (!$INC{inc_packname($pv)}) {
+ warn "Warning: Problem with require \"$pv\" - !\$INC{".inc_packname($pv)."}\n";
+ } else {
+ warn "load \"$pv\"\n" if $debug{meth};
+ }
}
}
mark_package($pv);
@@ -1693,18 +1697,22 @@ sub B::PMOP::save {
}
}
+ my $pmop_pmoffset = $ITHREADS # for >5.10thr (regex_padav) start with 1
+ ? ($] > 5.010 ? $pmopsect->index + 2 : $op->pmoffset)
+ : 0; # NULL op_pmregexp pointer
+
# pmnext handling is broken in perl itself, we think. Bad op_pmnext
# fields aren't noticed in perl's runtime (unless you try reset) but we
# segfault when trying to dereference it to find op->op_pmnext->op_type
if ($PERL510) {
$pmopsect->comment(
- "$opsect_common, first, last, pmoffset, pmflags, pmreplroot, pmreplstart"
+ "$opsect_common, first, last, pmoffset/pmregexp, pmflags, pmreplroot, pmreplstart"
);
$pmopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x, %u, 0x%x, {%s}, {%s}",
$op->_save_common, ${ $op->first },
- ${ $op->last }, ( $ITHREADS ? $op->pmoffset : 0 ),
+ ${ $op->last }, $pmop_pmoffset,
$op->pmflags, $replrootfield,
$replstartfield
)
@@ -1727,14 +1735,14 @@ sub B::PMOP::save {
);
} else { # perl5.8.x
$pmopsect->comment(
-"$opsect_common, first, last, pmreplroot, pmreplstart, pmoffset, pmflags, pmpermflags, pmdynflags, pmstash"
+"$opsect_common, first, last, pmreplroot, pmreplstart, pmoffset/pmregexp, pmflags, pmpermflags, pmdynflags, pmstash"
);
$pmopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x, %s",
$op->_save_common, ${ $op->first },
${ $op->last }, $replrootfield,
- $replstartfield, $ITHREADS ? $op->pmoffset : 0,
+ $replstartfield, $pmop_pmoffset,
$op->pmflags, $op->pmpermflags,
$op->pmdynflags, $ITHREADS ? cstring($op->pmstashpv) : "0"
)
@@ -1762,6 +1770,15 @@ sub B::PMOP::save {
require "utf8_heavy.pl"; # bypass AUTOLOAD
svref_2object( \&{"utf8\::SWASHNEW"} )->save; # for swash_init(), defined in lib/utf8_heavy.pl
}
+ if ($] >= 5.011 and $ITHREADS) {
+ my $pad_len = regex_padav->FILL; # already allocated
+ if (($pmopsect->index + 1) > $pad_len) {
+ $init->add("av_push(PL_regex_padav, &PL_sv_undef);",
+ "$pm.op_pmoffset = av_len(PL_regex_padav);",
+ "PL_regex_pad = AvARRAY(PL_regex_padav);"
+ );
+ }
+ }
$init->add( # XXX Modification of a read-only value attempted. use DateTime - threaded
"PM_SETRE(&$pm, CALLREGCOMP(newSVpvn($resym, $relen), ".sprintf("0x%x));", $pmflags),
sprintf("RX_EXTFLAGS(PM_GETRE(&$pm)) = 0x%x;", $op->reflags )
@@ -3178,6 +3195,8 @@ sub B::CV::save {
ivx($cv->OUTSIDE_SEQ),
($$gv and $CvFLAGS & 0x400) ? 0 : $CvFLAGS, # no CVf_CVGV_RC otherwise we cannot set the GV
$cv->DEPTH);
+ # repro only with 5.15.* threaded -q (70c0620) Encode::Alias::define_alias
+ warn "lexwarnsym in XPVCV OUTSIDE: $xpvc" if $xpvc =~ /, \(CV\*\)iv\d/; # t/testc.sh -q -O3 227
if (!$new_cv_fw) {
$symsect->add("XPVCVIX$xpvcv_ix\t$xpvc");
#$symsect->add
@@ -5127,11 +5146,7 @@ EOT
print <<"EOT";
if ((tmpgv = gv_fetchpv("\030", TRUE, SVt_PV))) {/* $^X */
tmpsv = GvSVn(tmpgv);
-#ifdef WIN32
- sv_setpv(tmpsv,"perl.exe");
-#else
- sv_setpv(tmpsv,"perl");
-#endif
+ sv_setpv(tmpsv,"$^X");
SvSETMAGIC(tmpsv);
}
View
4 log.modules-5.015009d-nt
@@ -1,4 +1,4 @@
-# B::C::VERSION = 1.42_07 78397f2 2012-04-17 | t/issue97.t added
+# B::C::VERSION = 1.43 9e1d1e4 2012-04-19 | Fixed regex_pad offset in threaded perls >= 5.11, issue 68
# perlversion = 5.015009d-nt
# path = /usr/local/bin/perl5.15.9d-nt-32
# platform = linux 32bit non-threaded debug
@@ -101,7 +101,7 @@ pass IO::String
pass AppConfig
pass UNIVERSAL::require
pass Template::Stash
-# 99 / 99 modules tested with B-C-1.42_07 - perl-5.015009d-nt
+# 99 / 99 modules tested with B-C-1.43 - perl-5.015009d-nt
# pass 99 / 99 (100.0%)
# fail 0 / 99 (0.0%)
# todo 1 / 0 ()
View
135 script/perlcc.PL
@@ -108,15 +108,15 @@ sub main {
sub choose_backend {
# Choose the backend.
$Backend = 'C';
- if (opt(B)) {
+ if (opt('B')) {
checkopts_byte();
$Backend = 'Bytecode';
}
- if (opt(S) && opt(c)) {
+ if (opt('S') && opt('c')) {
# die "$0: Do you want me to compile this or not?\n";
delete $Options->{S};
}
- $Backend = 'CC' if opt(O);
+ $Backend = 'CC' if opt('O');
}
sub generate_code {
@@ -145,7 +145,7 @@ sub run_code {
$Output = "$BinPerl $Output";
}
}
- if (opt(staticxs) and $extra_libs) {
+ if (opt('staticxs') and $extra_libs) {
my $path = '';
my $PATHSEP = $^O eq 'MSWin32' ? ';' : ':';
for (split / /, $extra_libs) {
@@ -266,21 +266,21 @@ sub parse_argv {
$Options->{v} += 0;
- if( opt(t) && opt(T) ) {
+ if( opt('t') && opt('T') ) {
warn "Can't specify both -T and -t, -t ignored";
$Options->{t} = 0;
}
- helpme() if opt(h); # And exit
- if (opt(version)) {
+ helpme() if opt('h'); # And exit
+ if (opt('version')) {
require B::C;
die "perlcc $VERSION, B-C-${B::C::VERSION}\n";
}
- $Options->{Wb} .= ",-O1" if opt(O1);
- $Options->{Wb} .= ",-O2" if opt(O2);
- $Options->{Wb} .= ",-O3" if opt(O3);
- $Options->{Wb} .= ",-O4" if opt(O4);
+ $Options->{Wb} .= ",-O1" if opt('O1');
+ $Options->{Wb} .= ",-O2" if opt('O2');
+ $Options->{Wb} .= ",-O3" if opt('O3');
+ $Options->{Wb} .= ",-O4" if opt('O4');
if( $Options->{time} ) {
eval { require Time::HiRes; }; # 5.6 has no Time::HiRes
@@ -293,13 +293,13 @@ sub parse_argv {
}
$logfh = new FileHandle(">> " . opt('log')) if (opt('log'));
- if (opt(e)) {
+ if (opt('e')) {
warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
# We don't use a temporary file here; why bother?
# XXX: this is not bullet proof -- spaces or quotes in name!
$Input = is_win32() ? # Quotes eaten by shell
- '-e "'.opt(e).'"' :
- "-e '".opt(e)."'";
+ '-e "'.opt('e').'"' :
+ "-e '".opt('e')."'";
} else {
$Input = shift @ARGV; # XXX: more files?
_usage_and_die("No input file specified\n") unless $Input;
@@ -310,10 +310,10 @@ sub parse_argv {
check_perl($Input);
}
- if (opt(o)) {
- $Output = opt(o);
- } elsif (opt(B)) {
- if (opt(e)) {
+ if (opt('o')) {
+ $Output = opt('o');
+ } elsif (opt('B')) {
+ if (opt('e')) {
my $suffix = '.plc';
$suffix = '.pmc' if exists $Options->{m};
(undef, $Output) = tempfile("plcXXXXX", SUFFIX => $suffix);
@@ -350,14 +350,14 @@ sub compile_byte {
if (@_ == 1) {
$opts .= $_[0].",";
}
- my $addoptions = opt(Wb);
+ my $addoptions = opt('Wb');
if( $addoptions ) {
- $opts .= '-v,' if opt(v) > 4;
- $opts .= '-DM,-DG,-DA,-DComment,' if opt(v) > 5;
+ $opts .= '-v,' if opt('v') > 4;
+ $opts .= '-DM,-DG,-DA,-DComment,' if opt('v') > 5;
$opts .= "$addoptions,";
- } elsif (opt(v) > 4) {
+ } elsif (opt('v') > 4) {
$opts .= '-v,';
- $opts .= '-DM,-DG,-DA,-DComment,' if opt(v) > 5;
+ $opts .= '-DM,-DG,-DA,-DComment,' if opt('v') > 5;
}
my $command = "$BinPerl -MO=Bytecode,$opts-o$Output $Input";
$Input =~ s/^-e.*$/-e/;
@@ -373,23 +373,23 @@ sub compile_byte {
_die("$Input did not compile:\n@$error_r\n");
} else {
my @error = grep { !/^$Input syntax OK$/o } @$error_r;
- warn "$0: Unexpected compiler output\n@error" if @error and opt(v)<5;
- warn "@error" if @error and opt(v)>4;
+ warn "$0: Unexpected compiler output\n@error" if @error and opt('v')<5;
+ warn "@error" if @error and opt('v')>4;
}
- unless (opt(dryrun)) {
+ unless (opt('dryrun')) {
chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!\n");
}
}
sub compile_cstyle {
- my $stash = opt(stash) ? grab_stash() : "";
+ my $stash = opt('stash') ? grab_stash() : "";
$stash .= "," if $stash; #stash can be empty
$stash .= "-u$_," for @{$Options->{u}};
$stash .= "-U$_," for @{$Options->{U}};
- my $taint = opt(T) ? ' -T' :
- opt(t) ? ' -t' : '';
+ my $taint = opt('T') ? ' -T' :
+ opt('t') ? ' -t' : '';
# What are we going to call our output C file?
my $lose = 0;
@@ -399,23 +399,23 @@ sub compile_cstyle {
if (@_ == 1) {
$addoptions .= $_[0].",";
}
- $addoptions .= opt(Wb);
+ $addoptions .= opt('Wb');
if( $addoptions ) {
- $addoptions .= ',-Dfull' if opt(v) >= 6;
- $addoptions .= ',-Dsp,-v' if opt(v) == 5;
+ $addoptions .= ',-Dfull' if opt('v') >= 6;
+ $addoptions .= ',-Dsp,-v' if opt('v') == 5;
$addoptions .= ',';
- } elsif (opt(v) > 4) {
+ } elsif (opt('v') > 4) {
$addoptions = '-Dsp,-v,';
- $addoptions = '-Dfull,-v,' if opt(v) >= 6;
+ $addoptions = '-Dfull,-v,' if opt('v') >= 6;
}
- if (opt(f)) {
+ if (opt('f')) {
$addoptions .= "-f$_," for @{$Options->{f}};
}
- my $staticxs = opt(staticxs) ? "-staticxs," : '';
+ my $staticxs = opt('staticxs') ? "-staticxs," : '';
warn "--staticxs on darwin does not work yet\n"
if $staticxs and $^O eq 'darwin';
- if (opt(testsuite)) {
+ if (opt('testsuite')) {
my $bo = join '', @begin_output;
$bo =~ s/\\/\\\\\\\\/gs;
$bo =~ s/\n/\\n/gs;
@@ -426,18 +426,18 @@ sub compile_cstyle {
q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
}
- if (opt(o)) {
- $cfile = opt(o).".c";
- } elsif (opt(S) || opt(c)) { # We need to keep it
- if (opt(e)) {
- $cfile = opt(o) ? opt(o).".c" : "a.out.c";
+ if (opt('o')) {
+ $cfile = opt('o').".c";
+ } elsif (opt('S') || opt('c')) { # We need to keep it
+ if (opt('e')) {
+ $cfile = opt('o') ? opt('o').".c" : "a.out.c";
} else {
$cfile = basename($Input);
# File off extension if present
# hold on: plx is executable; also, careful of ordering!
$cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
$cfile .= ".c";
- $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
+ $cfile = $Output if opt('c') && $Output =~ /\.c\z/i;
}
check_write($cfile);
} else { # Do not keep tempfiles (no -S nor -c nor -o)
@@ -470,8 +470,8 @@ sub compile_cstyle {
} else {
my $i = substr($Input,0,2) eq '-e' ? '-e' : $Input;
@error = grep { !/^$i syntax OK$/o } @error;
- warn "$0: Unexpected compiler output\n@error" if @error and opt(v)<5;
- warn "@error" if @error and opt(v)>4;
+ warn "$0: Unexpected compiler output\n@error" if @error and opt('v')<5;
+ warn "@error" if @error and opt('v')>4;
}
vprint -1, "c time: $elapsed" if opt('time');
$extra_libs = '';
@@ -522,7 +522,7 @@ sub compile_cstyle {
$t0 = [gettimeofday] if opt('time');
is_msvc ?
cc_harness_msvc($cfile, $stash, $extra_libs) :
- cc_harness($cfile, $stash, $extra_libs) unless opt(c);
+ cc_harness($cfile, $stash, $extra_libs) unless opt('c');
$elapsed = tv_interval ( $t0 ) if opt('time');
vprint -1, "cc time: $elapsed" if opt('time');
@@ -540,11 +540,11 @@ sub cc_harness_msvc {
my $link = "-out:$Output $obj";
$compile .= " -DHAVE_INDEPENDENT_COMALLOC" if $B::C::Flags::have_independent_comalloc;
$compile .= $B::C::Flags::extra_cflags;
- $compile .= " -I".$_ for split /\s+/, opt(I);
- $compile .= " -DNO_DYNAMIC_LOADING" if opt(staticxs);
- $compile .= " ".opt(Wc) if opt(Wc);
+ $compile .= " -I".$_ for split /\s+/, opt('I');
+ $compile .= " -DNO_DYNAMIC_LOADING" if opt('staticxs');
+ $compile .= " ".opt('Wc') if opt('Wc');
- $link .= " -libpath:".$_ for split /\s+/, opt(L);
+ $link .= " -libpath:".$_ for split /\s+/, opt('L');
# TODO: -shared,-static,-sharedxs
if ($stash) {
my @mods = split /,?-?u/, $stash; # XXX -U stashes
@@ -557,7 +557,7 @@ sub cc_harness_msvc {
if ($Config{ccversion} eq '12.0.8804') {
$link =~ s/ -opt:ref,icf//;
}
- $link .= " ".opt(Wl) if opt(Wl);
+ $link .= " ".opt('Wl') if opt('Wl');
$link .= $extra_libs;
$link .= " perl5$Config{PERL_VERSION}.lib kernel32.lib msvcrt.lib";
$link .= $B::C::Flags::extra_libs;
@@ -573,14 +573,14 @@ sub cc_harness {
my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
$command .= " -DHAVE_INDEPENDENT_COMALLOC" if $B::C::Flags::have_independent_comalloc;
$command .= $B::C::Flags::extra_cflags if $B::C::Flags::extra_cflags;
- $command .= " -I".$_ for split /\s+/, opt(I);
- $command .= " -L".$_ for split /\s+/, opt(L);
- $command .= " -DNO_DYNAMIC_LOADING" if opt(staticxs);
- $command .= " ".opt(Wc) if opt(Wc);
+ $command .= " -I".$_ for split /\s+/, opt('I');
+ $command .= " -L".$_ for split /\s+/, opt('L');
+ $command .= " -DNO_DYNAMIC_LOADING" if opt('staticxs');
+ $command .= " ".opt('Wc') if opt('Wc');
my $ccflags = $command;
my $useshrplib = $Config{useshrplib};
- _die("--sharedxs with useshrplib=false\n") if !$useshrplib and opt(sharedxs);
+ _die("--sharedxs with useshrplib=false\n") if !$useshrplib and opt('sharedxs');
my $ldopts;
if ($stash) {
my @mods = split /,?-?u/, $stash; # XXX -U stashes
@@ -588,7 +588,7 @@ sub cc_harness {
} else {
$ldopts = ExtUtils::Embed::ldopts("-std");
}
- $ldopts .= " ".opt(Wl) if opt(Wl);
+ $ldopts .= " ".opt('Wl') if opt('Wl');
# gcc crashes with this duplicate -fstack-protector arg
my $ldflags = $Config{ldflags};
@@ -609,7 +609,7 @@ sub cc_harness {
$ldopts = $extra_libs." ".$ldopts;
}
}
- if (opt(shared)) {
+ if (opt('shared')) {
warn "--shared with useshrplib=false might not work\n" unless $useshrplib;
my @plibs = ($libperl, "$coredir/$libperl", "$libdir/$libperl");
if ($libperl !~ /$Config{dlext}$/) {
@@ -629,7 +629,7 @@ sub cc_harness {
last;
}
}
- } elsif (opt(static)) {
+ } elsif (opt('static')) {
for my $lib ($libperl, "$coredir/$libperl", "$coredir/$libperl",
"$coredir/libperl.a", "$libdir/libperl.a") {
if (-e $lib) {
@@ -659,8 +659,8 @@ sub cc_harness {
sub yclept {
my $command = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
# DWIM the -I to be Perl, not C, include directories.
- if (opt(I) && $Backend eq "Bytecode") {
- for (split /\s+/, opt(I)) {
+ if (opt('I') && $Backend eq "Bytecode") {
+ for (split /\s+/, opt('I')) {
if (-d $_) {
push @INC, $_;
} else {
@@ -723,16 +723,17 @@ sub yclept {
# To wit, (-B|-O) ==> no -shared, no -S, no -c
sub checkopts_byte {
- _die("Please choose one of either -B and -O.\n") if opt(O);
+ _die("Please choose one of either -B and -O.\n") if opt('O');
for my $o ( qw[shared sharedxs static staticxs] ) {
- if (opt($o)) {
+ if (exists($Options->{$o}) && $Options->{$o}) {
warn "$0: --$o incompatible with -B\n";
delete $Options->{$o};
}
}
+ # TODO make -S produce an .asm also?
for my $o ( qw[c S] ) {
- if (opt($o)) {
+ if (exists($Options->{$o}) && $Options->{$o}) {
warn "$0: Compiling to bytecode is a one-pass process. ",
"-$o ignored\n";
delete $Options->{$o};
@@ -827,7 +828,7 @@ sub spawnit {
sub helpme {
print "perlcc compiler frontend, version $VERSION\n\n";
- if (opt(v)) {
+ if (opt('v')) {
pod2usage( -verbose => opt('v') );
} else {
pod2usage( -verbose => 0 );
@@ -907,11 +908,11 @@ sub is_win32() { $^O =~ m/^MSWin/ }
sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
END {
- if ($cfile && !opt(S) && !opt(c) && -e $cfile) {
+ if ($cfile && !opt('S') && !opt('c') && -e $cfile) {
vprint 4, "Unlinking $cfile";
unlink $cfile;
}
- if (opt(staticxs) and !opt(S)) {
+ if (opt('staticxs') and !opt('S')) {
vprint 4, "Unlinking $cfile.lst";
unlink "$cfile.lst";
}
View
5 t/issue68.t
@@ -1,6 +1,6 @@
#! /usr/bin/env perl
# http://code.google.com/p/perl-compiler/issues/detail?id=68
-# newPMOP assertion
+# newPMOP assertion >=5.10 threaded
use strict;
my $name = "ccode68i";
use Test::More tests => 1;
@@ -40,7 +40,8 @@ my $result = `$runexe`;
$result =~ s/\n$//;
TODO: {
- local $TODO = "threaded >= 5.010" if $] >= 5.010 and $Config{useithreads};
+ use B::Bytecode;
+ local $TODO = "threaded >= 5.010" if $] >= 5.010 and $Config{useithreads} and $B::Bytecode::VERSION lt "1.14";
ok($result eq $expected, "issue68 - newPMOP assert");
}
View
6 t/testc.sh
@@ -335,8 +335,10 @@ tests[224]='dbmopen(%H,q(f),0644);print q(ok);'
result[224]='ok'
tests[68]='package A;
sub test {
- use Data::Dumper; /^(.*?)\d+$/;
- "Some::Package"->new();}
+ use Data::Dumper ();
+ /^(.*?)\d+$/;
+ "Some::Package"->new();
+}
print "ok"'
result[68]='ok'
# issue71
Please sign in to comment.
Something went wrong with that request. Please try again.