Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

B-C-1.04_08

git-svn-id: http://perl-compiler.googlecode.com/svn/trunk@9 ed534f1a-1453-0410-ab30-dfc593a8b23c
  • Loading branch information...
commit 178a2ce4a0a1952c6facedcf2f2ce566846c54ac 1 parent 534c815
@rurban authored
View
16 Changes
@@ -1,6 +1,20 @@
Started with B-C-1.04_01. The perl compiler was previously in CORE.
TODO: Try to get info about earlier versions.
+1.04_08 2008-02-22 rurban
+ * fixed t/b.t tests for 5.11 (REGEXP, ref RV => IV)
+ * fixed Makefile.PL deps to ignore the interim .pl files
+ * added PMOP reflags
+ * added madprop to B-1.18_01 and B::C (if provided by B)
+ * enhanced B::Debug 1.05_02
+ * fixed B::C PL_cshlen (already initialized since 5.10)
+ * fixed B::C GvFILE
+ * fixed various (SV)xpv list casts and inits,
+ * fixed B::C xpvnv_list for 5.10
+ * fixed B::C xpvio_list for 5.10
+ * fixed B::C pmopsect for 5.11
+ * bootstrap also all $Config{static_ext}, not only dynamic stashes
+
1.04_07 2008-02-20 rurban
* moved bstate->bs_pv.xpv_pv slot to bs_pv.xiv_u.xivu_p1
* fixed pv_free
@@ -13,7 +27,7 @@ TODO: Try to get info about earlier versions.
1.04_06 2008-02-19 rurban
* no crashes anymore for 5.10, just op_pmflags & PMf_ONCE assertions.
* blead@32980 crashes in tests 11,16,17,18
- * enhanced B::Debug
+ * enhanced B::Debug (no version bump)
* fixed general op_list inits, and specials for av, hv
* almost fixed pv within sv handling
* added -O=C,-DS for SV debugging
View
2  META.yml
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: B-C
-version: 1.04_07
+version: 1.04_08
abstract: ~
license: ~
author: ~
View
8 Makefile.PL
@@ -28,9 +28,11 @@ sub headerpath {
package MY;
-#sub libscan {
-# return 0 unless $_[1] =~ /(ByteLoader|\.pm)$/;
-#}
+sub libscan {
+ # ignore temp testing files
+ return 0 if $_[1] =~ /(bytecode\d+\.pl|ccode\d+\..*|-588\.pod)$/;
+ return $_[1];
+}
sub post_constants {
"\nLIBS = $Config::Config{libs}\n"
View
44 lib/B/Bytecode.pm
@@ -572,8 +572,11 @@ sub B::PMOP::bsave {
# 5.9 $op->pmtargetoff?
}
$op->B::BINOP::bsave($ix);
- if (1 or $op->pmstashpv) { # avoid empty stash? if (table) pre-compiled else re-compile
+ if ($op->pmstashpv) { # avoid empty stash? if (table) pre-compiled else re-compile
asm "op_pmstashpv", pvix $op->pmstashpv;
+ } else {
+ bwarn("op_pmstashpv main") if $debug{M};
+ asm "op_pmstashpv", pvix "main";
}
} else {
$rrop = "op_pmreplrootgv";
@@ -595,23 +598,34 @@ sub B::PMOP::bsave {
# asm "op_pmnext", $pmnextix; # XXX
asm "newpv", pvstring $op->precomp;
asm "pregcomp";
- } elsif ( VERSION >= 5.011 ) { # full REGEX type
- $ix = pvix $op->precomp; # fixme
- bwarn("PMOP full REGEX type not yet supported");
- asm "pregcomp", $ix;
+ } elsif ( VERSION >= 5.011 ) { # full REGEXP type
+ bwarn("PMOP full REGEXP type not yet supported");
+ #my $re;
+ if ($op->pmoffset) { # regex_pad is regenerated within pregcomp
+ bwarn("PMOP existing regex_pad not yet supported");
+ asm "op_pmflags", $op->pmflags | 2;
+ } else {
+ asm "op_pmflags", $op->pmflags;
+ }
+ asm "op_pmflags", $op->pmflags | 2;
+ asm "newpv", pvstring $op->precomp;
+ asm "op_reflags", $op->reflags;
+ asm "pregcomp";
} elsif ( VERSION >= 5.009 ) {
- # TODO: not just a pv, use a full sv as pattern (2nd arg)
# asm "newsvx", $sv->FLAGS;
# asm "newsv", pvstring $op->precomp;
- #my $svix = $op->B::SV::ix();
- #$op->B::OP::bsave($ix);
- $ix = pvix $op->precomp; # fixme
- # asm "op_reflags", 2;
- # add flag PMf_ONCE to this pv or to the op?
- bwarn("PMOP sv REGEX not yet supported");
- asm "op_pmflags", $op->pmflags | 2;
- bwarn("PMOP pmstashpv: ",$op->pmstashpv, ", pmflags: ",$op->pmflags | 2) if $debug{M};
- asm "pregcomp", $ix;
+ bwarn("PMOP not yet supported");
+ if ($op->pmoffset) { # regex_pad is regenerated within pregcomp
+ bwarn("PMOP existing regex_pad not yet supported");
+ asm "op_pmflags", $op->pmflags | 2;
+ } else {
+ asm "op_pmflags", $op->pmflags;
+ }
+ asm "newpv", pvstring $op->precomp;
+ asm "op_reflags", $op->reflags;
+ # bwarn("PMOP pmstashpv: ",$op->pmstashpv, ", pmflags: ",$op->pmflags | 2) if $debug{M};
+ #asm "pregcomp", $ix;
+ asm "pregcomp";
}
}
View
217 lib/B/C.pm
@@ -8,7 +8,7 @@
package B::C;
-our $VERSION = '1.04_07';
+our $VERSION = '1.04_08';
package B::C::Section;
@@ -190,6 +190,7 @@ my %xsub;
my $warn_undefined_syms;
my $verbose;
my %unused_sub_packages;
+my %static_ext;
my $use_xsloader;
my $nullop_count;
my $pv_copy_on_grow = 0;
@@ -198,12 +199,14 @@ my $optimize_warn_sv = 0;
my $use_perl_script_name = 0;
my $save_data_fh = 0;
my $save_sig = 0;
-# -Dc -DA -DC -DM -DS
-my ($debug_cops, $debug_av, $debug_cv, $debug_mg, $debug_sv);
+# -Dc -DA -DC -DM -DS -DG
+my ($debug_cops, $debug_av, $debug_cv, $debug_mg, $debug_sv, $debug_gv);
my $max_string_len;
my $ithreads = $Config{useithreads} eq 'define';
my $perl510 = ($] >= 5.009005);
+my $perl511 = ($] >= 5.011);
+my $mad = $Config{mad} eq 'define';
my @threadsv_names;
BEGIN {
@@ -263,7 +266,7 @@ sub getsym {
sub savere {
my $re = shift;
my $sym = sprintf("re%d", $re_index++);
- $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
+ $decl->add(sprintf("static char *$sym = %s;\n", cstring($re)));
return ($sym,length(pack "a*",$re));
}
@@ -355,12 +358,13 @@ sub B::OP::fake_ppaddr {
# 5.11: unsigned op_opt:1; unsigned op_latefree:1; unsigned op_latefreed:1; unsigned op_attached:1; unsigned op_spare:3;
my $static;
if ($] < 5.009004) { $static = sprintf "%u", 65535; } # seq
- elsif ($] < 5.010) { $static = '0, 1, 0';} # opt static spare
- else { $static = '0, 0, 0, 0, 0';} # opt latefree latefreed attached spare
+ elsif ($] < 5.010) { $static = '0, 1, 0';} # opt static spare
+ else { $static = '0, 0, 0, 0, 0'; } # opt latefree latefreed attached spare
sub B::OP::_save_common_middle {
my $op = shift;
- sprintf ("%s, %u, %u, $static, 0x%x, 0x%x",
- $op->fake_ppaddr, $op->targ, $op->type,
+ my $madprop = $mad ? (" ".($B::VERSION < 1.1801 ? 0:$op->madprop) . ",") : "";
+ sprintf ("%s,%s %u, %u, $static, 0x%x, 0x%x",
+ $op->fake_ppaddr, $madprop, $op->targ, $op->type,
$op->flags, $op->private);
}
}
@@ -585,7 +589,7 @@ sub B::PMOP::save {
# of a substitution syntax tree. We don't want to walk that...
if ($op->name eq "pushre") {
$gvsym = $replroot->save;
-# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
+ warn "PMOP::save saving a pp_pushre with GV $gvsym\n" if $debug_gv;
$replrootfield = 0;
} else {
$replstartfield = saveoptree("*ignore*", $replroot, $replstart);
@@ -594,7 +598,14 @@ sub B::PMOP::save {
# pmnext handling is broken in perl itself, I 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) {
+ if ($perl511) {
+ $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->pmflags,
+ $replrootfield, $replstartfield,
+ ));
+ } elsif ($perl510) {
$pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x",
$op->_save_common, ${$op->first}, ${$op->last},
$replrootfield, $replstartfield,
@@ -612,9 +623,14 @@ sub B::PMOP::save {
unless $optimize_ppaddr;
my $re = $op->precomp;
if (defined($re)) {
+ # TODO: $op->pmregexp->reflags in 511
my( $resym, $relen ) = savere( $re );
- $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
- $relen));
+ if ($perl510) {
+ $init->add("PM_SETRE(&$pm, CALLREGCOMP($resym, &$pm));");
+ } else {
+ $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
+ $relen));
+ }
}
if ($gvsym) {
$init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
@@ -656,8 +672,8 @@ sub B::IV::save {
$xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
$svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
$xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
- warn sprintf("Saving IV %d to xpviv_list[%d], sv_list[%d]", $sv->IVX, $xpvivsect->index, $svsect->index)
- if $debug_sv;
+ warn sprintf("Saving IV %d to xpviv_list[%d], sv_list[%d]", $sv->IVX,
+ $xpvivsect->index, $svsect->index) if $debug_sv;
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}
@@ -667,7 +683,11 @@ sub B::NV::save {
return $sym if defined $sym;
my $val= $sv->NVX;
$val .= '.00' if $val =~ /^-?\d+$/;
- $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
+ if ($perl510) {
+ $xpvnvsect->add(sprintf("%s, 0, 0, %d", $val, $sv->IVX));
+ } else {
+ $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
+ }
$svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
$xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
warn sprintf("Saving NV %d %s to xpvnv_list[%d], sv_list[%d]", $sv->IVX, $val,
@@ -730,7 +750,7 @@ sub B::PVIV::save {
$svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
$xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
if (defined($pv) && !$pv_copy_on_grow) {
- my $pvx = $] < 5.009 ? "xpviv_list[%d].xpv_pv" : "((sv)xpviv_list[%d])->sv_u.svu_pv";
+ my $pvx = $] < 5.009 ? "xpviv_list[%d].xpv_pv" : "((SV)xpviv_list[%d]).sv_u.svu_pv";
$init->add(savepvn(sprintf($pvx, $xpvivsect->index), $pv));
}
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
@@ -743,12 +763,16 @@ sub B::PVNV::save {
my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
my $val= $sv->NVX;
$val .= '.00' if $val =~ /^-?\d+$/;
- $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
- $savesym, $len, $pvmax, $sv->IVX, $val));
+ if ($perl510) {
+ $xpvnvsect->add(sprintf("%s, %u, %u, %d", $val, $len, $pvmax, $sv->IVX)); # ??
+ } else {
+ $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
+ $savesym, $len, $pvmax, $sv->IVX, $val));
+ }
$svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
$xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
if (defined($pv) && !$pv_copy_on_grow) {
- my $pvx = $] < 5.009 ? "xpvnv_list[%d].xpv_pv" : "((sv)xpvnv_list[%d])->sv_u.svu_pv";
+ my $pvx = $] < 5.009 ? "xpvnv_list[%d].xpv_pv" : "((SV)xpvnv_list[%d]).sv_u.svu_pv";
$init->add(savepvn(sprintf($pvx, $xpvnvsect->index), $pv));
}
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
@@ -766,7 +790,7 @@ sub B::BM::save {
$svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
$xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
$sv->save_magic;
- my $pvx = $] < 5.009 ? "xpvbm_list[%d].xpv_pv" : "((sv)xpvbm_list[%d])->sv_u.svu_pv";
+ my $pvx = $] < 5.009 ? "xpvbm_list[%d].xpv_pv" : "((SV)xpvbm_list[%d]).sv_u.svu_pv";
$init->add(savepvn(sprintf($pvx, $xpvbmsect->index), $pv),
sprintf("xpvbm_list[%d].xpv_cur = %u;",
$xpvbmsect->index, $len - 257));
@@ -800,7 +824,7 @@ sub B::PVMG::save {
$svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
$xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
if (defined($pv) && !$pv_copy_on_grow) {
- my $pvx = $] < 5.009 ? "xpvmg_list[%d].xpv_pv" : "((sv)xpvmg_list[%d])->sv_u.svu_pv";
+ my $pvx = $] < 5.009 ? "xpvmg_list[%d].xpv_pv" : "((SV)xpvmg_list[%d]).sv_u.svu_pv";
$init->add(savepvn(sprintf($pvx, $xpvmgsect->index), $pv));
}
$sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
@@ -810,7 +834,7 @@ sub B::PVMG::save {
sub B::PVMG::save_magic {
my ($sv) = @_;
- #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
+ warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv) if $debug_mg;
my $stash = $sv->SvSTASH;
$stash->save;
if ($$stash) {
@@ -849,13 +873,22 @@ sub B::PVMG::save_magic {
my( $resym, $relen ) = savere( $mg->precomp );
my $pmsym = $pmop->save;
- $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
+ if ($perl510) {
+ $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
+{
+ REGEXP* rx = CALLREGCOMP($resym, (PMOP*)$pmsym);
+ sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
+}
+CODE
+ } else {
+ $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
{
REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
}
CODE
- }else{
+ }
+ } else {
$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
$$sv, $$obj, cchar($type),cstring($ptr),$len));
}
@@ -1075,24 +1108,24 @@ sub B::GV::save {
my ($gv) = @_;
my $sym = objsym($gv);
if (defined($sym)) {
- #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
+ warn sprintf("GV 0x%x already saved as $sym\n", $$gv) if $debug_gv;
return $sym;
} else {
my $ix = $gv_index++;
$sym = savesym($gv, "gv_list[$ix]");
- #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
+ warn sprintf("Saving GV 0x%x as $sym\n", $$gv) if $debug_gv;
}
my $is_empty = $gv->is_empty;
my $gvname = $gv->NAME;
my $fullname = $gv->STASH->NAME . "::" . $gvname;
my $name = cstring($fullname);
- #warn "GV name is $name\n"; # debug
+ warn "GV name is $name\n" if $debug_gv;
my $egvsym;
unless ($is_empty) {
my $egv = $gv->EGV;
if ($$gv != $$egv) {
- #warn(sprintf("EGV name is %s, saving it now\n",
- # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
+ warn(sprintf("EGV name is %s, saving it now\n",
+ $egv->STASH->NAME . "::" . $egv->NAME)) if $debug_gv;
$egvsym = $egv->save;
}
}
@@ -1143,24 +1176,24 @@ sub B::GV::save {
"GvGP($sym) = GvGP($egvsym);");
} elsif ($savefields) {
# Don't save subfields of special GVs (*_, *1, *# and so on)
-# warn "GV::save saving subfields\n"; # debug
+ warn "GV::save saving subfields\n" if $debug_gv;
my $gvsv = $gv->SV;
if ($$gvsv && $savefields&Save_SV) {
$gvsv->save;
$init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
-# warn "GV::save \$$name\n"; # debug
+ warn "GV::save \$$name\n" if $debug_gv;
}
my $gvav = $gv->AV;
if ($$gvav && $savefields&Save_AV) {
$gvav->save;
$init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
-# warn "GV::save \@$name\n"; # debug
+ warn "GV::save \@$name\n" if $debug_gv;
}
my $gvhv = $gv->HV;
if ($$gvhv && $savefields&Save_HV) {
$gvhv->save;
$init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
-# warn "GV::save \%$name\n"; # debug
+ warn "GV::save \%$name\n" if $debug_gv;
}
my $gvcv = $gv->CV;
if ($$gvcv && $savefields&Save_CV) {
@@ -1175,20 +1208,20 @@ sub B::GV::save {
$init->add("}");
} else {
$init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
-# warn "GV::save &$name\n"; # debug
- }
- }
- if ($[ < 5.009) {
+ warn "GV::save &$name\n" if $debug_gv;
+ }
+ }
+ if ($] < 5.009) {
$init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
} else {
$init->add(sprintf("GvFILE_HEK($sym) = %s;", cstring($gv->FILE)));
}
-# warn "GV::save GvFILE(*$name)\n"; # debug
+ warn "GV::save GvFILE".($[ < 5.009 ? "" : "_HEK")."(*$name)\n" if $debug_gv;
my $gvform = $gv->FORM;
if ($$gvform && $savefields&Save_FORM) {
$gvform->save;
$init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
-# warn "GV::save GvFORM(*$name)\n"; # debug
+ warn "GV::save GvFORM(*$name)\n" if $debug_gv;
}
my $gvio = $gv->IO;
if ($$gvio && $savefields&Save_IO) {
@@ -1200,7 +1233,7 @@ sub B::GV::save {
use strict 'refs';
$gvio->save_data( $fullname, <$fh> ) if $fh->opened;
}
-# warn "GV::save GvIO(*$name)\n"; # debug
+ warn "GV::save GvIO(*$name)\n" if $debug_gv;
}
}
return $sym;
@@ -1361,7 +1394,7 @@ CODE
}
# TODO
-sub B::IO::SUBPROCESS {
+sub B::IO::SUBPROCESS {
warn "B::IO::SUBPROCESS missing\n";
}
@@ -1372,12 +1405,23 @@ sub B::IO::save {
my $pv = $io->PV;
$pv = '' unless defined $pv;
my $len = length($pv);
- $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
- $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
- $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
- cstring($io->TOP_NAME), cstring($io->FMT_NAME),
- cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
- cchar($io->IoTYPE), $io->IoFLAGS));
+ # < 5.10: xpv_pv, cur, len, iv, nv, magic, stash, xio_ifp, xio_ofp, xio_dirpu, ..., subprocess, type, flags
+ # 5.10: xnv_u, cur, len, xiv_u, xmg_u, xmg_stash, xio_ifp, xio_ofp, xio_dirpu, ..., type, flags
+ if ($perl510) {
+ $xpviosect->add(sprintf("0, %u, %u, %d, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %s, 0x%x",
+ $len, $len+1, $io->IVX, $io->LINES,
+ $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
+ cstring($io->TOP_NAME), cstring($io->FMT_NAME),
+ cstring($io->BOTTOM_NAME),
+ cchar($io->IoTYPE), $io->IoFLAGS));
+ } else {
+ $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
+ $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
+ $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
+ cstring($io->TOP_NAME), cstring($io->FMT_NAME),
+ cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
+ cchar($io->IoTYPE), $io->IoFLAGS));
+ }
$svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
$xpviosect->index, $io->REFCNT , $io->FLAGS));
$sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
@@ -1592,8 +1636,8 @@ EOT
}
print <<'EOT';
-#ifdef CSH
- if (!PL_cshlen)
+#if defined(CSH) && (PERL_VERSION < 10)
+ if (!PL_cshlen)
PL_cshlen = strlen(PL_cshname);
#endif
@@ -1696,13 +1740,21 @@ xs_init(pTHX)
dTARG;
dSP;
EOT
+ print "\n#undef USE_DYNAMIC_LOADING"; # REMOVEME! boot_ symbols not linked!
print "\n#ifdef USE_DYNAMIC_LOADING";
print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
print "\n#endif\n" ;
- # delete $xsub{'DynaLoader'};
- delete $xsub{'UNIVERSAL'};
+ # delete $xsub{'DynaLoader'};
+ delete $xsub{'UNIVERSAL'};
print("/* bootstrapping code*/\n\tSAVETMPS;\n");
print("\ttarg=sv_newmortal();\n");
+ print "#ifdef USE_DYNAMIC_LOADING\n"; # REMOVEME! boot_ symbols not linked!
+ foreach my $stashname (keys %static_ext) {
+ my $stashxsub = $stashname;
+ $stashxsub =~ s/::/__/g;
+ print "\tnewXS(\"${stashname}::bootstrap\", boot_$stashxsub, file);\n";
+ }
+ print "#endif\n"; # REMOVEME! boot_ symbols not linked!
print "#ifdef USE_DYNAMIC_LOADING\n";
print "\tPUSHMARK(sp);\n";
print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
@@ -1710,20 +1762,20 @@ EOT
print "\tboot_DynaLoader(aTHX_ NULL);\n";
print qq/\tSPAGAIN;\n/;
print "#endif\n";
- foreach my $stashname (keys %xsub){
- if ($xsub{$stashname} !~ m/Dynamic/ ) {
+ foreach my $stashname (keys %xsub) {
+ if ($xsub{$stashname} !~ m/Dynamic/ and !$static_ext{$stashname}) {
my $stashxsub=$stashname;
- $stashxsub =~ s/::/__/g;
+ $stashxsub =~ s/::/__/g;
print "\tPUSHMARK(sp);\n";
print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
print qq/\tPUTBACK;\n/;
print "\tboot_$stashxsub(aTHX_ NULL);\n";
print qq/\tSPAGAIN;\n/;
- }
+ }
}
print("\tFREETMPS;\n/* end bootstrapping code */\n");
print "}\n";
-
+
print <<'EOT';
static void
dl_init(pTHX)
@@ -1738,7 +1790,7 @@ EOT
warn "Loaded $stashname\n";
if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
my $stashxsub=$stashname;
- $stashxsub =~ s/::/__/g;
+ $stashxsub =~ s/::/__/g;
print "\tPUSHMARK(sp);\n";
print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
print qq/\tPUTBACK;\n/;
@@ -1754,7 +1806,7 @@ EOT
print "\tboot_$stashxsub(aTHX_ NULL);\n";
print "#endif\n";
print qq/\tSPAGAIN;\n/;
- }
+ }
}
print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
print "}\n";
@@ -1774,11 +1826,11 @@ sub save_object {
foreach $sv (@_) {
svref_2object($sv)->save;
}
-}
+}
-sub Dummy_BootStrap { }
+sub Dummy_BootStrap { }
-sub B::GV::savecv
+sub B::GV::savecv
{
my $gv = shift;
my $package=$gv->STASH->NAME;
@@ -1800,10 +1852,10 @@ sub B::GV::savecv
}
sub mark_package
-{
+{
my $package = shift;
unless ($unused_sub_packages{$package})
- {
+ {
no strict 'refs';
$unused_sub_packages{$package} = 1;
if (defined @{$package.'::ISA'})
@@ -1813,7 +1865,7 @@ sub mark_package
if ($isa eq 'DynaLoader')
{
unless (defined(&{$package.'::bootstrap'}))
- {
+ {
warn "Forcing bootstrap of $package\n";
eval { $package->bootstrap };
}
@@ -1831,7 +1883,7 @@ sub mark_package
}
return 1;
}
-
+
sub should_save
{
no strict qw(vars refs);
@@ -1839,9 +1891,9 @@ sub should_save
$package =~ s/::$//;
return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
warn "Considering $package\n";#debug
- foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
- {
- # If this package is a prefix to something we are saving, traverse it
+ foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
+ {
+ # If this package is a prefix to something we are saving, traverse it
# but do not mark it for saving if it is not already
# e.g. to get to Getopt::Long we need to traverse Getopt but need
# not save Getopt
@@ -1849,7 +1901,7 @@ sub should_save
}
if (exists $unused_sub_packages{$package})
{
- # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
+ # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
return $unused_sub_packages{$package};
}
@@ -1889,22 +1941,22 @@ sub walkpackages
no strict 'vars';
$prefix = '' unless defined $prefix;
while (($sym, $ref) = each %$symref)
- {
+ {
local(*glob);
*glob = $ref;
- if ($sym =~ /::$/)
+ if ($sym =~ /::$/)
{
$sym = $prefix . $sym;
if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
{
walkpackages(\%glob, $recurse, $sym);
}
- }
+ }
}
}
-sub save_unused_subs
+sub save_unused_subs
{
no strict qw(refs);
&descend_marked_unused;
@@ -1920,7 +1972,7 @@ sub save_context
my $curpad_sym = (comppadlist->ARRAY)[1]->save;
my $inc_hv = svref_2object(\%INC)->save;
my $inc_av = svref_2object(\@INC)->save;
- my $amagic_generate= amagic_generation;
+ my $amagic_generate= amagic_generation;
$init->add( "PL_curpad = AvARRAY($curpad_sym);",
"GvHV(PL_incgv) = $inc_hv;",
"GvAV(PL_incgv) = $inc_av;",
@@ -1994,6 +2046,14 @@ sub save_main {
warn "Writing output\n";
output_boilerplate();
+ # add static modules like " Win32CORE"
+ foreach my $stashname (split /\s+/, $Config{static_ext}) {
+ next if $stashname =~ /^\s*$/; # often a leading space
+ $static_ext{$stashname}++;
+ my $stashxsub = $stashname;
+ $stashxsub =~ s/::/__/g;
+ print "EXTERN_C void boot_$stashxsub (pTHX_ CV* cv);\n";
+ }
print "\n";
output_all("perl_init");
print "\n";
@@ -2069,6 +2129,8 @@ sub compile {
$debug_cv = 1;
} elsif ($arg eq "M") {
$debug_mg = 1;
+ } elsif ($arg eq "G") {
+ $debug_gv = 1;
} elsif ($arg eq "S") {
$debug_sv = 1;
} else {
@@ -2206,6 +2268,10 @@ prints AV information on saving
prints CV information on saving
+=item B<-DG>
+
+prints GV information on saving
+
=item B<-DM>
prints MAGIC information on saving
@@ -2290,8 +2356,7 @@ Plenty. Current status: experimental.
=head1 AUTHOR
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>.
Reini Urban, C<rurban@cpan.org>
=cut
View
20 lib/B/CC.pm
@@ -290,9 +290,9 @@ sub reload_lexicals {
my %alloc; # Keyed by variable name. A value of 1 means the
# variable has been declared. A value of 2 means
# it's in use.
-
+
sub new_scope { %alloc = () }
-
+
sub new ($$$) {
my ($class, $type, $prefix) = @_;
my ($ptr, $i, $varname, $status, $obj);
@@ -539,7 +539,7 @@ sub pp_and {
}
return $op->other;
}
-
+
sub pp_or {
my $op = shift;
my $next = $op->next;
@@ -558,7 +558,7 @@ sub pp_or {
}
return $op->other;
}
-
+
sub pp_cond_expr {
my $op = shift;
my $false = $op->next;
@@ -643,7 +643,7 @@ sub pp_rv2gv{
my $sym=doop($op);
if ($op->private & OPpDEREF) {
$init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
- $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
+ $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
$op->first->type));
}
return $op->next;
@@ -651,7 +651,7 @@ sub pp_rv2gv{
sub pp_sort {
my $op = shift;
my $ppname = $op->ppaddr;
- if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
+ if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED) {
#this indicates the sort BLOCK Array case
#ugly surgery required.
my $root=$op->first->sibling->first;
@@ -1117,7 +1117,7 @@ sub pp_formline {
write_back_stack() unless $skip_stack{$ppname};
my $sym=doop($op);
# See comment in pp_grepwhile to see why!
- $init->add("((LISTOP*)$sym)->op_first = $sym;");
+ $init->add("((LISTOP*)$sym)->op_first = $sym;");
runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
save_or_restore_lexical_state(${$op->first});
runtime( sprintf("goto %s;",label($op->first)));
@@ -1144,7 +1144,7 @@ sub pp_leavesub{
my $op = shift;
write_back_lexicals() unless $skip_lexicals{$ppname};
write_back_stack() unless $skip_stack{$ppname};
- runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
+ runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
runtime("\tPUTBACK;return 0;");
runtime("}");
doop($op);
@@ -1619,7 +1619,7 @@ sub cc_recurse {
cc(@$ccinfo);
}
return $start;
-}
+}
sub cc_obj {
my ($name, $cvref) = @_;
@@ -1654,7 +1654,7 @@ sub cc_main {
"av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
"PL_amagic_generation= $amagic_generate;",
);
-
+
}
seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
output_boilerplate();
View
33 lib/B/Debug.pm
@@ -1,11 +1,19 @@
package B::Debug;
-our $VERSION = '1.05_01';
+our $VERSION = '1.05_02';
use strict;
use B qw(peekop class walkoptree walkoptree_exec
main_start main_root cstring sv_undef @specialsv_name);
# <=5.008 had @specialsv_name exported from B::Asmdata
+BEGIN {
+ use Config;
+ my $ithreads = $Config{'useithreads'} eq 'define';
+ eval qq{
+ sub ITHREADS() { $ithreads }
+ sub VERSION() { $] }
+ }; die $@ if $@;
+}
my %done_gv;
@@ -18,11 +26,11 @@ sub _printop {
sub B::OP::debug {
my ($op) = @_;
- printf <<'EOT', class($op), $$op, _printop($op->next), _printop($op->sibling), $op->ppaddr, $op->targ, $op->type;
+ printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
%s (0x%lx)
+ op_ppaddr %s
op_next %s
op_sibling %s
- op_ppaddr %s
op_targ %d
op_type %d
EOT
@@ -81,8 +89,17 @@ sub B::PMOP::debug {
printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
- printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
+ if (ITHREADS) {
+ printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
+ printf "\top_pmoffset\t%d\n", $op->pmoffset;
+ } else {
+ printf "\top_pmstash\t%s\n", cstring($op->pmstash);
+ }
+ printf "\top_precomp\t%s\n", cstring($op->precomp);
printf "\top_pmflags\t0x%x\n", $op->pmflags;
+ printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
+ printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
+ printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
$op->pmreplroot->debug;
}
@@ -112,7 +129,7 @@ sub B::SVOP::debug {
sub B::PVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf "\top_pv\t\t\"%s\"\n", cstring($op->pv);
+ printf "\top_pv\t\t%s\n", cstring($op->pv);
}
sub B::PADOP::debug {
@@ -157,7 +174,7 @@ sub B::PV::debug {
$sv->B::SV::debug();
my $pv = $sv->PV();
printf <<'EOT', cstring($pv), length($pv);
- xpv_pv "%s"
+ xpv_pv %s
xpv_cur %d
EOT
}
@@ -191,7 +208,7 @@ sub B::PVLV::debug {
$sv->B::PVNV::debug();
printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
- printf "\txlv_type\t\"%s\"\n", cstring(chr($sv->TYPE));
+ printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
}
sub B::BM::debug {
@@ -199,7 +216,7 @@ sub B::BM::debug {
$sv->B::PVNV::debug();
printf "\txbm_useful\t%d\n", $sv->USEFUL;
printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
- printf "\txbm_rare\t\"%s\"\n", cstring(chr($sv->RARE));
+ printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
}
sub B::CV::debug {
View
9 t/testc.sh
@@ -1,12 +1,14 @@
-OCMD="perld -Mblib -MO=C,-DcACMS,"
-CCMD="gcc -DPERL_USE_SAFE_PUTENV -U__STRICT_ANSI__ -fno-strict-aliasing -I/usr/local/include -I/usr/lib/perl5/5.10/i686-cygwin/CORE"
-LCMD=" -Wl,--enable-auto-import -Wl,--export-all-symbols -Wl,--stack,8388608 -Wl,--enable-auto-image-base -L/usr/local/lib -L/usr/lib/perl5/5.10/i686-cygwin/CORE -lperl -ldl -lcrypt -lgdbm_compat -lperl"
+OCMD="perl5.11.0 -Mblib -MO=C,-DcACMSG,"
+CCMD="gcc -pipe -DDEBUGGING -DPERL_USE_SAFE_PUTENV -U__STRICT_ANSI__ -fno-strict-aliasing -I/usr/lib/perl5/5.11/i686-cygwin/CORE -O0 -g"
+LCMD=" -Wl,--enable-auto-import -Wl,--export-all-symbols -L/usr/lib/perl5/5.11/i686-cygwin/CORE -lperl -ldl -lcrypt -lgdbm_compat"
+make
echo "print 'hi'" > ccode1.pl
echo ${OCMD}-occode1.c ccode1.pl
${OCMD}-occode1.c ccode1.pl
echo $CCMD ccode1.c $LCMD -o ccode1.exe
$CCMD ccode1.c $LCMD -o ccode1.exe
+$CCMD ccode1.c -E -o ccode1.cee
test -e ccode1.exe || exit
echo "for (1,2,3) { print if /\d/ }" > ccode2.pl
@@ -14,3 +16,4 @@ echo ${OCMD}-occode2.c ccode2.pl
${OCMD}-occode2.c ccode2.pl
echo $CCMD ccode2.c $LCMD -o ccode2.exe
$CCMD ccode2.c $LCMD -o ccode2.exe
+$CCMD ccode2.c -E -o ccode2.cee
View
25 t/testplc.sh
@@ -1,33 +1,54 @@
#!/bin/sh
-PERL=perld
+PERL=perl5.11.0
OCMD="$PERL -Mblib -MO=Bytecode,"
ICMD="$PERL -Mblib -MByteLoader"
+make
+
+#basics
+if false; then
echo "print 'hi'" > bytecode1.pl
echo ${OCMD}-obytecode1.plc bytecode1.pl
${OCMD}-obytecode1.plc bytecode1.pl
${OCMD}-O6,-obytecode1O6.plc bytecode1.pl
${OCMD}-k,-obytecode1k.plc bytecode1.pl
${OCMD}-S,-obytecode1S.asm bytecode1.pl
+echo $PERL -Mblib -MO=Debug bytecode1.pl > bytecode1.dbg
+$PERL -Mblib -MO=Debug bytecode1.pl > bytecode1.dbg
+$PERL -Mblib -MO=Concise bytecode1.pl > bytecode1.concise
$PERL -Mblib script/assemble bytecode1S.asm bytecode1S.plc
$PERL -Mblib script/disassemble bytecode1k.plc > bytecode1k.asm
${OCMD}-TI,-obytecode1TI.plc bytecode1.pl
${OCMD}-H,-obytecode1H.plc bytecode1.pl
echo ${ICMD} bytecode1.plc
${ICMD} bytecode1.plc
+fi
+#PMOP
+if true; then
echo "for (1,2,3) { print if /\d/ }" > bytecode2.pl
echo ${OCMD}-obytecode2.plc bytecode2.pl
-${OCMD}-obytecode2.plc bytecode2.pl
+${OCMD}-obytecode2.plc,-DM bytecode2.pl
+${OCMD}-S,-obytecode2S.asm bytecode2.pl
+echo $PERL -Mblib -MO=Debug bytecode2.pl > bytecode2.dbg
+$PERL -Mblib -MO=Debug bytecode2.pl > bytecode2.dbg
+$PERL -Mblib -MO=Concise bytecode2.pl > bytecode2.concise
echo ${ICMD} bytecode2.plc
${ICMD} bytecode2.plc
+fi
+#only if ByteLoader installed
+if false; then
echo ${OCMD}-H,-obytecode2.plc bytecode2.pl
${OCMD}-H,-obytecode2.plc bytecode2.pl
chmod +x bytecode2.plc
echo ./bytecode2.plc
./bytecode2.plc
+fi
+# package
+if false; then
echo "package MY::Test;" > bytecode1.pm
echo "print 'hi'" >> bytecode1.pm
echo ${OCMD}-m,-obytecode1.pmc bytecode1.pm
${OCMD}-obytecode1.pmc bytecode1.pm
+fi
Please sign in to comment.
Something went wrong with that request. Please try again.