# 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;
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;
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');
'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);
$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;
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;
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;
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;
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;
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;
#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;
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;
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;
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;
$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;
# 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 ));
# 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, '';
$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));
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) {
#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;
- 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
#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";
my $sym;
my $ref;
no strict 'vars';
- local(*glob);
$prefix = '' unless defined $prefix;
while (($sym, $ref) = each %$symref)
{
+ local(*glob);
*glob = $ref;
if ($sym =~ /::$/)
{
projects / p5sagit/p5-mst-13.2.git / blobdiff