X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FC.pm;h=17ca25788b05763e7f5e84a1b9487963978d3078;hb=461824dcfbc00b3c4e20590f06d6c9881e4a416b;hp=8d71bb27600287922f896f0c6954a487e28e75a9;hpb=e934609f7db1163b003ba7314f8d52ebfc1e2f12;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index 8d71bb2..17ca257 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -5,9 +5,12 @@ # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. # -package B::C::Section; -our $VERSION = '1.01'; +package B::C; + +our $VERSION = '1.05'; + +package B::C::Section; use B (); use base B::Section; @@ -166,7 +169,7 @@ our %REGEXP; use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation - AVf_REAL HEf_SVKEY SVf_POK SVf_ROK CVf_CONST); + HEf_SVKEY SVf_POK SVf_ROK CVf_CONST); use B::Asmdata qw(@specialsv_name); use FileHandle; @@ -226,15 +229,6 @@ sub walk_and_save_optree { return objsym($start); } -# 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 $op_seq = 65535; - # 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'); @@ -335,6 +329,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); @@ -346,9 +372,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, %u, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ, - $type, $op_seq, $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; @@ -362,9 +386,8 @@ sub B::FAKEOP::new { sub B::FAKEOP::save { my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x", - $op->next, $op->sibling, $op->fake_ppaddr, $op->targ, - $op->type, $op_seq, $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; @@ -383,10 +406,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, %u, 0x%x, 0x%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -397,10 +417,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, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -411,10 +429,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, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -425,10 +441,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, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -442,10 +456,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, %u, 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_seq, $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; @@ -458,10 +470,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, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -475,11 +484,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, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -492,10 +498,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, %u, 0x%x, 0x%x, %d", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -536,10 +540,8 @@ sub B::COP::save { $warn_sv = $warnings->save; } - $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s", - ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, - $op->targ, $op->type, $op_seq, $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; @@ -582,10 +584,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, %u, 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_seq, $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 )); @@ -659,7 +659,7 @@ sub savepvn { # work with byte offsets/lengths my $pv = pack "a*", $pv; if (defined $max_string_len && length($pv) > $max_string_len) { - push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1); + push @res, sprintf("Newx(%s,%u,char);", $dest, length($pv)+1); my $offset = 0; while (length $pv) { my $str = substr $pv, 0, $max_string_len, ''; @@ -1012,10 +1012,11 @@ sub B::CV::save { $cvstashname, $cvname); # debug } $pv = '' unless defined $pv; # Avoid use of undef warnings - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x", + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, - $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); + $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS, + $cv->OUTSIDE_SEQ)); if (${$cv->OUTSIDE} == ${main_cv()}){ $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); @@ -1181,16 +1182,19 @@ sub B::AV::save { my ($av) = @_; my $sym = objsym($av); return $sym if defined $sym; - my $avflags = $av->AvFLAGS; - $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", - $avflags)); + my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0"; + $line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009; + $xpvavsect->add($line); $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", $xpvavsect->index, $av->REFCNT , $av->FLAGS)); my $sv_list_index = $svsect->index; my $fill = $av->FILL; $av->save_magic; - warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags) - if $debug_av; + if ($debug_av) { + $line = sprintf("saving AV 0x%x FILL=$fill", $$av); + $line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009; + warn $line; + } # XXX AVf_REAL is wrong test: need to save comppadlist but not stack #if ($fill > -1 && ($avflags & AVf_REAL)) { if ($fill > -1) { @@ -1412,40 +1416,11 @@ sub output_declarations { #endif /* BROKEN_STATIC_REDECL */ #ifdef BROKEN_UNION_INIT -/* - * Cribbed from cv.h with ANY (a union) replaced by void*. - * Some pre-Standard compilers can't cope with initialising unions. Ho hum. - */ -typedef struct { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xp_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - IV xof_off; /* integer value */ - NV xnv_nv; /* numeric value, if any */ - MAGIC* xmg_magic; /* magic for scalar array */ - HV* xmg_stash; /* class package */ - - HV * xcv_stash; - OP * xcv_start; - OP * xcv_root; - void (*xcv_xsub) (pTHX_ CV*); - ANY xcv_xsubany; - GV * xcv_gv; - char * xcv_file; - long xcv_depth; /* >= 2 indicates recursive call */ - AV * xcv_padlist; - CV * xcv_outside; -#ifdef USE_5005THREADS - perl_mutex *xcv_mutexp; - struct perl_thread *xcv_owner; /* current owner thread */ -#endif /* USE_5005THREADS */ - cv_flags_t xcv_flags; -} XPVCV_or_similar; -#define ANYINIT(i) i -#else +#error BROKEN_UNION_INIT no longer needed, as Perl requires an ANSI compiler +#endif + #define XPVCV_or_similar XPVCV #define ANYINIT(i) {i} -#endif /* BROKEN_UNION_INIT */ #define Nullany ANYINIT(0) #define UNUSED 0 @@ -1574,7 +1549,7 @@ EOT #else #define EXTRA_OPTIONS 4 #endif /* ALLOW_PERL_OPTIONS */ - New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *); + Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *); fakeargv[0] = argv[0]; fakeargv[1] = "-e"; @@ -1619,6 +1594,15 @@ EOT } EOT } + else { + print <