From: Nicholas Clark Date: Wed, 8 Sep 2004 16:53:34 +0000 (+0000) Subject: backport B to work on 5.8.x, so that a single version of the source X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7252851f9977dfc5c982b985eeabcb43c006d03e;p=p5sagit%2Fp5-mst-13.2.git backport B to work on 5.8.x, so that a single version of the source can be maintained, and ultimately dual-lifed on CPAN (the version conditional changes are actually surprisingly small) p4raw-id: //depot/perl@23278 --- diff --git a/ext/B/B.xs b/ext/B/B.xs index ed1af11..43b91fe 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -29,11 +29,16 @@ static char *svclassnames[] = { "B::PVNV", "B::PVMG", "B::BM", +#if PERL_VERSION >= 9 "B::GV", +#endif "B::PVLV", "B::AV", "B::HV", "B::CV", +#if PERL_VERSION <= 8 + "B::GV", +#endif "B::FM", "B::IO", }; @@ -416,9 +421,15 @@ oplist(pTHX_ OP *o, SV **SP) { for(; o; o = o->op_next) { SV *opsv; - if (o->op_opt == 0) +#if PERL_VERSION >= 9 + if (o->op_opt == 0) break; o->op_opt = 0; +#else + if (o->op_seq == 0) + break; + o->op_seq = 0; +#endif opsv = sv_newmortal(); sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o)); XPUSHs(opsv); @@ -494,6 +505,9 @@ BOOT: specialsv_list[4] = pWARN_ALL; specialsv_list[5] = pWARN_NONE; specialsv_list[6] = pWARN_STD; +#if PERL_VERSION <= 9 +# define CVf_ASSERTION 0 +#endif #include "defsubs.h" } @@ -714,8 +728,12 @@ threadsv_names() #define OP_desc(o) PL_op_desc[o->op_type] #define OP_targ(o) o->op_targ #define OP_type(o) o->op_type -#define OP_opt(o) o->op_opt -#define OP_static(o) o->op_static +#if PERL_VERSION >= 9 +# define OP_opt(o) o->op_opt +# define OP_static(o) o->op_static +#else +# define OP_seq(o) o->op_seq +#endif #define OP_flags(o) o->op_flags #define OP_private(o) o->op_private #define OP_spare(o) o->op_spare @@ -773,6 +791,8 @@ U16 OP_type(o) B::OP o +#if PERL_VERSION >= 9 + U8 OP_opt(o) B::OP o @@ -781,6 +801,14 @@ U8 OP_static(o) B::OP o +#else + +U16 +OP_seq(o) + B::OP o + +#endif + U8 OP_flags(o) B::OP o @@ -789,10 +817,14 @@ U8 OP_private(o) B::OP o +#if PERL_VERSION >= 9 + U8 OP_spare(o) B::OP o +#endif + void OP_oplist(o) B::OP o diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index 2fb763d..245f6f0 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -226,12 +226,6 @@ sub walk_and_save_optree { return objsym($start); } -# Set the values for op_opt and op_static in each op. The value of -# op_opt is irrelevant, and the value of op_static needs to be 1 to tell -# op_free that this is a statically defined op and that is shouldn't be -# freed. -my $op_os = "0, 1, 0"; - # Look this up here so we can do just a number compare # rather than looking up the name of every BASEOP in B::OP my $OP_THREADSV = opnumber('threadsv'); @@ -332,6 +326,38 @@ sub B::OP::fake_ppaddr { 'NULL'; } +# This pair is needed becase B::FAKEOP::save doesn't scalar dereference +# $op->next and $op->sibling + +{ + # For 5.9 the hard coded text is the values for op_opt and op_static in each + # op. The value of op_opt is irrelevant, and the value of op_static needs to + # be 1 to tell op_free that this is a statically defined op and that is + # shouldn't be freed. + + # For 5.8: + # Current workaround/fix for op_free() trying to free statically + # defined OPs is to set op_seq = -1 and check for that in op_free(). + # Instead of hardwiring -1 in place of $op->seq, we use $op_seq + # so that it can be changed back easily if necessary. In fact, to + # stop compilers from moaning about a U16 being initialised with an + # uncast -1 (the printf format is %d so we can't tweak it), we have + # to "know" that op_seq is a U16 and use 65535. Ugh. + + my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535; + 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, $op->flags, $op->private); + } +} + +sub B::OP::_save_common { + my $op = shift; + return sprintf("s\\_%x, s\\_%x, %s", + ${$op->next}, ${$op->sibling}, $op->_save_common_middle); +} + sub B::OP::save { my ($op, $level) = @_; my $sym = objsym($op); @@ -343,9 +369,7 @@ sub B::OP::save { $init->add(sprintf("(void)find_threadsv(%s);", cstring($threadsv_names[$op->targ]))); } - $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ, - $type, $op->flags, $op->private)); + $opsect->add($op->_save_common); my $ix = $opsect->index; $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -359,9 +383,8 @@ sub B::FAKEOP::new { sub B::FAKEOP::save { my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s, %u, %u, $op_os, 0x%x, 0x%x", - $op->next, $op->sibling, $op->fake_ppaddr, $op->targ, - $op->type, $op->flags, $op->private)); + $opsect->add(sprintf("%s, %s, %s", + $op->next, $op->sibling, $op->_save_common_middle)); my $ix = $opsect->index; $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -380,10 +403,7 @@ sub B::UNOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, ${$op->first})); + $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first})); my $ix = $unopsect->index; $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -394,10 +414,8 @@ sub B::BINOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, ${$op->first}, ${$op->last})); + $binopsect->add(sprintf("%s, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->last})); my $ix = $binopsect->index; $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -408,10 +426,8 @@ sub B::LISTOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, ${$op->first}, ${$op->last})); + $listopsect->add(sprintf("%s, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->last})); my $ix = $listopsect->index; $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -422,10 +438,8 @@ sub B::LOGOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, ${$op->first}, ${$op->other})); + $logopsect->add(sprintf("%s, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->other})); my $ix = $logopsect->index; $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -439,10 +453,8 @@ sub B::LOOP::save { #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", # peekop($op->redoop), peekop($op->nextop), # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, ${$op->first}, ${$op->last}, + $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->last}, ${$op->redoop}, ${$op->nextop}, ${$op->lastop})); my $ix = $loopsect->index; @@ -455,10 +467,7 @@ sub B::PVOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, cstring($op->pv))); + $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv))); my $ix = $pvopsect->index; $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -472,11 +481,8 @@ sub B::SVOP::save { my $sv = $op->sv; my $svsym = '(SV*)' . $sv->save; my $is_const_addr = $svsym =~ m/Null|\&/; - $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, - ( $is_const_addr ? $svsym : 'Nullsv' ))); + $svopsect->add(sprintf("%s, %s", $op->_save_common, + ( $is_const_addr ? $svsym : 'Nullsv' ))); my $ix = $svopsect->index; $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -489,10 +495,8 @@ sub B::PADOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %d", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private,$op->padix)); + $padopsect->add(sprintf("%s, %d", + $op->_save_common, $op->padix)); my $ix = $padopsect->index; $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) unless $optimize_ppaddr; @@ -533,10 +537,8 @@ sub B::COP::save { $warn_sv = $warnings->save; } - $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op->flags, - $op->private, cstring($op->label), $op->cop_seq, + $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s", + $op->_save_common, cstring($op->label), $op->cop_seq, $op->arybase, $op->line, ( $optimize_warn_sv ? $warn_sv : 'NULL' ))); my $ix = $copsect->index; @@ -579,10 +581,8 @@ 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 - $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ, - $op->type, $op->flags, $op->private, - ${$op->first}, ${$op->last}, + $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x", + $op->_save_common, ${$op->first}, ${$op->last}, $replrootfield, $replstartfield, ( $ithreads ? $op->pmoffset : 0 ), $op->pmflags, $op->pmpermflags, $op->pmdynflags )); diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 9259b31..c6ac010 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -47,7 +47,8 @@ my %style = "(?(#seq)?)#noise#arg(?([#targarg])?)"], "debug" => ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" - . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" + . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" . + ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n") . "\top_flags\t#flagval\n\top_private\t#privval\n" . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" . "(?(\top_sv\t\t#svaddr\n)?)", @@ -432,9 +433,15 @@ sub walk_exec { push @$targ, $ar; push @todo, [$op->pmreplstart, $ar]; } elsif ($name =~ /^enter(loop|iter)$/) { - $labels{${$op->nextop}} = "NEXT"; - $labels{${$op->lastop}} = "LAST"; - $labels{${$op->redoop}} = "REDO"; + if ($] > 5.009) { + $labels{${$op->nextop}} = "NEXT"; + $labels{${$op->lastop}} = "LAST"; + $labels{${$op->redoop}} = "REDO"; + } else { + $labels{$op->nextop->seq} = "NEXT"; + $labels{$op->lastop->seq} = "LAST"; + $labels{$op->redoop->seq} = "REDO"; + } } } } @@ -736,8 +743,14 @@ sub concise_op { } $h{seq} = $h{hyphseq} = seq($op); $h{seq} = "" if $h{seq} eq "-"; - $h{opt} = $op->opt; - $h{static} = $op->static; + if ($] > 5.009) { + $h{opt} = $op->opt; + $h{static} = $op->static; + $h{label} = $labels{$$op}; + } else { + $h{seqnum} = $op->seq; + $h{label} = $labels{$op->seq}; + } $h{next} = $op->next; $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); $h{nextaddr} = sprintf("%#x", $ {$op->next}); @@ -751,7 +764,6 @@ sub concise_op { $h{privval} = $op->private; $h{private} = private_flags($h{name}, $op->private); $h{addr} = sprintf("%#x", $$op); - $h{label} = $labels{$$op}; $h{typenum} = $op->type; $h{noise} = $linenoise[$op->type]; @@ -850,7 +862,11 @@ sub tree { # a little code at the end of the module, and compute the base sequence # number for the user's program as being a small offset later, so all we # have to worry about are changes in the offset. - + +# [For 5.8.x and earlier perl is generating sequence numbers for all ops, +# and using them to reference labels] + + # When you say "perl -MO=Concise -e '$a'", the output should look like: # 4 <@> leave[t1] vKP/REFC ->(end) @@ -1342,15 +1358,28 @@ The numeric value of the OP's private flags. The sequence number of the OP. Note that this is a sequence number generated by B::Concise. +=item B<#seqnum> + +5.8.x and earlier only. 5.9 and later do not provide this. + +The real sequence number of the OP, as a regular number and not adjusted +to be relative to the start of the real program. (This will generally be +a fairly large number because all of B is compiled before +your program is). + =item B<#opt> Whether or not the op has been optimised by the peephole optimiser. +Only available in 5.9 and later. + =item B<#static> Whether or not the op is statically defined. This flag is used by the B::C compiler backend and indicates that the op should not be freed. +Only available in 5.9 and later. + =item B<#sibaddr> The address of the OP's next youngest sibling, in hexidecimal. diff --git a/ext/B/B/Debug.pm b/ext/B/B/Debug.pm index aeac17f..39209cf 100644 --- a/ext/B/B/Debug.pm +++ b/ext/B/B/Debug.pm @@ -11,15 +11,25 @@ my %done_gv; sub B::OP::debug { my ($op) = @_; - printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->opt, $op->static, $op->flags, $op->private; + printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type; %s (0x%lx) op_next 0x%x op_sibling 0x%x op_ppaddr %s op_targ %d op_type %d +EOT + if ($] > 5.009) { + printf <<'EOT', $op->opt, $op->static; op_opt %d op_static %d +EOT + } else { + printf <<'EOT', $op->seq; + op_seq %d +EOT + } + printf <<'EOT', $op->flags, $op->private; op_flags %d op_private %d EOT diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index 478cee8..7d4303f 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -8,7 +8,11 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - require q(./test.pl); + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } + require q(./test.pl); } use OptreeCheck; plan tests => 9; diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t index 377b41c..c6f6bc4 100644 --- a/ext/B/t/f_sort.t +++ b/ext/B/t/f_sort.t @@ -8,6 +8,10 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } require q(./test.pl); } use OptreeCheck; diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index a8bc790..c51eeae 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -8,6 +8,10 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } require './test.pl'; } use OptreeCheck; diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t index 99f96fe..873e484 100755 --- a/ext/B/t/stash.t +++ b/ext/B/t/stash.t @@ -73,6 +73,8 @@ $got = "@got"; my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy Internals main Regexp utf8 version warnings"; +$expected =~ s/version // if $] < 5.009; + { no strict 'vars'; use vars '$OS2::is_aout';