My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
Changes to /lib/B/Bytecode.pm
9514b5aef691 vs. e3e94715045e Compare: vs.  Format:
Revision e3e94715045e
Go to: 
Project members, sign in to write a code review
/lib/B/Bytecode.pm   9514b5aef691 /lib/B/Bytecode.pm   e3e94715045e
1 # B::Bytecode.pm - The bytecode compiler (.plc), loaded by ByteLoader 1 # B::Bytecode.pm - The bytecode compiler (.plc), loaded by ByteLoader
2 # 2 #
3 # Copyright (c) 1994-1999 Malcolm Beattie. All rights reserved. 3 # Copyright (c) 1994-1999 Malcolm Beattie. All rights reserved.
4 # Copyright (c) 2003 Enache Adrian. All rights reserved. 4 # Copyright (c) 2003 Enache Adrian. All rights reserved.
5 # Copyright (c) 2008-2011 Reini Urban <rurban@cpan.org>. All rights reserved. 5 # Copyright (c) 2008-2011 Reini Urban <rurban@cpan.org>. All rights reserved.
6 # Copyright (c) 2011-2012 cPanel Inc. All rights reserved. 6 # Copyright (c) 2011-2012 cPanel Inc. All rights reserved.
7 # This module is free software; you can redistribute and/or modify 7 # This module is free software; you can redistribute and/or modify
8 # it under the same terms as Perl itself. 8 # it under the same terms as Perl itself.
9 9
10 # Reviving 5.6 support here is work in progress, and not yet enabled. 10 # Reviving 5.6 support here is work in progress, and not yet enabled.
11 # So far the original is used instead, even if the list of failed tests 11 # So far the original is used instead, even if the list of failed tests
12 # is impressive: 3,6,8..10,12,15,16,18,25..28. Pretty broken. 12 # is impressive: 3,6,8..10,12,15,16,18,25..28. Pretty broken.
13 13
14 package B::Bytecode; 14 package B::Bytecode;
15 15
16 our $VERSION = '1.14'; 16 our $VERSION = '1.14';
17 17
18 #use 5.008; 18 #use 5.008;
19 use B qw( class main_cv main_root main_start 19 use B qw( class main_cv main_root main_start
20 begin_av init_av end_av cstring comppadlist 20 begin_av init_av end_av cstring comppadlist
21 OPf_SPECIAL OPf_STACKED OPf_MOD 21 OPf_SPECIAL OPf_STACKED OPf_MOD
22 OPpLVAL_INTRO SVf_READONLY SVf_ROK ); 22 OPpLVAL_INTRO SVf_READONLY SVf_ROK );
23 use B::Assembler qw(asm newasm endasm); 23 use B::Assembler qw(asm newasm endasm);
24 24
25 BEGIN { 25 BEGIN {
26 if ( $] < 5.009 ) { 26 if ( $] < 5.009 ) {
27 require B::Asmdata; 27 require B::Asmdata;
28 B::Asmdata->import(qw(@specialsv_name @optype)); 28 B::Asmdata->import(qw(@specialsv_name @optype));
29 eval q[ 29 eval q[
30 sub SVp_NOK() {}; # unused 30 sub SVp_NOK() {}; # unused
31 sub SVf_NOK() {}; # unused 31 sub SVf_NOK() {}; # unused
32 ]; 32 ];
33 } 33 }
34 else { 34 else {
35 B->import(qw(SVp_NOK SVf_NOK @specialsv_name @optype)); 35 B->import(qw(SVp_NOK SVf_NOK @specialsv_name @optype));
36 } 36 }
37 if ( $] > 5.007 ) { 37 if ( $] > 5.007 ) {
38 B->import(qw(defstash curstash inc_gv dowarn 38 B->import(qw(defstash curstash inc_gv dowarn
39 warnhook diehook SVt_PVGV 39 warnhook diehook SVt_PVGV
40 SVf_FAKE)); 40 SVf_FAKE));
41 } else { 41 } else {
42 B->import(qw(walkoptree walksymtable)); 42 B->import(qw(walkoptree walksymtable));
43 } 43 }
44 } 44 }
45 use strict; 45 use strict;
46 use Config; 46 use Config;
47 use B::Concise; 47 use B::Concise;
48 48
49 ################################################# 49 #################################################
50 50
51 my $PERL56 = ( $] < 5.008001 ); 51 my $PERL56 = ( $] < 5.008001 );
52 my $PERL510 = ( $] >= 5.009005 ); 52 my $PERL510 = ( $] >= 5.009005 );
53 my $PERL512 = ( $] >= 5.011 ); 53 my $PERL512 = ( $] >= 5.011 );
54 #my $PERL514 = ( $] >= 5.013002 ); 54 #my $PERL514 = ( $] >= 5.013002 );
55 my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/); 55 my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/);
56 our ($quiet, $includeall, $savebegins, $T_inhinc); 56 our ($quiet, $includeall, $savebegins, $T_inhinc);
57 my ( $varix, $opix, %debug, %walked, %files, @cloop ); 57 my ( $varix, $opix, %debug, %walked, %files, @cloop );
58 my %strtab = ( 0, 0 ); 58 my %strtab = ( 0, 0 );
59 my %svtab = ( 0, 0 ); 59 my %svtab = ( 0, 0 );
60 my %optab = ( 0, 0 ); 60 my %optab = ( 0, 0 );
61 my %spectab = $PERL56 ? () : ( 0, 0 ); # we need the special Nullsv on 5.6 (?) 61 my %spectab = $PERL56 ? () : ( 0, 0 ); # we need the special Nullsv on 5.6 (?)
62 my $tix = $PERL56 ? 0 : 1; 62 my $tix = $PERL56 ? 0 : 1;
63 my %ops = ( 0, 0 ); 63 my %ops = ( 0, 0 );
64 my @packages; # list of packages to compile. 5.6 only 64 my @packages; # list of packages to compile. 5.6 only
65 65
66 # sub asm ($;$$) { } 66 # sub asm ($;$$) { }
67 sub nice ($) { } 67 sub nice ($) { }
68 sub nice1 ($) { } 68 sub nice1 ($) { }
69 69
70 my %optype_enum; 70 my %optype_enum;
71 my ($SVt_PV, $SVt_PVGV, $SVf_FAKE, $POK); 71 my ($SVt_PV, $SVt_PVGV, $SVf_FAKE, $POK);
72 if ($PERL56) { 72 if ($PERL56) {
73 sub dowarn {}; 73 sub dowarn {};
74 $SVt_PV = 4; 74 $SVt_PV = 4;
75 $SVt_PVGV = 13; 75 $SVt_PVGV = 13;
76 $SVf_FAKE = 0x00100000; 76 $SVf_FAKE = 0x00100000;
77 $POK = 0x00040000 | 0x04000000; 77 $POK = 0x00040000 | 0x04000000;
78 sub MAGICAL56 { $_[0]->FLAGS & 0x000E000 } #(SVs_GMG|SVs_SMG|SVs_RMG) 78 sub MAGICAL56 { $_[0]->FLAGS & 0x000E000 } #(SVs_GMG|SVs_SMG|SVs_RMG)
79 } else { 79 } else {
80 no strict 'subs'; 80 no strict 'subs';
81 $SVt_PV = 4; 81 $SVt_PV = 4;
82 $SVt_PVGV = SVt_PVGV; 82 $SVt_PVGV = SVt_PVGV;
83 $SVf_FAKE = SVf_FAKE; 83 $SVf_FAKE = SVf_FAKE;
84 } 84 }
85 for ( my $i = 0 ; $i < @optype ; $i++ ) { 85 for ( my $i = 0 ; $i < @optype ; $i++ ) {
86 $optype_enum{ $optype[$i] } = $i; 86 $optype_enum{ $optype[$i] } = $i;
87 } 87 }
88 88
89 BEGIN { 89 BEGIN {
90 my $ithreads = $Config{'useithreads'} eq 'define'; 90 my $ithreads = $Config{'useithreads'} eq 'define';
91 eval qq{ 91 eval qq{
92 sub ITHREADS() { $ithreads } 92 sub ITHREADS() { $ithreads }
93 sub VERSION() { $] } 93 sub VERSION() { $] }
94 }; 94 };
95 die $@ if $@; 95 die $@ if $@;
96 } 96 }
97 97
98 sub ashex {$quiet ? undef : sprintf("0x%x",shift)} 98 sub as_hex {$quiet ? undef : sprintf("0x%x",shift)}
99 99
100 ################################################# 100 #################################################
101 101
102 # This is for -S commented assembler output 102 # This is for -S commented assembler output
103 sub op_flags { 103 sub op_flags {
104 return '' if $quiet; 104 return '' if $quiet;
105 # B::Concise::op_flags($_[0]); # too terse 105 # B::Concise::op_flags($_[0]); # too terse
106 # common flags (see BASOP.op_flags in op.h) 106 # common flags (see BASOP.op_flags in op.h)
107 my ($x) = @_; 107 my ($x) = @_;
108 my (@v); 108 my (@v);
109 push @v, "WANT_VOID" if ( $x & 3 ) == 1; 109 push @v, "WANT_VOID" if ( $x & 3 ) == 1;
110 push @v, "WANT_SCALAR" if ( $x & 3 ) == 2; 110 push @v, "WANT_SCALAR" if ( $x & 3 ) == 2;
111 push @v, "WANT_LIST" if ( $x & 3 ) == 3; 111 push @v, "WANT_LIST" if ( $x & 3 ) == 3;
112 push @v, "KIDS" if $x & 4; 112 push @v, "KIDS" if $x & 4;
113 push @v, "PARENS" if $x & 8; 113 push @v, "PARENS" if $x & 8;
114 push @v, "REF" if $x & 16; 114 push @v, "REF" if $x & 16;
115 push @v, "MOD" if $x & 32; 115 push @v, "MOD" if $x & 32;
116 push @v, "STACKED" if $x & 64; 116 push @v, "STACKED" if $x & 64;
117 push @v, "SPECIAL" if $x & 128; 117 push @v, "SPECIAL" if $x & 128;
118 return join( ",", @v ); 118 return join( ",", @v );
119 } 119 }
120 120
121 # This is also for -S commented assembler output 121 # This is also for -S commented assembler output
122 sub sv_flags { 122 sub sv_flags {
123 return '' if $quiet or $B::Concise::VERSION < 0.74; # or ($] == 5.010); 123 return '' if $quiet or $B::Concise::VERSION < 0.74; # or ($] == 5.010);
124 return '' unless $debug{Comment}; 124 return '' unless $debug{Comment};
125 return 'B::SPECIAL' if $_[0]->isa('B::SPECIAL'); 125 return 'B::SPECIAL' if $_[0]->isa('B::SPECIAL');
126 return 'B::PADLIST' if $_[0]->isa('B::PADLIST');
126 my ($sv) = @_; 127 my ($sv) = @_;
127 my %h; 128 my %h;
128 129
129 # TODO: Check with which Concise and B versions this works. 5.10.0 fails. 130 # TODO: Check with which Concise and B versions this works. 5.10.0 fails.
130 # B::Concise 0.66 fails also 131 # B::Concise 0.66 fails also
131 sub B::Concise::fmt_line { return shift; } 132 sub B::Concise::fmt_line { return shift; }
132 %h = B::Concise::concise_op( $ops{ $tix - 1 } ) if ref $ops{ $tix - 1 }; 133 %h = B::Concise::concise_op( $ops{ $tix - 1 } ) if ref $ops{ $tix - 1 };
133 B::Concise::concise_sv( $_[0], \%h, 0 ); 134 B::Concise::concise_sv( $_[0], \%h, 0 );
134 } 135 }
135 136
136 sub pvstring { 137 sub pvstring {
137 my $pv = shift; 138 my $pv = shift;
138 defined($pv) ? cstring( $pv . "\0" ) : "\"\""; 139 defined($pv) ? cstring( $pv . "\0" ) : "\"\"";
139 } 140 }
140 141
141 sub pvix { 142 sub pvix {
142 my $str = pvstring shift; 143 my $str = pvstring shift;
143 my $ix = $strtab{$str}; 144 my $ix = $strtab{$str};
144 defined($ix) ? $ix : do { 145 defined($ix) ? $ix : do {
145 nice1 "-PV- $tix"; 146 nice1 "-PV- $tix";
146 B::Assembler::maxsvix($tix) if $debug{A}; 147 B::Assembler::maxsvix($tix) if $debug{A};
147 asm "newpv", $str; 148 asm "newpv", $str;
148 asm "stpv", $strtab{$str} = $tix; 149 asm "stpv", $strtab{$str} = $tix;
149 $tix++; 150 $tix++;
150 } 151 }
151 } 152 }
152 153
153 sub B::OP::ix { 154 sub B::OP::ix {
154 my $op = shift; 155 my $op = shift;
155 my $ix = $optab{$$op}; 156 my $ix = $optab{$$op};
156 defined($ix) ? $ix : do { 157 defined($ix) ? $ix : do {
157 nice "[" . $op->name . " $tix]"; 158 nice "[" . $op->name . " $tix]";
158 $ops{$tix} = $op; 159 $ops{$tix} = $op;
159 # Note: This left-shift 7 encoding of the optype has nothing to do with OCSHIFT 160 # Note: This left-shift 7 encoding of the optype has nothing to do with OCSHIFT
160 # in opcode.pl 161 # in opcode.pl
161 # The counterpart is hardcoded in Byteloader/bytecode.h: BSET_newopx 162 # The counterpart is hardcoded in Byteloader/bytecode.h: BSET_newopx
162 my $arg = $PERL56 ? $optype_enum{class($op)} : $op->size | $op->type << 7; 163 my $arg = $PERL56 ? $optype_enum{class($op)} : $op->size | $op->type << 7;
163 my $opsize = $PERL56 ? '?' : $op->size; 164 my $opsize = $PERL56 ? '?' : $op->size;
164 if (ref($op) eq 'B::OP') { # check wrong BASEOPs 165 if (ref($op) eq 'B::OP') { # check wrong BASEOPs
165 # [perl #80622] Introducing the entrytry hack, needed since 5.12, 166 # [perl #80622] Introducing the entrytry hack, needed since 5.12,
166 # fixed with 5.13.8 a425677 167 # fixed with 5.13.8 a425677
167 # ck_eval upgrades the UNOP entertry to a LOGOP, but B gets us just a 168 # ck_eval upgrades the UNOP entertry to a LOGOP, but B gets us just a
168 # B::OP (BASEOP). 169 # B::OP (BASEOP).
169 # op->other points to the leavetry op, which is needed for the eval scope. 170 # op->other points to the leavetry op, which is needed for the eval scope.
170 if ($op->name eq 'entertry') { 171 if ($op->name eq 'entertry') {
171 $opsize = $op->size + (2*$Config{ptrsize}); 172 $opsize = $op->size + (2*$Config{ptrsize});
172 $arg = $PERL56 ? $optype_enum{LOGOP} : $opsize | $optype_enum{LOGOP} << 7; 173 $arg = $PERL56 ? $optype_enum{LOGOP} : $opsize | $optype_enum{LOGOP} << 7;
173 warn "[perl #80622] Upgrading entertry from BASEOP to LOGOP...\n" 174 warn "[perl #80622] Upgrading entertry from BASEOP to LOGOP...\n"
174 unless $quiet; 175 unless $quiet;
175 bless $op, 'B::LOGOP'; 176 bless $op, 'B::LOGOP';
176 } elsif ($op->name eq 'aelemfast') { 177 } elsif ($op->name eq 'aelemfast') {
177 if (0) { 178 if (0) {
178 my $class = ITHREADS ? 'PADOP' : 'SVOP'; 179 my $class = ITHREADS ? 'PADOP' : 'SVOP';
179 my $type = ITHREADS ? $optype_enum{PADOP} : $optype_enum{SVOP}; 180 my $type = ITHREADS ? $optype_enum{PADOP} : $optype_enum{SVOP};
180 $opsize = $op->size + $Config{ptrsize}; 181 $opsize = $op->size + $Config{ptrsize};
181 $arg = $PERL56 ? $type : $opsize | $type << 7; 182 $arg = $PERL56 ? $type : $opsize | $type << 7;
182 warn "Upgrading aelemfast from BASEOP to $class...\n" 183 warn "Upgrading aelemfast from BASEOP to $class...\n"
183 unless $quiet; 184 unless $quiet;
184 bless $op, "B::$class"; 185 bless $op, "B::$class";
185 } 186 }
186 } elsif ($DEBUGGING) { # only needed when we want to check for new wrong BASEOP's 187 } elsif ($DEBUGGING) { # only needed when we want to check for new wrong BASEOP's
187 if (eval "require Opcodes;") { 188 if (eval "require Opcodes;") {
188 my $class = Opcodes::opclass($op->type); 189 my $class = Opcodes::opclass($op->type);
189 if ($class > 0) { 190 if ($class > 0) {
190 my $classname = $optype[$class]; 191 my $classname = $optype[$class];
191 my $name = $op->name; 192 my $name = $op->name;
192 warn "Upgrading $name BASEOP to $classname...\n" if $classname and !$quiet; 193 warn "Upgrading $name BASEOP to $classname...\n" if $classname and !$quiet;
193 bless $op, "B::".$classname if $classname; 194 bless $op, "B::".$classname if $classname;
194 } 195 }
195 } 196 }
196 } 197 }
197 } 198 }
198 B::Assembler::maxopix($tix) if $debug{A}; 199 B::Assembler::maxopix($tix) if $debug{A};
199 asm "newopx", $arg, sprintf( "$arg=size:%s,type:%d", $opsize, $op->type ); 200 asm "newopx", $arg, sprintf( "$arg=size:%s,type:%d", $opsize, $op->type );
200 asm "stop", $tix if $PERL56; 201 asm "stop", $tix if $PERL56;
201 $optab{$$op} = $opix = $ix = $tix++; 202 $optab{$$op} = $opix = $ix = $tix++;
202 $op->bsave($ix); 203 $op->bsave($ix);
203 $ix; 204 $ix;
204 } 205 }
205 } 206 }
206 207
207 sub B::SPECIAL::ix { 208 sub B::SPECIAL::ix {
208 my $spec = shift; 209 my $spec = shift;
209 my $ix = $spectab{$$spec}; 210 my $ix = $spectab{$$spec};
210 defined($ix) ? $ix : do { 211 defined($ix) ? $ix : do {
211 B::Assembler::maxsvix($tix) if $debug{A}; 212 B::Assembler::maxsvix($tix) if $debug{A};
212 nice "[SPECIAL $tix]"; 213 nice "[SPECIAL $tix]";
213 asm "ldspecsvx", $$spec, $specialsv_name[$$spec]; 214 asm "ldspecsvx", $$spec, $specialsv_name[$$spec];
214 asm "stsv", $tix if $PERL56; 215 asm "stsv", $tix if $PERL56;
215 $spectab{$$spec} = $varix = $tix++; 216 $spectab{$$spec} = $varix = $tix++;
216 } 217 }
217 } 218 }
218 219
219 sub B::SV::ix { 220 sub B::SV::ix {
220 my $sv = shift; 221 my $sv = shift;
221 my $ix = $svtab{$$sv}; 222 my $ix = $svtab{$$sv};
222 defined($ix) ? $ix : do { 223 defined($ix) ? $ix : do {
223 nice '[' . class($sv) . " $tix]"; 224 nice '[' . class($sv) . " $tix]";
224 B::Assembler::maxsvix($tix) if $debug{A}; 225 B::Assembler::maxsvix($tix) if $debug{A};
225 my $type = $sv->FLAGS & 0xff; # SVTYPEMASK 226 my $type = $sv->FLAGS & 0xff; # SVTYPEMASK
226 asm "newsvx", $sv->FLAGS, 227 asm "newsvx", $sv->FLAGS,
227 $debug{Comment} ? sprintf("type=%d,flags=0x%x,%s", $type, $sv->FLAGS,sv_flags($sv)) : ''; 228 $debug{Comment} ? sprintf("type=%d,flags=0x%x,%s", $type, $sv->FLAGS,sv_flags($sv)) : '';
228 asm "stsv", $tix if $PERL56; 229 asm "stsv", $tix if $PERL56;
229 $svtab{$$sv} = $varix = $ix = $tix++; 230 $svtab{$$sv} = $varix = $ix = $tix++;
230 #nice "\tsvtab ".$$sv." => bsave(".$ix."); 231 #nice "\tsvtab ".$$sv." => bsave(".$ix.");
231 $sv->bsave($ix); 232 $sv->bsave($ix);
232 $ix; 233 $ix;
233 } 234 }
234 } 235 }
235 236
236 sub B::PADLIST::ix { 237 sub B::PADLIST::ix {
237 my $sv = shift; 238 my $sv = shift;
238 my $ix = $svtab{$$sv}; 239 my $ix = $svtab{$$sv};
239 defined($ix) ? $ix : do { 240 defined($ix) ? $ix : do {
240 nice '[' . class($sv) . " $tix]"; 241 nice '[' . class($sv) . " $tix]";
241 B::Assembler::maxsvix($tix) if $debug{A}; 242 B::Assembler::maxsvix($tix) if $debug{A};
242 my $type = 0xff; # SVTYPEMASK 243 my $type = 0xff; # SVTYPEMASK
243 asm "newsvx", 0, 244 asm "newsvx", 0,
244 $debug{Comment} ? sprintf("type=%d", $type) : ""; 245 $debug{Comment} ? sprintf("type=%d", $type) : "";
245 asm "stsv", $tix if $PERL56; 246 asm "stsv", $tix if $PERL56;
246 $svtab{$$sv} = $varix = $ix = $tix++; 247 $svtab{$$sv} = $varix = $ix = $tix++;
247 $sv->bsave($ix); 248 $sv->bsave($ix);
248 $ix; 249 $ix;
249 } 250 }
250 } 251 }
251 252
252 sub B::GV::ix { 253 sub B::GV::ix {
253 my ( $gv, $desired ) = @_; 254 my ( $gv, $desired ) = @_;
254 my $ix = $svtab{$$gv}; 255 my $ix = $svtab{$$gv};
255 defined($ix) ? $ix : do { 256 defined($ix) ? $ix : do {
256 if ( $debug{G} and !$PERL510 ) { 257 if ( $debug{G} and !$PERL510 ) {
257 select *STDERR; 258 select *STDERR;
258 eval "require B::Debug;"; 259 eval "require B::Debug;";
259 $gv->B::GV::debug; 260 $gv->B::GV::debug;
260 select *STDOUT; 261 select *STDOUT;
261 } 262 }
262 if ( ( $PERL510 and $gv->isGV_with_GP ) 263 if ( ( $PERL510 and $gv->isGV_with_GP )
263 or ( !$PERL510 and !$PERL56 and $gv->GP ) ) 264 or ( !$PERL510 and !$PERL56 and $gv->GP ) )
264 { # only gv with gp 265 { # only gv with gp
265 my ( $svix, $avix, $hvix, $cvix, $ioix, $formix ); 266 my ( $svix, $avix, $hvix, $cvix, $ioix, $formix );
266 # 510 without debugging misses B::SPECIAL::NAME 267 # 510 without debugging misses B::SPECIAL::NAME
267 my $name; 268 my $name;
268 if ( $PERL510 269 if ( $PERL510
269 and ( $gv->STASH->isa('B::SPECIAL') or $gv->isa('B::SPECIAL') ) ) 270 and ( $gv->STASH->isa('B::SPECIAL') or $gv->isa('B::SPECIAL') ) )
270 { 271 {
271 $name = '_'; 272 $name = '_';
272 nice '[GV] # "_"'; 273 nice '[GV] # "_"';
273 return 0; 274 return 0;
274 } 275 }
275 else { 276 else {
276 $name = $gv->STASH->NAME . "::" 277 $name = $gv->STASH->NAME . "::"
277 . ( class($gv) eq 'B::SPECIAL' ? '_' : $gv->NAME ); 278 . ( class($gv) eq 'B::SPECIAL' ? '_' : $gv->NAME );
278 } 279 }
279 nice "[GV $tix]"; 280 nice "[GV $tix]";
280 B::Assembler::maxsvix($tix) if $debug{A}; 281 B::Assembler::maxsvix($tix) if $debug{A};
281 asm "gv_fetchpvx", cstring $name; 282 asm "gv_fetchpvx", cstring $name;
282 asm "stsv", $tix if $PERL56; 283 asm "stsv", $tix if $PERL56;
283 $svtab{$$gv} = $varix = $ix = $tix++; 284 $svtab{$$gv} = $varix = $ix = $tix++;
284 asm "sv_flags", $gv->FLAGS, ashex($gv->FLAGS); 285 asm "sv_flags", $gv->FLAGS, as_hex($gv->FLAGS);
285 asm "sv_refcnt", $gv->REFCNT; 286 asm "sv_refcnt", $gv->REFCNT;
286 asm "xgv_flags", $gv->GvFLAGS, ashex($gv->GvFLAGS); 287 asm "xgv_flags", $gv->GvFLAGS, as_hex($gv->GvFLAGS);
287 288
288 asm "gp_refcnt", $gv->GvREFCNT; 289 asm "gp_refcnt", $gv->GvREFCNT;
289 asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob"; 290 asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
290 return $ix 291 return $ix
291 unless $desired || desired $gv; 292 unless $desired || desired $gv;
292 $svix = $gv->SV->ix; 293 $svix = $gv->SV->ix;
293 $avix = $gv->AV->ix; 294 $avix = $gv->AV->ix;
294 $hvix = $gv->HV->ix; 295 $hvix = $gv->HV->ix;
295 296
296 # XXX {{{{ 297 # XXX {{{{
297 my $cv = $gv->CV; 298 my $cv = $gv->CV;
298 $cvix = $$cv && defined $files{ $cv->FILE } ? $cv->ix : 0; 299 $cvix = $$cv && defined $files{ $cv->FILE } ? $cv->ix : 0;
299 my $form = $gv->FORM; 300 my $form = $gv->FORM;
300 $formix = $$form && defined $files{ $form->FILE } ? $form->ix : 0; 301 $formix = $$form && defined $files{ $form->FILE } ? $form->ix : 0;
301 302
302 $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0; 303 $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
303 304
304 # }}}} XXX 305 # }}}} XXX
305 306
306 nice1 "-GP-", asm "ldsv", $varix = $ix, sv_flags($gv) unless $ix == $varix; 307 nice1 "-GP-", asm "ldsv", $varix = $ix, sv_flags($gv) unless $ix == $varix;
307 asm "gp_sv", $svix, sv_flags( $gv->SV ); 308 asm "gp_sv", $svix, sv_flags( $gv->SV );
308 asm "gp_av", $avix, sv_flags( $gv->AV ); 309 asm "gp_av", $avix, sv_flags( $gv->AV );
309 asm "gp_hv", $hvix, sv_flags( $gv->HV ); 310 asm "gp_hv", $hvix, sv_flags( $gv->HV );
310 asm "gp_cv", $cvix, sv_flags( $gv->CV ); 311 asm "gp_cv", $cvix, sv_flags( $gv->CV );
311 asm "gp_io", $ioix; 312 asm "gp_io", $ioix;
312 asm "gp_cvgen", $gv->CVGEN; 313 asm "gp_cvgen", $gv->CVGEN;
313 asm "gp_form", $formix; 314 asm "gp_form", $formix;
314 asm "gp_file", pvix $gv->FILE; 315 asm "gp_file", pvix $gv->FILE;
315 asm "gp_line", $gv->LINE; 316 asm "gp_line", $gv->LINE;
316 asm "formfeed", $svix if $name eq "main::\cL"; 317 asm "formfeed", $svix if $name eq "main::\cL";
317 } 318 }
318 else { 319 else {
319 nice "[GV $tix]"; 320 nice "[GV $tix]";
320 B::Assembler::maxsvix($tix) if $debug{A}; 321 B::Assembler::maxsvix($tix) if $debug{A};
321 asm "newsvx", $gv->FLAGS, $debug{Comment} ? sv_flags($gv) : ''; 322 asm "newsvx", $gv->FLAGS, $debug{Comment} ? sv_flags($gv) : '';
322 asm "stsv", $tix if $PERL56; 323 asm "stsv", $tix if $PERL56;
323 $svtab{$$gv} = $varix = $ix = $tix++; 324 $svtab{$$gv} = $varix = $ix = $tix++;
324 if ( !$PERL510 ) { 325 if ( !$PERL510 ) {
325 #GV_without_GP has no GvFlags 326 #GV_without_GP has no GvFlags
326 asm "xgv_flags", $gv->GvFLAGS; 327 asm "xgv_flags", $gv->GvFLAGS;
327 } 328 }
328 if ( !$PERL510 and !$PERL56 and $gv->STASH ) { 329 if ( !$PERL510 and !$PERL56 and $gv->STASH ) {
329 my $stashix = $gv->STASH->ix; 330 my $stashix = $gv->STASH->ix;
330 asm "xgv_stash", $stashix; 331 asm "xgv_stash", $stashix;
331 } 332 }
332 if ($PERL510 and $gv->FLAGS & 0x40000000) { # SVpbm_VALID 333 if ($PERL510 and $gv->FLAGS & 0x40000000) { # SVpbm_VALID
333 my $bm = bless $gv, "B::BM"; 334 my $bm = bless $gv, "B::BM";
334 $bm->bsave($ix); # also saves magic 335 $bm->bsave($ix); # also saves magic
335 } else { 336 } else {
336 $gv->B::PVMG::bsave($ix); 337 $gv->B::PVMG::bsave($ix);
337 } 338 }
338 } 339 }
339 $ix; 340 $ix;
340 } 341 }
341 } 342 }
342 343
343 sub B::HV::ix { 344 sub B::HV::ix {
344 my $hv = shift; 345 my $hv = shift;
345 my $ix = $svtab{$$hv}; 346 my $ix = $svtab{$$hv};
346 defined($ix) ? $ix : do { 347 defined($ix) ? $ix : do {
347 my ( $ix, $i, @array ); 348 my ( $ix, $i, @array );
348 my $name = $hv->NAME; 349 my $name = $hv->NAME;
349 if ($name) { 350 if ($name) {
350 nice "[STASH $tix]"; 351 nice "[STASH $tix]";
351 B::Assembler::maxsvix($tix) if $debug{A}; 352 B::Assembler::maxsvix($tix) if $debug{A};
352 asm "gv_stashpvx", cstring $name; 353 asm "gv_stashpvx", cstring $name;
353 asm "ldsv", $tix if $PERL56; 354 asm "ldsv", $tix if $PERL56;
354 asm "sv_flags", $hv->FLAGS, ashex($hv->FLAGS); 355 asm "sv_flags", $hv->FLAGS, as_hex($hv->FLAGS);
355 $svtab{$$hv} = $varix = $ix = $tix++; 356 $svtab{$$hv} = $varix = $ix = $tix++;
356 asm "xhv_name", pvix $name; 357 asm "xhv_name", pvix $name;
357 358
358 # my $pmrootix = $hv->PMROOT->ix; # XXX 359 # my $pmrootix = $hv->PMROOT->ix; # XXX
359 asm "ldsv", $varix = $ix unless $ix == $varix; 360 asm "ldsv", $varix = $ix unless $ix == $varix;
360 # asm "xhv_pmroot", $pmrootix; # XXX 361 # asm "xhv_pmroot", $pmrootix; # XXX
361 } 362 }
362 else { 363 else {
363 nice "[HV $tix]"; 364 nice "[HV $tix]";
364 B::Assembler::maxsvix($tix) if $debug{A}; 365 B::Assembler::maxsvix($tix) if $debug{A};
365 asm "newsvx", $hv->FLAGS, $debug{Comment} ? sv_flags($hv) : ''; 366 asm "newsvx", $hv->FLAGS, $debug{Comment} ? sv_flags($hv) : '';
366 asm "stsv", $tix if $PERL56; 367 asm "stsv", $tix if $PERL56;
367 $svtab{$$hv} = $varix = $ix = $tix++; 368 $svtab{$$hv} = $varix = $ix = $tix++;
368 my $stashix = $hv->SvSTASH->ix; 369 my $stashix = $hv->SvSTASH->ix;
369 for ( @array = $hv->ARRAY ) { 370 for ( @array = $hv->ARRAY ) {
370 next if $i = not $i; 371 next if $i = not $i;
371 $_ = $_->ix; 372 $_ = $_->ix;
372 } 373 }
373 nice1 "-HV-", asm "ldsv", $varix = $ix unless $ix == $varix; 374 nice1 "-HV-", asm "ldsv", $varix = $ix unless $ix == $varix;
374 ( $i = not $i ) ? asm( "newpv", pvstring $_) : asm( "hv_store", $_ ) 375 ( $i = not $i ) ? asm( "newpv", pvstring $_) : asm( "hv_store", $_ )
375 for @array; 376 for @array;
376 if ( VERSION < 5.009 ) { 377 if ( VERSION < 5.009 ) {
377 asm "xnv", $hv->NVX; 378 asm "xnv", $hv->NVX;
378 } 379 }
379 asm "xmg_stash", $stashix; 380 asm "xmg_stash", $stashix;
380 asm( "xhv_riter", $hv->RITER ) if VERSION < 5.009; 381 asm( "xhv_riter", $hv->RITER ) if VERSION < 5.009;
381 } 382 }
382 asm "sv_refcnt", $hv->REFCNT; 383 asm "sv_refcnt", $hv->REFCNT;
383 $ix; 384 $ix;
384 } 385 }
385 } 386 }
386 387
387 sub B::NULL::ix { 388 sub B::NULL::ix {
388 my $sv = shift; 389 my $sv = shift;
389 $$sv ? $sv->B::SV::ix : 0; 390 $$sv ? $sv->B::SV::ix : 0;
390 } 391 }
391 392
392 sub B::NULL::opwalk { 0 } 393 sub B::NULL::opwalk { 0 }
393 394
394 ################################################# 395 #################################################
395 396
396 sub B::NULL::bsave { 397 sub B::NULL::bsave {
397 my ( $sv, $ix ) = @_; 398 my ( $sv, $ix ) = @_;
398 399
399 nice '-' . class($sv) . '-', asm "ldsv", $varix = $ix, sv_flags($sv) 400 nice '-' . class($sv) . '-', asm "ldsv", $varix = $ix, sv_flags($sv)
400 unless $ix == $varix; 401 unless $ix == $varix;
401 if ($PERL56) { 402 if ($PERL56) {
402 asm "stsv", $ix; 403 asm "stsv", $ix;
403 } else { 404 } else {
404 asm "sv_refcnt", $sv->REFCNT; 405 asm "sv_refcnt", $sv->REFCNT;
405 } 406 }
406 } 407 }
407 408
408 sub B::SV::bsave; 409 sub B::SV::bsave;
409 *B::SV::bsave = *B::NULL::bsave; 410 *B::SV::bsave = *B::NULL::bsave;
410 411
411 sub B::RV::bsave { 412 sub B::RV::bsave {
412 my ( $sv, $ix ) = @_; 413 my ( $sv, $ix ) = @_;
413 my $rvix = $sv->RV->ix; 414 my $rvix = $sv->RV->ix;
414 $sv->B::NULL::bsave($ix); 415 $sv->B::NULL::bsave($ix);
415 # RV with DEBUGGING already requires sv_flags before SvRV_set 416 # RV with DEBUGGING already requires sv_flags before SvRV_set
416 asm "sv_flags", $sv->FLAGS, ashex($sv->FLAGS); 417 asm "sv_flags", $sv->FLAGS, as_hex($sv->FLAGS);
417 asm "xrv", $rvix; 418 asm "xrv", $rvix;
418 } 419 }
419 420
420 sub B::PV::bsave { 421 sub B::PV::bsave {
421 my ( $sv, $ix ) = @_; 422 my ( $sv, $ix ) = @_;
422 $sv->B::NULL::bsave($ix); 423 $sv->B::NULL::bsave($ix);
423 if ($PERL56) { 424 if ($PERL56) {
424 #$sv->B::SV::bsave; 425 #$sv->B::SV::bsave;
425 if ($sv->FLAGS & $POK) { 426 if ($sv->FLAGS & $POK) {
426 asm "newpv", pvstring $sv->PV ; 427 asm "newpv", pvstring $sv->PV ;
427 asm "xpv"; 428 asm "xpv";
428 } 429 }
429 } elsif ($PERL510 and $sv and ($sv->FLAGS & 0x09000000) == 0x09000000) { # 42 430 } elsif ($PERL510 and $sv and ($sv->FLAGS & 0x09000000) == 0x09000000) { # 42
430 asm "newpv", pvstring $sv->PVBM; 431 asm "newpv", pvstring $sv->PVBM;
431 asm "xpvshared"; 432 asm "xpvshared";
432 } else { 433 } else {
433 asm "newpv", pvstring $sv->PVBM; 434 asm "newpv", pvstring $sv->PVBM;
434 asm "xpv"; 435 asm "xpv";
435 } 436 }
436 } 437 }
437 438
438 sub B::IV::bsave { 439 sub B::IV::bsave {
439 my ( $sv, $ix ) = @_; 440 my ( $sv, $ix ) = @_;
440 return $sv->B::RV::bsave($ix) 441 return $sv->B::RV::bsave($ix)
441 if $PERL512 and $sv->FLAGS & B::SVf_ROK; 442 if $PERL512 and $sv->FLAGS & B::SVf_ROK;
442 $sv->B::NULL::bsave($ix); 443 $sv->B::NULL::bsave($ix);
443 if ($PERL56) { 444 if ($PERL56) {
444 asm $sv->needs64bits ? "xiv64" : "xiv32", $sv->IVX; 445 asm $sv->needs64bits ? "xiv64" : "xiv32", $sv->IVX;
445 } else { 446 } else {
446 asm "xiv", $sv->IVX; 447 asm "xiv", $sv->IVX;
447 } 448 }
448 } 449 }
449 450
450 sub B::NV::bsave { 451 sub B::NV::bsave {
451 my ( $sv, $ix ) = @_; 452 my ( $sv, $ix ) = @_;
452 $sv->B::NULL::bsave($ix); 453 $sv->B::NULL::bsave($ix);
453 asm "xnv", sprintf "%.40g", $sv->NVX; 454 asm "xnv", sprintf "%.40g", $sv->NVX;
454 } 455 }
455 456
456 sub B::PVIV::bsave { 457 sub B::PVIV::bsave {
457 my ( $sv, $ix ) = @_; 458 my ( $sv, $ix ) = @_;
458 if ($PERL56) { 459 if ($PERL56) {
459 $sv->B::PV::bsave($ix); 460 $sv->B::PV::bsave($ix);
460 } else { 461 } else {
461 $sv->POK ? $sv->B::PV::bsave($ix) 462 $sv->POK ? $sv->B::PV::bsave($ix)
462 : $sv->ROK ? $sv->B::RV::bsave($ix) 463 : $sv->ROK ? $sv->B::RV::bsave($ix)
463 : $sv->B::NULL::bsave($ix); 464 : $sv->B::NULL::bsave($ix);
464 } 465 }
465 if ($PERL510) { # See note below in B::PVNV::bsave 466 if ($PERL510) { # See note below in B::PVNV::bsave
466 return if $sv->isa('B::AV'); 467 return if $sv->isa('B::AV');
467 return if $sv->isa('B::HV'); 468 return if $sv->isa('B::HV');
468 return if $sv->isa('B::CV'); 469 return if $sv->isa('B::CV');
469 return if $sv->isa('B::GV'); 470 return if $sv->isa('B::GV');
470 return if $sv->isa('B::IO'); 471 return if $sv->isa('B::IO');
471 return if $sv->isa('B::FM'); 472 return if $sv->isa('B::FM');
472 } 473 }
473 bwarn( sprintf( "PVIV sv:%s flags:0x%x", class($sv), $sv->FLAGS ) ) 474 bwarn( sprintf( "PVIV sv:%s flags:0x%x", class($sv), $sv->FLAGS ) )
474 if $debug{M}; 475 if $debug{M};
475 476
476 if ($PERL56) { 477 if ($PERL56) {
477 my $iv = $sv->IVX; 478 my $iv = $sv->IVX;
478 asm $sv->needs64bits ? "xiv64" : "xiv32", $iv; 479 asm $sv->needs64bits ? "xiv64" : "xiv32", $iv;
479 } else { 480 } else {
480 # PVIV GV 8009, GV flags & (4000|8000) illegal (SVpgv_GP|SVp_POK) 481 # PVIV GV 8009, GV flags & (4000|8000) illegal (SVpgv_GP|SVp_POK)
481 asm "xiv", !ITHREADS 482 asm "xiv", !ITHREADS
482 && $sv->FLAGS & ( $SVf_FAKE | SVf_READONLY ) ? "0 # but true" : $sv->IVX; 483 && $sv->FLAGS & ( $SVf_FAKE | SVf_READONLY ) ? "0 # but true" : $sv->IVX;
483 } 484 }
484 } 485 }
485 486
486 sub B::PVNV::bsave { 487 sub B::PVNV::bsave {
487 my ( $sv, $ix ) = @_; 488 my ( $sv, $ix ) = @_;
488 $sv->B::PVIV::bsave($ix); 489 $sv->B::PVIV::bsave($ix);
489 if ($PERL510) { 490 if ($PERL510) {
490 # getting back to PVMG 491 # getting back to PVMG
491 return if $sv->isa('B::AV'); 492 return if $sv->isa('B::AV');
492 return if $sv->isa('B::HV'); 493 return if $sv->isa('B::HV');
493 return if $sv->isa('B::CV'); 494 return if $sv->isa('B::CV');
494 return if $sv->isa('B::FM'); 495 return if $sv->isa('B::FM');
495 return if $sv->isa('B::GV'); 496 return if $sv->isa('B::GV');
496 return if $sv->isa('B::IO'); 497 return if $sv->isa('B::IO');
497 498
498 # cop_seq range instead of a double. (IV, NV) 499 # cop_seq range instead of a double. (IV, NV)
499 unless ($sv->FLAGS & (SVf_NOK|SVp_NOK)) { 500 unless ($sv->FLAGS & (SVf_NOK|SVp_NOK)) {
500 asm "cop_seq_low", $sv->COP_SEQ_RANGE_LOW; 501 asm "cop_seq_low", $sv->COP_SEQ_RANGE_LOW;
501 asm "cop_seq_high", $sv->COP_SEQ_RANGE_HIGH; 502 asm "cop_seq_high", $sv->COP_SEQ_RANGE_HIGH;
502 return; 503 return;
503 } 504 }
504 } 505 }
505 asm "xnv", sprintf "%.40g", $sv->NVX; 506 asm "xnv", sprintf "%.40g", $sv->NVX;
506 } 507 }
507 508
508 sub B::PVMG::domagic { 509 sub B::PVMG::domagic {
509 my ( $sv, $ix ) = @_; 510 my ( $sv, $ix ) = @_;
510 nice1 '-MAGICAL-'; # no empty line before 511 nice1 '-MAGICAL-'; # no empty line before
511 my @mglist = $sv->MAGIC; 512 my @mglist = $sv->MAGIC;
512 my ( @mgix, @namix ); 513 my ( @mgix, @namix );
513 for (@mglist) { 514 for (@mglist) {
514 push @mgix, $_->OBJ->ix; 515 push @mgix, $_->OBJ->ix;
515 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY; 516 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
516 } 517 }
517 518
518 nice1 '-' . class($sv) . '-', asm "ldsv", $varix = $ix unless $ix == $varix; 519 nice1 '-' . class($sv) . '-', asm "ldsv", $varix = $ix unless $ix == $varix;
519 for (@mglist) { 520 for (@mglist) {
520 next unless ord($_->TYPE); 521 next unless ord($_->TYPE);
521 asm "sv_magic", ord($_->TYPE), cstring $_->TYPE; 522 asm "sv_magic", ord($_->TYPE), cstring $_->TYPE;
522 asm "mg_obj", shift @mgix; # D sets itself, see mg.c:mg_copy 523 asm "mg_obj", shift @mgix; # D sets itself, see mg.c:mg_copy
523 my $length = $_->LENGTH; 524 my $length = $_->LENGTH;
524 if ( $length == B::HEf_SVKEY and !$PERL56) { 525 if ( $length == B::HEf_SVKEY and !$PERL56) {
525 asm "mg_namex", shift @namix; 526 asm "mg_namex", shift @namix;
526 } 527 }
527 elsif ($length) { 528 elsif ($length) {
528 asm "newpv", pvstring $_->PTR; 529 asm "newpv", pvstring $_->PTR;
529 $PERL56 530 $PERL56
530 ? asm "mg_pv" 531 ? asm "mg_pv"
531 : asm "mg_name"; 532 : asm "mg_name";
532 } 533 }
533 } 534 }
534 } 535 }
535 536
536 sub B::PVMG::bsave { 537 sub B::PVMG::bsave {
537 my ( $sv, $ix ) = @_; 538 my ( $sv, $ix ) = @_;
538 my $stashix = $sv->SvSTASH->ix; 539 my $stashix = $sv->SvSTASH->ix;
539 $sv->B::PVNV::bsave($ix); 540 $sv->B::PVNV::bsave($ix);
540 asm "xmg_stash", $stashix; 541 asm "xmg_stash", $stashix;
541 # XXX added SV->MAGICAL to 5.6 for compat 542 # XXX added SV->MAGICAL to 5.6 for compat
542 $sv->domagic($ix) if $PERL56 ? MAGICAL56($sv) : $sv->MAGICAL; 543 $sv->domagic($ix) if $PERL56 ? MAGICAL56($sv) : $sv->MAGICAL;
543 } 544 }
544 545
545 sub B::PVLV::bsave { 546 sub B::PVLV::bsave {
546 my ( $sv, $ix ) = @_; 547 my ( $sv, $ix ) = @_;
547 my $targix = $sv->TARG->ix; 548 my $targix = $sv->TARG->ix;
548 $sv->B::PVMG::bsave($ix); 549 $sv->B::PVMG::bsave($ix);
549 asm "xlv_targ", $targix unless $PERL56; # XXX really? xlv_targ IS defined 550 asm "xlv_targ", $targix unless $PERL56; # XXX really? xlv_targ IS defined
550 asm "xlv_targoff", $sv->TARGOFF; 551 asm "xlv_targoff", $sv->TARGOFF;
551 asm "xlv_targlen", $sv->TARGLEN; 552 asm "xlv_targlen", $sv->TARGLEN;
552 asm "xlv_type", $sv->TYPE; 553 asm "xlv_type", $sv->TYPE;
553 } 554 }
554 555
555 sub B::BM::bsave { 556 sub B::BM::bsave {
556 my ( $sv, $ix ) = @_; 557 my ( $sv, $ix ) = @_;
557 $sv->B::PVMG::bsave($ix); 558 $sv->B::PVMG::bsave($ix);
558 asm "xpv_cur", $sv->CUR if $] > 5.008; 559 asm "xpv_cur", $sv->CUR if $] > 5.008;
559 asm "xbm_useful", $sv->USEFUL; 560 asm "xbm_useful", $sv->USEFUL;
560 asm "xbm_previous", $sv->PREVIOUS; 561 asm "xbm_previous", $sv->PREVIOUS;
561 asm "xbm_rare", $sv->RARE; 562 asm "xbm_rare", $sv->RARE;
562 } 563 }
563 564
564 sub B::IO::bsave { 565 sub B::IO::bsave {
565 my ( $io, $ix ) = @_; 566 my ( $io, $ix ) = @_;
566 my $topix = $io->TOP_GV->ix; 567 my $topix = $io->TOP_GV->ix;
567 my $fmtix = $io->FMT_GV->ix; 568 my $fmtix = $io->FMT_GV->ix;
568 my $bottomix = $io->BOTTOM_GV->ix; 569 my $bottomix = $io->BOTTOM_GV->ix;
569 $io->B::PVMG::bsave($ix); 570 $io->B::PVMG::bsave($ix);
570 asm "xio_lines", $io->LINES; 571 asm "xio_lines", $io->LINES;
571 asm "xio_page", $io->PAGE; 572 asm "xio_page", $io->PAGE;
572 asm "xio_page_len", $io->PAGE_LEN; 573 asm "xio_page_len", $io->PAGE_LEN;
573 asm "xio_lines_left", $io->LINES_LEFT; 574 asm "xio_lines_left", $io->LINES_LEFT;
574 asm "xio_top_name", pvix $io->TOP_NAME; 575 asm "xio_top_name", pvix $io->TOP_NAME;
575 asm "xio_top_gv", $topix; 576 asm "xio_top_gv", $topix;
576 asm "xio_fmt_name", pvix $io->FMT_NAME; 577 asm "xio_fmt_name", pvix $io->FMT_NAME;
577 asm "xio_fmt_gv", $fmtix; 578 asm "xio_fmt_gv", $fmtix;
578 asm "xio_bottom_name", pvix $io->BOTTOM_NAME; 579 asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
579 asm "xio_bottom_gv", $bottomix; 580 asm "xio_bottom_gv", $bottomix;
580 asm "xio_subprocess", $io->SUBPROCESS unless $PERL510; 581 asm "xio_subprocess", $io->SUBPROCESS unless $PERL510;
581 asm "xio_type", ord $io->IoTYPE; 582 asm "xio_type", ord $io->IoTYPE;
582 if ($PERL56) { # do not mess with PerlIO 583 if ($PERL56) { # do not mess with PerlIO
583 asm "xio_flags", $io->IoFLAGS; 584 asm "xio_flags", $io->IoFLAGS;
584 } else { 585 } else {
585 # XXX IOf_NOLINE off was added with 5.8, but not used (?) 586 # XXX IOf_NOLINE off was added with 5.8, but not used (?)
586 asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX IOf_NOLINE 32 587 asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX IOf_NOLINE 32
587 } 588 }
588 # issue93: restore std handles 589 # issue93: restore std handles
589 if (!$PERL56) { 590 if (!$PERL56) {
590 my $o = $io->object_2svref(); 591 my $o = $io->object_2svref();
591 eval "require ".ref($o).";"; 592 eval "require ".ref($o).";";
592 my $fd = $o->fileno(); 593 my $fd = $o->fileno();
593 # use IO::Handle (); 594 # use IO::Handle ();
594 # my $fd = IO::Handle::fileno($o); 595 # my $fd = IO::Handle::fileno($o);
595 bwarn( "io ix=$ix perlio no fileno for ".ref($o) ) if $fd < 0; 596 bwarn( "io ix=$ix perlio no fileno for ".ref($o) ) if $fd < 0;
596 my $i = 0; 597 my $i = 0;
597 foreach (qw(stdin stdout stderr)) { 598 foreach (qw(stdin stdout stderr)) {
598 if ($io->IsSTD($_) or $fd == -$i) { # negative stdout = error 599 if ($io->IsSTD($_) or $fd == -$i) { # negative stdout = error
599 nice1 "-perlio_$_($fd)-"; 600 nice1 "-perlio_$_($fd)-";
600 # bwarn( "io $ix perlio_$_($fd)" ); 601 # bwarn( "io $ix perlio_$_($fd)" );
601 asm "xio_flags", $io->IoFLAGS; 602 asm "xio_flags", $io->IoFLAGS;
602 asm "xio_ifp", $i; 603 asm "xio_ifp", $i;
603 } 604 }
604 $i++; 605 $i++;
605 } 606 }
606 } 607 }
607 } 608 }
608 609
609 sub B::CV::bsave { 610 sub B::CV::bsave {
610 my ( $cv, $ix ) = @_; 611 my ( $cv, $ix ) = @_;
611 my $stashix = $cv->STASH->ix; 612 my $stashix = $cv->STASH->ix;
612 my $gvix = $cv->GV->ix; 613 my $gvix = $cv->GV->ix;
613 my $padlistix = $cv->PADLIST->ix; 614 my $padlistix = $cv->PADLIST->ix;
614 my $outsideix = $cv->OUTSIDE->ix; 615 my $outsideix = $cv->OUTSIDE->ix;
615 my $startix = $cv->START->opwalk; 616 my $startix = $cv->START->opwalk;
616 my $rootix = $cv->ROOT->ix; 617 my $rootix = $cv->ROOT->ix;
617 # TODO 5.14 will need CvGV_set to add backref magic 618 # TODO 5.14 will need CvGV_set to add backref magic
618 my $xsubanyix = ($cv->CONST and !$PERL56) ? $cv->XSUBANY->ix : 0; 619 my $xsubanyix = ($cv->CONST and !$PERL56) ? $cv->XSUBANY->ix : 0;
619 620
620 $cv->B::PVMG::bsave($ix); 621 $cv->B::PVMG::bsave($ix);
621 asm "xcv_stash", $stashix; 622 asm "xcv_stash", $stashix;
622 asm "xcv_start", $startix; 623 asm "xcv_start", $startix;
623 asm "xcv_root", $rootix; 624 asm "xcv_root", $rootix;
624 asm "xcv_xsubany", $xsubanyix unless $PERL56; 625 asm "xcv_xsubany", $xsubanyix unless $PERL56;
625 asm "xcv_padlist", $padlistix; 626 asm "xcv_padlist", $padlistix;
626 asm "xcv_outside", $outsideix; 627 asm "xcv_outside", $outsideix;
627 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ unless $PERL56; 628 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ unless $PERL56;
628 asm "xcv_depth", $cv->DEPTH; 629 asm "xcv_depth", $cv->DEPTH;
629 # add the RC flag if there's no backref magic. eg END (48) 630 # add the RC flag if there's no backref magic. eg END (48)
630 my $cvflags = $cv->CvFLAGS; 631 my $cvflags = $cv->CvFLAGS;
631 $cvflags |= 0x400 if $] >= 5.013 and !$cv->MAGIC; 632 $cvflags |= 0x400 if $] >= 5.013 and !$cv->MAGIC;
632 asm "xcv_flags", $cvflags; 633 asm "xcv_flags", $cvflags;
633 asm "xcv_gv", $gvix; 634 asm "xcv_gv", $gvix;
634 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD 635 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
635 } 636 }
636 637
637 sub B::FM::bsave { 638 sub B::FM::bsave {
638 my ( $form, $ix ) = @_; 639 my ( $form, $ix ) = @_;
639 640
640 $form->B::CV::bsave($ix); 641 $form->B::CV::bsave($ix);
641 asm "xfm_lines", $form->LINES; 642 asm "xfm_lines", $form->LINES;
642 } 643 }
643 644
644 sub B::AV::bsave { 645 sub B::AV::bsave {
645 my ( $av, $ix ) = @_; 646 my ( $av, $ix ) = @_;
646 if (!$PERL56 and $av->MAGICAL) { 647 if (!$PERL56 and $av->MAGICAL) {
647 $av->B::PVMG::bsave($ix); 648 $av->B::PVMG::bsave($ix);
648 for ($av->MAGIC) { 649 for ($av->MAGIC) {
649 return if $_->TYPE eq 'P'; # 'P' tied AV has no ARRAY/FETCHSIZE,..., test 16 650 return if $_->TYPE eq 'P'; # 'P' tied AV has no ARRAY/FETCHSIZE,..., test 16
650 # but e.g. 'I' (@ISA) has 651 # but e.g. 'I' (@ISA) has
651 } 652 }
652 } 653 }
653 my @array = $av->ARRAY; 654 my @array = $av->ARRAY;
654 $_ = $_->ix for @array; # hack. walks the ->ix methods to save the elements 655 $_ = $_->ix for @array; # hack. walks the ->ix methods to save the elements
655 my $stashix = $av->SvSTASH->ix; 656 my $stashix = $av->SvSTASH->ix;
656 nice "-AV-", 657 nice "-AV-",
657 asm "ldsv", $varix = $ix, sv_flags($av) unless $ix == $varix; 658 asm "ldsv", $varix = $ix, sv_flags($av) unless $ix == $varix;
658 659
659 if ($PERL56) { 660 if ($PERL56) {
660 # SvREADONLY_off($av) w PADCONST 661 # SvREADONLY_off($av) w PADCONST
661 asm "sv_flags", $av->FLAGS & ~SVf_READONLY, ashex($av->FLAGS); 662 asm "sv_flags", $av->FLAGS & ~SVf_READONLY, as_hex($av->FLAGS);
662 $av->domagic($ix) if MAGICAL56($av); 663 $av->domagic($ix) if MAGICAL56($av);
663 asm "xav_flags", $av->AvFLAGS, ashex($av->AvFLAGS); 664 asm "xav_flags", $av->AvFLAGS, as_hex($av->AvFLAGS);
664 asm "xav_max", -1; 665 asm "xav_max", -1;
665 asm "xav_fill", -1; 666 asm "xav_fill", -1;
666 if ($av->FILL > -1) { 667 if ($av->FILL > -1) {
667 asm "av_push", $_ for @array; 668 asm "av_push", $_ for @array;
668 } else { 669 } else {
669 asm "av_extend", $av->MAX if $av->MAX >= 0; 670 asm "av_extend", $av->MAX if $av->MAX >= 0;
670 } 671 }
671 asm "sv_flags", $av->FLAGS if $av->FLAGS & SVf_READONLY; # restore flags 672 asm "sv_flags", $av->FLAGS if $av->FLAGS & SVf_READONLY; # restore flags
672 } else { 673 } else {
673 #$av->domagic($ix) if $av->MAGICAL; # XXX need tests for magic arrays 674 #$av->domagic($ix) if $av->MAGICAL; # XXX need tests for magic arrays
674 asm "av_extend", $av->MAX if $av->MAX >= 0; 675 asm "av_extend", $av->MAX if $av->MAX >= 0;
675 asm "av_pushx", $_ for @array; 676 asm "av_pushx", $_ for @array;
676 if ( !$PERL510 ) { # VERSION < 5.009 677 if ( !$PERL510 ) { # VERSION < 5.009
677 asm "xav_flags", $av->AvFLAGS, ashex($av->AvFLAGS); 678 asm "xav_flags", $av->AvFLAGS, as_hex($av->AvFLAGS);
678 } 679 }
679 # asm "xav_alloc", $av->AvALLOC if $] > 5.013002; # XXX new but not needed 680 # asm "xav_alloc", $av->AvALLOC if $] > 5.013002; # XXX new but not needed
680 } 681 }
681 asm "sv_refcnt", $av->REFCNT; 682 asm "sv_refcnt", $av->REFCNT;
682 asm "xmg_stash", $stashix; 683 asm "xmg_stash", $stashix;
683 } 684 }
684 685
685 sub B::PADLIST::bsave { 686 sub B::PADLIST::bsave {
686 my ( $av, $ix ) = @_; 687 my ( $av, $ix ) = @_;
687 my @array = $av->ARRAY; 688 my @array = $av->ARRAY;
688 $_ = $_->ix for @array; # hack. walks the ->ix methods to save the elements 689 $_ = $_->ix for @array; # hack. walks the ->ix methods to save the elements
689 # my $stashix = $av->SvSTASH->ix; 690 # my $stashix = $av->SvSTASH->ix;
690 nice "-AV-", 691 nice "-AV-",
691 asm "ldsv", $varix = $ix, sv_flags($av) unless $ix == $varix; 692 asm "ldsv", $varix = $ix, sv_flags($av) unless $ix == $varix;
692 asm "av_extend", $av->MAX if $av->MAX >= 0; 693 asm "av_extend", $av->MAX if $av->MAX >= 0;
693 asm "av_pushx", $_ for @array; 694 asm "av_pushx", $_ for @array;
694 asm "sv_refcnt", $av->REFCNT; 695 asm "sv_refcnt", $av->REFCNT;
695 # asm "xmg_stash", $stashix; 696 # asm "xmg_stash", $stashix;
696 } 697 }
697 698
698 sub B::GV::desired { 699 sub B::GV::desired {
699 my $gv = shift; 700 my $gv = shift;
700 my ( $cv, $form ); 701 my ( $cv, $form );
701 if ( $debug{Gall} and !$PERL510 ) { 702 if ( $debug{Gall} and !$PERL510 ) {
702 select *STDERR; 703 select *STDERR;
703 eval "require B::Debug;"; 704 eval "require B::Debug;";
704 $gv->debug; 705 $gv->debug;
705 select *STDOUT; 706 select *STDOUT;
706 } 707 }
707 $files{ $gv->FILE } && $gv->LINE 708 $files{ $gv->FILE } && $gv->LINE
708 || ${ $cv = $gv->CV } && $files{ $cv->FILE } 709 || ${ $cv = $gv->CV } && $files{ $cv->FILE }
709 || ${ $form = $gv->FORM } && $files{ $form->FILE }; 710 || ${ $form = $gv->FORM } && $files{ $form->FILE };
710 } 711 }
711 712
712 sub B::HV::bwalk { 713 sub B::HV::bwalk {
713 my $hv = shift; 714 my $hv = shift;
714 return if $walked{$$hv}++; 715 return if $walked{$$hv}++;
715 my %stash = $hv->ARRAY; 716 my %stash = $hv->ARRAY;
716 while ( my ( $k, $v ) = each %stash ) { 717 while ( my ( $k, $v ) = each %stash ) {
717 if ( !$PERL56 and $v->SvTYPE == $SVt_PVGV ) { 718 if ( !$PERL56 and $v->SvTYPE == $SVt_PVGV ) {
718 my $hash = $v->HV; 719 my $hash = $v->HV;
719 if ( $$hash && $hash->NAME ) { 720 if ( $$hash && $hash->NAME ) {
720 $hash->bwalk; 721 $hash->bwalk;
721 } 722 }
722 # B since 5.13.6 (744aaba0598) pollutes our namespace. Keep it clean 723 # B since 5.13.6 (744aaba0598) pollutes our namespace. Keep it clean
723 # XXX This fails if our source really needs any B constant 724 # XXX This fails if our source really needs any B constant
724 unless ($] > 5.013005 and $hv->NAME eq 'B') { 725 unless ($] > 5.013005 and $hv->NAME eq 'B') {
725 $v->ix(1) if desired $v; 726 $v->ix(1) if desired $v;
726 } 727 }
727 } 728 }
728 else { 729 else {
729 if ($] > 5.013005 and $hv->NAME eq 'B') { # see above. omit B prototypes 730 if ($] > 5.013005 and $hv->NAME eq 'B') { # see above. omit B prototypes
730 return; 731 return;
731 } 732 }
732 nice "[prototype $tix]"; 733 nice "[prototype $tix]";
733 B::Assembler::maxsvix($tix) if $debug{A}; 734 B::Assembler::maxsvix($tix) if $debug{A};
734 asm "gv_fetchpvx", cstring ($hv->NAME . "::" . $k); 735 asm "gv_fetchpvx", cstring ($hv->NAME . "::" . $k);
735 $svtab{$$v} = $varix = $tix; 736 $svtab{$$v} = $varix = $tix;
736 # we need the sv_flags before, esp. for DEBUGGING asserts 737 # we need the sv_flags before, esp. for DEBUGGING asserts
737 asm "sv_flags", $v->FLAGS, ashex($v->FLAGS); 738 asm "sv_flags", $v->FLAGS, as_hex($v->FLAGS);
738 $v->bsave( $tix++ ); 739 $v->bsave( $tix++ );
739 } 740 }
740 } 741 }
741 } 742 }
742 743
743 ###################################################### 744 ######################################################
744 745
745 sub B::OP::bsave_thin { 746 sub B::OP::bsave_thin {
746 my ( $op, $ix ) = @_; 747 my ( $op, $ix ) = @_;
747 bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o}; 748 bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o};
748 my $next = $op->next; 749 my $next = $op->next;
749 my $nextix = $optab{$$next}; 750 my $nextix = $optab{$$next};
750 $nextix = 0, push @cloop, $op unless defined $nextix; 751 $nextix = 0, push @cloop, $op unless defined $nextix;
751 if ( $ix != $opix ) { 752 if ( $ix != $opix ) {
752 nice '-' . $op->name . '-', asm "ldop", $opix = $ix; 753 nice '-' . $op->name . '-', asm "ldop", $opix = $ix;
753 } 754 }
754 asm "op_flags", $op->flags, op_flags( $op->flags ); 755 asm "op_flags", $op->flags, op_flags( $op->flags );
755 asm "op_next", $nextix; 756 asm "op_next", $nextix;
756 asm "op_targ", $op->targ if $op->type; # tricky 757 asm "op_targ", $op->targ if $op->type; # tricky
757 asm "op_private", $op->private; # private concise flags? 758 asm "op_private", $op->private; # private concise flags?
758 } 759 }
759 760
760 sub B::OP::bsave; 761 sub B::OP::bsave;
761 *B::OP::bsave = *B::OP::bsave_thin; 762 *B::OP::bsave = *B::OP::bsave_thin;
762 763
763 sub B::UNOP::bsave { 764 sub B::UNOP::bsave {
764 my ( $op, $ix ) = @_; 765 my ( $op, $ix ) = @_;
765 my $name = $op->name; 766 my $name = $op->name;
766 my $flags = $op->flags; 767 my $flags = $op->flags;
767 my $first = $op->first; 768 my $first = $op->first;
768 my $firstix = $name =~ /fl[io]p/ 769 my $firstix = $name =~ /fl[io]p/
769 770
770 # that's just neat 771 # that's just neat
771 || ( !ITHREADS && $name eq 'regcomp' ) 772 || ( !ITHREADS && $name eq 'regcomp' )
772 773
773 # trick for /$a/o in pp_regcomp 774 # trick for /$a/o in pp_regcomp
774 || $name eq 'rv2sv' 775 || $name eq 'rv2sv'
775 && $op->flags & OPf_MOD 776 && $op->flags & OPf_MOD
776 && $op->private & OPpLVAL_INTRO 777 && $op->private & OPpLVAL_INTRO
777 778
778 # change #18774 (localref) made my life hard (commit 82d039840b913b4) 779 # change #18774 (localref) made my life hard (commit 82d039840b913b4)
779 ? $first->ix 780 ? $first->ix
780 : 0; 781 : 0;
781 782
782 # XXX Are there more new UNOP's with first? 783 # XXX Are there more new UNOP's with first?
783 $firstix = $first->ix if $name eq 'require'; #issue 97 784 $firstix = $first->ix if $name eq 'require'; #issue 97
784 $op->B::OP::bsave($ix); 785 $op->B::OP::bsave($ix);
785 asm "op_first", $firstix; 786 asm "op_first", $firstix;
786 } 787 }
787 788
788 sub B::BINOP::bsave { 789 sub B::BINOP::bsave {
789 my ( $op, $ix ) = @_; 790 my ( $op, $ix ) = @_;
790 if ( $op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH() ) { 791 if ( $op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH() ) {
791 my $last = $op->last; 792 my $last = $op->last;
792 my $lastix = do { 793 my $lastix = do {
793 local *B::OP::bsave = *B::OP::bsave_fat; 794 local *B::OP::bsave = *B::OP::bsave_fat;
794 local *B::UNOP::bsave = *B::UNOP::bsave_fat; 795 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
795 $last->ix; 796 $last->ix;
796 }; 797 };
797 asm "ldop", $lastix unless $lastix == $opix; 798 asm "ldop", $lastix unless $lastix == $opix;
798 asm "op_targ", $last->targ; 799 asm "op_targ", $last->targ;
799 $op->B::OP::bsave($ix); 800 $op->B::OP::bsave($ix);
800 asm "op_last", $lastix; 801 asm "op_last", $lastix;
801 } 802 }
802 else { 803 else {
803 $op->B::OP::bsave($ix); 804 $op->B::OP::bsave($ix);
804 } 805 }
805 } 806 }
806 807
807 # not needed if no pseudohashes 808 # not needed if no pseudohashes
808 809
809 *B::BINOP::bsave = *B::OP::bsave if $PERL510; #VERSION >= 5.009; 810 *B::BINOP::bsave = *B::OP::bsave if $PERL510; #VERSION >= 5.009;
810 811
811 # deal with sort / formline 812 # deal with sort / formline
812 813
813 sub B::LISTOP::bsave { 814 sub B::LISTOP::bsave {
814 my ( $op, $ix ) = @_; 815 my ( $op, $ix ) = @_;
815 bwarn( $op->peekop, ", ix: $ix" ) if $debug{o}; 816 bwarn( $op->peekop, ", ix: $ix" ) if $debug{o};
816 my $name = $op->name; 817 my $name = $op->name;
817 sub blocksort() { OPf_SPECIAL | OPf_STACKED } 818 sub blocksort() { OPf_SPECIAL | OPf_STACKED }
818 if ( $name eq 'sort' && ( $op->flags & blocksort ) == blocksort ) { 819 if ( $name eq 'sort' && ( $op->flags & blocksort ) == blocksort ) {
819 my $first = $op->first; 820 my $first = $op->first;
820 my $pushmark = $first->sibling; 821 my $pushmark = $first->sibling;
821 my $rvgv = $pushmark->first; 822 my $rvgv = $pushmark->first;
822 my $leave = $rvgv->first; 823 my $leave = $rvgv->first;
823 824
824 my $leaveix = $leave->ix; 825 my $leaveix = $leave->ix;
825 826
826 my $rvgvix = $rvgv->ix; 827 my $rvgvix = $rvgv->ix;
827 asm "ldop", $rvgvix unless $rvgvix == $opix; 828 asm "ldop", $rvgvix unless $rvgvix == $opix;
828 asm "op_first", $leaveix; 829 asm "op_first", $leaveix;
829 830
830 my $pushmarkix = $pushmark->ix; 831 my $pushmarkix = $pushmark->ix;
831 asm "ldop", $pushmarkix unless $pushmarkix == $opix; 832 asm "ldop", $pushmarkix unless $pushmarkix == $opix;
832 asm "op_first", $rvgvix; 833 asm "op_first", $rvgvix;
833 834
834 my $firstix = $first->ix; 835 my $firstix = $first->ix;
835 asm "ldop", $firstix unless $firstix == $opix; 836 asm "ldop", $firstix unless $firstix == $opix;
836 asm "op_sibling", $pushmarkix; 837 asm "op_sibling", $pushmarkix;
837 838
838 $op->B::OP::bsave($ix); 839 $op->B::OP::bsave($ix);
839 asm "op_first", $firstix; 840 asm "op_first", $firstix;
840 } 841 }
841 elsif ( $name eq 'formline' ) { 842 elsif ( $name eq 'formline' ) {
842 $op->B::UNOP::bsave_fat($ix); 843 $op->B::UNOP::bsave_fat($ix);
843 } 844 }
844 elsif ( $name eq 'dbmopen' ) { 845 elsif ( $name eq 'dbmopen' ) {
845 require AnyDBM_File; 846 require AnyDBM_File;
846 $op->B::OP::bsave($ix); 847 $op->B::OP::bsave($ix);
847 } 848 }
848 else { 849 else {
849 $op->B::OP::bsave($ix); 850 $op->B::OP::bsave($ix);
850 } 851 }
851 } 852 }
852 853
853 # fat versions 854 # fat versions
854 855
855 sub B::OP::bsave_fat { 856 sub B::OP::bsave_fat {
856 my ( $op, $ix ) = @_; 857 my ( $op, $ix ) = @_;
857 my $siblix = $op->sibling->ix; 858 my $siblix = $op->sibling->ix;
858 859
859 $op->B::OP::bsave_thin($ix); 860 $op->B::OP::bsave_thin($ix);
860 asm "op_sibling", $siblix; 861 asm "op_sibling", $siblix;
861 862
862 # asm "op_seq", -1; XXX don't allocate OPs piece by piece 863 # asm "op_seq", -1; XXX don't allocate OPs piece by piece
863 } 864 }
864 865
865 sub B::UNOP::bsave_fat { 866 sub B::UNOP::bsave_fat {
866 my ( $op, $ix ) = @_; 867 my ( $op, $ix ) = @_;
867 my $firstix = $op->first->ix; 868 my $firstix = $op->first->ix;
868 869
869 $op->B::OP::bsave($ix); 870 $op->B::OP::bsave($ix);
870 asm "op_first", $firstix; 871 asm "op_first", $firstix;
871 } 872 }
872 873
873 sub B::BINOP::bsave_fat { 874 sub B::BINOP::bsave_fat {
874 my ( $op, $ix ) = @_; 875 my ( $op, $ix ) = @_;
875 my $last = $op->last; 876 my $last = $op->last;
876 my $lastix = $op->last->ix; 877 my $lastix = $op->last->ix;
877 bwarn( B::peekop($op), ", ix: $ix $last: $last, lastix: $lastix" ) 878 bwarn( B::peekop($op), ", ix: $ix $last: $last, lastix: $lastix" )
878 if $debug{o}; 879 if $debug{o};
879 if ( !$PERL510 && $op->name eq 'aassign' && $last->name eq 'null' ) { 880 if ( !$PERL510 && $op->name eq 'aassign' && $last->name eq 'null' ) {
880 asm "ldop", $lastix unless $lastix == $opix; 881 asm "ldop", $lastix unless $lastix == $opix;
881 asm "op_targ", $last->targ; 882 asm "op_targ", $last->targ;
882 } 883 }
883 884
884 $op->B::UNOP::bsave($ix); 885 $op->B::UNOP::bsave($ix);
885 asm "op_last", $lastix; 886 asm "op_last", $lastix;
886 } 887 }
887 888
888 sub B::LOGOP::bsave { 889 sub B::LOGOP::bsave {
889 my ( $op, $ix ) = @_; 890 my ( $op, $ix ) = @_;
890 my $otherix = $op->other->ix; 891 my $otherix = $op->other->ix;
891 bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o}; 892 bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o};
892 893
893 $op->B::UNOP::bsave($ix); 894 $op->B::UNOP::bsave($ix);
894 asm "op_other", $otherix; 895 asm "op_other", $otherix;
895 } 896 }
896 897
897 sub B::PMOP::bsave { 898 sub B::PMOP::bsave {
898 my ( $op, $ix ) = @_; 899 my ( $op, $ix ) = @_;
899 my ( $rrop, $rrarg, $rstart ); 900 my ( $rrop, $rrarg, $rstart );
900 901
901 # my $pmnextix = $op->pmnext->ix; # XXX 902 # my $pmnextix = $op->pmnext->ix; # XXX
902 bwarn( B::peekop($op), " ix: $ix" ) if $debug{M} or $debug{o}; 903 bwarn( B::peekop($op), " ix: $ix" ) if $debug{M} or $debug{o};
903 if (ITHREADS) { 904 if (ITHREADS) {
904 if ( $op->name eq 'subst' ) { 905 if ( $op->name eq 'subst' ) {
905 $rrop = "op_pmreplroot"; 906 $rrop = "op_pmreplroot";
906 $rrarg = $op->pmreplroot->ix; 907 $rrarg = $op->pmreplroot->ix;
907 $rstart = $op->pmreplstart->ix; 908 $rstart = $op->pmreplstart->ix;
908 } 909 }
909 elsif ( $op->name eq 'pushre' ) { 910 elsif ( $op->name eq 'pushre' ) {
910 $rrarg = $op->pmreplroot; 911 $rrarg = $op->pmreplroot;
911 $rrop = "op_pmreplrootpo"; 912 $rrop = "op_pmreplrootpo";
912 } 913 }
913 $op->B::BINOP::bsave($ix); 914 $op->B::BINOP::bsave($ix);
914 if ( !$PERL56 and $op->pmstashpv ) 915 if ( !$PERL56 and $op->pmstashpv )
915 { # avoid empty stash? if (table) pre-compiled else re-compile 916 { # avoid empty stash? if (table) pre-compiled else re-compile
916 if ( !$PERL510 ) { 917 if ( !$PERL510 ) {
917 asm "op_pmstashpv", pvix $op->pmstashpv; 918 asm "op_pmstashpv", pvix $op->pmstashpv;
918 } 919 }
919 else { 920 else {
920 # XXX crash in 5.10, 5.11. Only used in OP_MATCH, with PMf_ONCE set 921 # XXX crash in 5.10, 5.11. Only used in OP_MATCH, with PMf_ONCE set
921 if ( $op->name eq 'match' and $op->op_pmflags & 2) { 922 if ( $op->name eq 'match' and $op->op_pmflags & 2) {
922 asm "op_pmstashpv", pvix $op->pmstashpv; 923 asm "op_pmstashpv", pvix $op->pmstashpv;
923 } else { 924 } else {
924 bwarn("op_pmstashpv ignored") if $debug{M}; 925 bwarn("op_pmstashpv ignored") if $debug{M};
925 } 926 }
926 } 927 }
927 } 928 }
928 elsif ($PERL56) { # ignored 929 elsif ($PERL56) { # ignored
929 ; 930 ;
930 } 931 }
931 else { 932 else {
932 bwarn("op_pmstashpv main") if $debug{M}; 933 bwarn("op_pmstashpv main") if $debug{M};
933 asm "op_pmstashpv", pvix "main" unless $PERL510; 934 asm "op_pmstashpv", pvix "main" unless $PERL510;
934 } 935 }
935 } # ithreads 936 } # ithreads
936 else { 937 else {
937 $rrop = "op_pmreplrootgv"; 938 $rrop = "op_pmreplrootgv";
938 $rrarg = $op->pmreplroot->ix; 939 $rrarg = $op->pmreplroot->ix;
939 $rstart = $op->pmreplstart->ix if $op->name eq 'subst'; 940 $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
940 # 5.6 walks down the pmreplrootgv here 941 # 5.6 walks down the pmreplrootgv here
941 # $op->pmreplroot->save($rrarg) unless $op->name eq 'pushre'; 942 # $op->pmreplroot->save($rrarg) unless $op->name eq 'pushre';
942 my $stashix = $op->pmstash->ix unless $PERL56; 943 my $stashix = $op->pmstash->ix unless $PERL56;
943 $op->B::BINOP::bsave($ix); 944 $op->B::BINOP::bsave($ix);
944 asm "op_pmstash", $stashix unless $PERL56; 945 asm "op_pmstash", $stashix unless $PERL56;
945 } 946 }
946 947
947 asm $rrop, $rrarg if $rrop; 948 asm $rrop, $rrarg if $rrop;
948 asm "op_pmreplstart", $rstart if $rstart; 949 asm "op_pmreplstart", $rstart if $rstart;
949 950
950 if ( !$PERL510 ) { 951 if ( !$PERL510 ) {
951 bwarn( "PMOP op_pmflags: ", $op->pmflags ) if $debug{M}; 952 bwarn( "PMOP op_pmflags: ", $op->pmflags ) if $debug{M};
952 asm "op_pmflags", $op->pmflags; 953 asm "op_pmflags", $op->pmflags;
953 asm "op_pmpermflags", $op->pmpermflags; 954 asm "op_pmpermflags", $op->pmpermflags;
954 asm "op_pmdynflags", $op->pmdynflags unless $PERL56; 955 asm "op_pmdynflags", $op->pmdynflags unless $PERL56;
955 # asm "op_pmnext", $pmnextix; # XXX broken 956 # asm "op_pmnext", $pmnextix; # XXX broken
956 # Special sequence: This is the arg for the next pregcomp 957 # Special sequence: This is the arg for the next pregcomp
957 asm "newpv", pvstring $op->precomp; 958 asm "newpv", pvstring $op->precomp;
958 asm "pregcomp"; 959 asm "pregcomp";
959 } 960 }
960 elsif ($PERL510) { 961 elsif ($PERL510) {
961 my $pv = $op->precomp; 962 my $pv = $op->precomp;
962 # Since PMf_BASE_SHIFT we need a U32, which needs a new bytecode for 963 # Since PMf_BASE_SHIFT we need a U32, which needs a new bytecode for
963 # backwards compat. 964 # backwards compat.
964 asm "op_pmflags", $op->pmflags; 965 asm "op_pmflags", $op->pmflags;
965 bwarn("PMOP op_pmflags: ", $op->pmflags) if $debug{M}; 966 bwarn("PMOP op_pmflags: ", $op->pmflags) if $debug{M};
966 # pregcomp does not set the extflags correctly, just the pmflags 967 # pregcomp does not set the extflags correctly, just the pmflags
967 asm "newpv", pvstring $pv; 968 asm "newpv", pvstring $pv;
968 asm "pregcomp"; 969 asm "pregcomp";
969 asm "op_reflags", $op->reflags if $pv; # so overwrite the extflags 970 asm "op_reflags", $op->reflags if $pv; # so overwrite the extflags
970 } 971 }
971 } 972 }
972 973
973 sub B::SVOP::bsave { 974 sub B::SVOP::bsave {
974 my ( $op, $ix ) = @_; 975 my ( $op, $ix ) = @_;
975 my $svix = $op->sv->ix; 976 my $svix = $op->sv->ix;
976 977
977 $op->B::OP::bsave($ix); 978 $op->B::OP::bsave($ix);
978 asm "op_sv", $svix; 979 asm "op_sv", $svix;
979 } 980 }
980 981
981 sub B::PADOP::bsave { 982 sub B::PADOP::bsave {
982 my ( $op, $ix ) = @_; 983 my ( $op, $ix ) = @_;
983 984
984 $op->B::OP::bsave($ix); 985 $op->B::OP::bsave($ix);
985 986
986 # XXX crashed in 5.11 (where, why?) 987 # XXX crashed in 5.11 (where, why?)
987 #if ($PERL512) { 988 #if ($PERL512) {
988 asm "op_padix", $op->padix; 989 asm "op_padix", $op->padix;
989 #} 990 #}
990 } 991 }
991 992
992 sub B::PVOP::bsave { 993 sub B::PVOP::bsave {
993 my ( $op, $ix ) = @_; 994 my ( $op, $ix ) = @_;
994 $op->B::OP::bsave($ix); 995 $op->B::OP::bsave($ix);
995 return unless my $pv = $op->pv; 996 return unless my $pv = $op->pv;
996 997
997 if ( $op->name eq 'trans' ) { 998 if ( $op->name eq 'trans' ) {
998 asm "op_pv_tr", join ',', length($pv) / 2, unpack( "s*", $pv ); 999 asm "op_pv_tr", join ',', length($pv) / 2, unpack( "s*", $pv );
999 } 1000 }
1000 else { 1001 else {
1001 asm "newpv", pvstring $pv; 1002 asm "newpv", pvstring $pv;
1002 asm "op_pv"; 1003 asm "op_pv";
1003 } 1004 }
1004 } 1005 }
1005 1006
1006 sub B::LOOP::bsave { 1007 sub B::LOOP::bsave {
1007 my ( $op, $ix ) = @_; 1008 my ( $op, $ix ) = @_;
1008 my $nextix = $op->nextop->ix; 1009 my $nextix = $op->nextop->ix;
1009 my $lastix = $op->lastop->ix; 1010 my $lastix = $op->lastop->ix;
1010 my $redoix = $op->redoop->ix; 1011 my $redoix = $op->redoop->ix;
1011 1012
1012 $op->B::BINOP::bsave($ix); 1013 $op->B::BINOP::bsave($ix);
1013 asm "op_redoop", $redoix; 1014 asm "op_redoop", $redoix;
1014 asm "op_nextop", $nextix; 1015 asm "op_nextop", $nextix;
1015 asm "op_lastop", $lastix; 1016 asm "op_lastop", $lastix;
1016 } 1017 }
1017 1018
1018 sub B::COP::bsave { 1019 sub B::COP::bsave {
1019 my ( $cop, $ix ) = @_; 1020 my ( $cop, $ix ) = @_;
1020 my $warnix = $cop->warnings->ix; 1021 my $warnix = $cop->warnings->ix;
1021 if (ITHREADS) { 1022 if (ITHREADS) {
1022 $cop->B::OP::bsave($ix); 1023 $cop->B::OP::bsave($ix);
1023 asm "cop_stashpv", pvix $cop->stashpv, $cop->stashpv; 1024 asm "cop_stashpv", pvix $cop->stashpv, $cop->stashpv;
1024 asm "cop_file", pvix $cop->file, $cop->file; 1025 asm "cop_file", pvix $cop->file, $cop->file;
1025 } 1026 }
1026 else { 1027 else {
1027 my $stashix = $cop->stash->ix; 1028 my $stashix = $cop->stash->ix;
1028 my $fileix = $PERL56 ? pvix($cop->file) : $cop->filegv->ix(1); 1029 my $fileix = $PERL56 ? pvix($cop->file) : $cop->filegv->ix(1);
1029 $cop->B::OP::bsave($ix); 1030 $cop->B::OP::bsave($ix);
1030 asm "cop_stash", $stashix; 1031 asm "cop_stash", $stashix;
1031 asm "cop_filegv", $fileix; 1032 asm "cop_filegv", $fileix;
1032 } 1033 }
1033 asm "cop_label", pvix $cop->label, $cop->label if $cop->label; # XXX AD 1034 asm "cop_label", pvix $cop->label, $cop->label if $cop->label; # XXX AD
1034 asm "cop_seq", $cop->cop_seq; 1035 asm "cop_seq", $cop->cop_seq;
1035 asm "cop_arybase", $cop->arybase unless $PERL510; 1036 asm "cop_arybase", $cop->arybase unless $PERL510;
1036 asm "cop_line", $cop->line; 1037 asm "cop_line", $cop->line;
1037 asm "cop_warnings", $warnix; 1038 asm "cop_warnings", $warnix;
1038 if ( !$PERL510 and !$PERL56 ) { 1039 if ( !$PERL510 and !$PERL56 ) {
1039 asm "cop_io", $cop->io->ix; 1040 asm "cop_io", $cop->io->ix;
1040 } 1041 }
1041 } 1042 }
1042 1043
1043 sub B::OP::opwalk { 1044 sub B::OP::opwalk {
1044 my $op = shift; 1045 my $op = shift;
1045 my $ix = $optab{$$op}; 1046 my $ix = $optab{$$op};
1046 defined($ix) ? $ix : do { 1047 defined($ix) ? $ix : do {
1047 my $ix; 1048 my $ix;
1048 my @oplist = ($PERL56 and $op->isa("B::COP")) 1049 my @oplist = ($PERL56 and $op->isa("B::COP"))
1049 ? () : $op->oplist; # 5.6 may be called by a COP 1050 ? () : $op->oplist; # 5.6 may be called by a COP
1050 push @cloop, undef; 1051 push @cloop, undef;
1051 $ix = $_->ix while $_ = pop @oplist; 1052 $ix = $_->ix while $_ = pop @oplist;
1052 #print "\n# rest of cloop\n"; 1053 #print "\n# rest of cloop\n";
1053 while ( $_ = pop @cloop ) { 1054 while ( $_ = pop @cloop ) {
1054 asm "ldop", $optab{$$_}; 1055 asm "ldop", $optab{$$_};
1055 asm "op_next", $optab{ ${ $_->next } }; 1056 asm "op_next", $optab{ ${ $_->next } };
1056 } 1057 }
1057 $ix; 1058 $ix;
1058 } 1059 }
1059 } 1060 }
1060 1061
1061 # Do run-time requires with -s savebegin and without -i includeall. 1062 # Do run-time requires with -s savebegin and without -i includeall.
1062 # Otherwise all side-effects of BEGIN blocks are already in the current 1063 # Otherwise all side-effects of BEGIN blocks are already in the current
1063 # compiled code. 1064 # compiled code.
1064 # -s or !-i will have smaller code, but run-time access of dependent modules 1065 # -s or !-i will have smaller code, but run-time access of dependent modules
1065 # such as with python, where all modules are byte-compiled. 1066 # such as with python, where all modules are byte-compiled.
1066 # With -i the behaviour is similar to the C or CC compiler, where everything 1067 # With -i the behaviour is similar to the C or CC compiler, where everything
1067 # is packed into one file. 1068 # is packed into one file.
1068 # Redo only certain ops, such as push @INC ""; unshift @INC "" (TODO *INC) 1069 # Redo only certain ops, such as push @INC ""; unshift @INC "" (TODO *INC)
1069 # use/require defs and boot sections are already included. 1070 # use/require defs and boot sections are already included.
1070 sub save_begin { 1071 sub save_begin {
1071 my $av; 1072 my $av;
1072 if ( ( $av = begin_av )->isa("B::AV") and $av->ARRAY) { 1073 if ( ( $av = begin_av )->isa("B::AV") and $av->ARRAY) {
1073 nice '<push_begin>'; 1074 nice '<push_begin>';
1074 if ($savebegins) { 1075 if ($savebegins) {
1075 for ( $av->ARRAY ) { 1076 for ( $av->ARRAY ) {
1076 next unless $_->FILE eq $0; 1077 next unless $_->FILE eq $0;
1077 asm "push_begin", $_->ix; 1078 asm "push_begin", $_->ix;
1078 } 1079 }
1079 } 1080 }
1080 else { 1081 else {
1081 for ( $av->ARRAY ) { 1082 for ( $av->ARRAY ) {
1082 next unless $_->FILE eq $0; 1083 next unless $_->FILE eq $0;
1083 1084
1084 # XXX BEGIN { goto A while 1; A: } 1085 # XXX BEGIN { goto A while 1; A: }
1085 for ( my $op = $_->START ; $$op ; $op = $op->next ) { 1086 for ( my $op = $_->START ; $$op ; $op = $op->next ) {
1086 # 1. push|unshift @INC, "libpath" 1087 # 1. push|unshift @INC, "libpath"
1087 if ($op->name eq 'gv') { 1088 if ($op->name eq 'gv') {
1088 my $gv = class($op) eq 'SVOP' 1089 my $gv = class($op) eq 'SVOP'
1089 ? $op->gv 1090 ? $op->gv
1090 : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ]; 1091 : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ];
1091 nice1 '<gv '.$gv->NAME.'>' if $$gv; 1092 nice1 '<gv '.$gv->NAME.'>' if $$gv;
1092 asm "incav", inc_gv->AV->ix if $$gv and $gv->NAME eq 'INC'; 1093 asm "incav", inc_gv->AV->ix if $$gv and $gv->NAME eq 'INC';
1093 } 1094 }
1094 # 2. use|require 1095 # 2. use|require
1095 if (!$includeall) { 1096 if (!$includeall) {
1096 next unless $op->name eq 'require' || 1097 next unless $op->name eq 'require' ||
1097 # this kludge needed for tests 1098 # this kludge needed for tests
1098 $op->name eq 'gv' && do { 1099 $op->name eq 'gv' && do {
1099 my $gv = class($op) eq 'SVOP' 1100 my $gv = class($op) eq 'SVOP'
1100 ? $op->gv 1101 ? $op->gv
1101 : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ]; 1102 : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ];
1102 $$gv && $gv->NAME =~ /use_ok|plan/; 1103 $$gv && $gv->NAME =~ /use_ok|plan/;
1103 }; 1104 };
1104 nice1 '<require in BEGIN>'; 1105 nice1 '<require in BEGIN>';
1105 asm "push_begin", $_->ix if $_; 1106 asm "push_begin", $_->ix if $_;
1106 last; 1107 last;
1107 } 1108 }
1108 } 1109 }
1109 } 1110 }
1110 } 1111 }
1111 } 1112 }
1112 } 1113 }
1113 1114
1114 sub save_init_end { 1115 sub save_init_end {
1115 my $av; 1116 my $av;
1116 if ( ( $av = init_av )->isa("B::AV") and $av->ARRAY ) { 1117 if ( ( $av = init_av )->isa("B::AV") and $av->ARRAY ) {
1117 nice '<push_init>'; 1118 nice '<push_init>';
1118 for ( $av->ARRAY ) { 1119 for ( $av->ARRAY ) {
1119 next unless $_->FILE eq $0; 1120 next unless $_->FILE eq $0;
1120 asm "push_init", $_->ix; 1121 asm "push_init", $_->ix;
1121 } 1122 }
1122 } 1123 }
1123 if ( ( $av = end_av )->isa("B::AV") and $av->ARRAY ) { 1124 if ( ( $av = end_av )->isa("B::AV") and $av->ARRAY ) {
1124 nice '<push_end>'; 1125 nice '<push_end>';
1125 for ( $av->ARRAY ) { 1126 for ( $av->ARRAY ) {
1126 next unless $_->FILE eq $0; 1127 next unless $_->FILE eq $0;
1127 asm "push_end", $_->ix; 1128 asm "push_end", $_->ix;
1128 } 1129 }
1129 } 1130 }
1130 } 1131 }
1131 1132
1132 ################### perl 5.6 backport only ################################### 1133 ################### perl 5.6 backport only ###################################
1133 1134
1134 sub B::GV::bytecodecv { 1135 sub B::GV::bytecodecv {
1135 my $gv = shift; 1136 my $gv = shift;
1136 my $cv = $gv->CV; 1137 my $cv = $gv->CV;
1137 if ( $$cv && !( $gv->FLAGS & 0x80 ) ) { # GVf_IMPORTED_CV / && !saved($cv) 1138 if ( $$cv && !( $gv->FLAGS & 0x80 ) ) { # GVf_IMPORTED_CV / && !saved($cv)
1138 if ($debug{cv}) { 1139 if ($debug{cv}) {
1139 warn sprintf( "saving extra CV &%s::%s (0x%x) from GV 0x%x\n", 1140 warn sprintf( "saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1140 $gv->STASH->NAME, $gv->NAME, $$cv, $$gv ); 1141 $gv->STASH->NAME, $gv->NAME, $$cv, $$gv );
1141 } 1142 }
1142 $gv->bsave; 1143 $gv->bsave;
1143 } 1144 }
1144 } 1145 }
1145 1146
1146 sub symwalk { 1147 sub symwalk {
1147 no strict 'refs'; 1148 no strict 'refs';
1148 my $ok = 1 1149 my $ok = 1
1149 if grep { ( my $name = $_[0] ) =~ s/::$//; $_ eq $name; } @packages; 1150 if grep { ( my $name = $_[0] ) =~ s/::$//; $_ eq $name; } @packages;
1150 if ( grep { /^$_[0]/; } @packages ) { 1151 if ( grep { /^$_[0]/; } @packages ) {
1151 walksymtable( \%{"$_[0]"}, "desired", \&symwalk, $_[0] ); 1152 walksymtable( \%{"$_[0]"}, "desired", \&symwalk, $_[0] );
1152 } 1153 }
1153 warn "considering $_[0] ... " . ( $ok ? "accepted\n" : "rejected\n" ) 1154 warn "considering $_[0] ... " . ( $ok ? "accepted\n" : "rejected\n" )
1154 if $debug{b}; 1155 if $debug{b};
1155 $ok; 1156 $ok;
1156 } 1157 }
1157 1158
1158 ################### end perl 5.6 backport ################################### 1159 ################### end perl 5.6 backport ###################################
1159 1160
1160 sub compile { 1161 sub compile {
1161 my ( $head, $scan, $keep_syn, $module ); 1162 my ( $head, $scan, $keep_syn, $module );
1162 my $cwd = ''; 1163 my $cwd = '';
1163 $files{$0} = 1; 1164 $files{$0} = 1;
1164 $DB::single=1 if defined &DB::DB; 1165 $DB::single=1 if defined &DB::DB;
1165 # includeall mode (without require): 1166 # includeall mode (without require):
1166 if ($includeall) { 1167 if ($includeall) {
1167 # add imported symbols => values %INC 1168 # add imported symbols => values %INC
1168 $files{$_} = 1 for values %INC; 1169 $files{$_} = 1 for values %INC;
1169 } 1170 }
1170 1171
1171 sub keep_syn { 1172 sub keep_syn {
1172 $keep_syn = 1; 1173 $keep_syn = 1;
1173 *B::OP::bsave = *B::OP::bsave_fat; 1174 *B::OP::bsave = *B::OP::bsave_fat;
1174 *B::UNOP::bsave = *B::UNOP::bsave_fat; 1175 *B::UNOP::bsave = *B::UNOP::bsave_fat;
1175 *B::BINOP::bsave = *B::BINOP::bsave_fat; 1176 *B::BINOP::bsave = *B::BINOP::bsave_fat;
1176 *B::LISTOP::bsave = *B::LISTOP::bsave_fat; 1177 *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
1177 } 1178 }
1178 sub bwarn { print STDERR "Bytecode.pm: @_\n" unless $quiet; } 1179 sub bwarn { print STDERR "Bytecode.pm: @_\n" unless $quiet; }
1179 1180
1180 for (@_) { 1181 for (@_) {
1181 if (/^-q(q?)/) { 1182 if (/^-q(q?)/) {
1182 $quiet = 1; 1183 $quiet = 1;
1183 } 1184 }
1184 elsif (/^-S/) { 1185 elsif (/^-S/) {
1185 $debug{Comment} = 1; 1186 $debug{Comment} = 1;
1186 $debug{-S} = 1; 1187 $debug{-S} = 1;
1187 *newasm = *endasm = sub { }; 1188 *newasm = *endasm = sub { };
1188 *asm = sub($;$$) { 1189 *asm = sub($;$$) {
1189 undef $_[2] if defined $_[2] and $quiet; 1190 undef $_[2] if defined $_[2] and $quiet;
1190 ( defined $_[2] ) 1191 ( defined $_[2] )
1191 ? print $_[0], " ", $_[1], "\t# ", $_[2], "\n" 1192 ? print $_[0], " ", $_[1], "\t# ", $_[2], "\n"
1192 : print "@_\n"; 1193 : print "@_\n";
1193 }; 1194 };
1194 *nice = sub ($) { print "\n# @_\n" unless $quiet; }; 1195 *nice = sub ($) { print "\n# @_\n" unless $quiet; };
1195 *nice1 = sub ($) { print "# @_\n" unless $quiet; }; 1196 *nice1 = sub ($) { print "# @_\n" unless $quiet; };
1196 } 1197 }
1197 elsif (/^-v/) { 1198 elsif (/^-v/) {
1198 warn "conflicting -q ignored" if $quiet; 1199 warn "conflicting -q ignored" if $quiet;
1199 *nice = sub ($) { print "\n# @_\n"; print STDERR "@_\n" }; 1200 *nice = sub ($) { print "\n# @_\n"; print STDERR "@_\n" };
1200 *nice1 = sub ($) { print "# @_\n"; print STDERR "@_\n" }; 1201 *nice1 = sub ($) { print "# @_\n"; print STDERR "@_\n" };
1201 } 1202 }
1202 elsif (/^-H/) { 1203 elsif (/^-H/) {
1203 require ByteLoader; 1204 require ByteLoader;
1204 my $version = $ByteLoader::VERSION; 1205 my $version = $ByteLoader::VERSION;
1205 $head = "#! $^X 1206 $head = "#! $^X
1206 use ByteLoader '$ByteLoader::VERSION'; 1207 use ByteLoader '$ByteLoader::VERSION';
1207 "; 1208 ";
1208 1209
1209 # Maybe: Fix the plc reader, if 'perl -MByteLoader <.plc>' is called 1210 # Maybe: Fix the plc reader, if 'perl -MByteLoader <.plc>' is called
1210 } 1211 }
1211 elsif (/^-k/) { 1212 elsif (/^-k/) {
1212 keep_syn; 1213 keep_syn;
1213 } 1214 }
1214 elsif (/^-m/) { 1215 elsif (/^-m/) {
1215 $module = 1; 1216 $module = 1;
1216 } 1217 }
1217 elsif (/^-o(.*)$/) { 1218 elsif (/^-o(.*)$/) {
1218 open STDOUT, ">$1" or die "open $1: $!"; 1219 open STDOUT, ">$1" or die "open $1: $!";
1219 } 1220 }
1220 elsif (/^-f(.*)$/) { 1221 elsif (/^-f(.*)$/) {
1221 $files{$1} = 1; 1222 $files{$1} = 1;
1222 } 1223 }
1223 elsif (/^-i/) { 1224 elsif (/^-i/) {
1224 $includeall = 1; 1225 $includeall = 1;
1225 } 1226 }
1226 elsif (/^-D(.*)$/) { 1227 elsif (/^-D(.*)$/) {
1227 $debug{$1}++; 1228 $debug{$1}++;
1228 } 1229 }
1229 elsif (/^-s(.*)$/) { 1230 elsif (/^-s(.*)$/) {
1230 $scan = length($1) ? $1 : $0; 1231 $scan = length($1) ? $1 : $0;
1231 } 1232 }
1232 elsif (/^-b/) { 1233 elsif (/^-b/) {
1233 $savebegins = 1; 1234 $savebegins = 1;
1234 } # this is here for the testsuite 1235 } # this is here for the testsuite
1235 elsif (/^-TI/) { 1236 elsif (/^-TI/) {
1236 $T_inhinc = 1; 1237 $T_inhinc = 1;
1237 } 1238 }
1238 elsif (/^-TF(.*)/) { 1239 elsif (/^-TF(.*)/) {
1239 my $thatfile = $1; 1240 my $thatfile = $1;
1240 *B::COP::file = sub { $thatfile }; 1241 *B::COP::file = sub { $thatfile };
1241 } 1242 }
1242 # Use -m instead for modules 1243 # Use -m instead for modules
1243 elsif (/^-u(.*)/ and $PERL56) { 1244 elsif (/^-u(.*)/ and $PERL56) {
1244 my $arg ||= $1; 1245 my $arg ||= $1;
1245 push @packages, $arg; 1246 push @packages, $arg;
1246 } 1247 }
1247 else { 1248 else {
1248 bwarn "Ignoring '$_' option"; 1249 bwarn "Ignoring '$_' option";
1249 } 1250 }
1250 } 1251 }
1251 if ($scan) { 1252 if ($scan) {
1252 my $f; 1253 my $f;
1253 if ( open $f, $scan ) { 1254 if ( open $f, $scan ) {
1254 while (<$f>) { 1255 while (<$f>) {
1255 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1; 1256 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
1256 /^#/ and next; 1257 /^#/ and next;
1257 if ( /\bgoto\b\s*[^&]/ && !$keep_syn ) { 1258 if ( /\bgoto\b\s*[^&]/ && !$keep_syn ) {
1258 bwarn "keeping the syntax tree: \"goto\" op found"; 1259 bwarn "keeping the syntax tree: \"goto\" op found";
1259 keep_syn; 1260 keep_syn;
1260 } 1261 }
1261 } 1262 }
1262 } 1263 }
1263 else { 1264 else {
1264 bwarn "cannot rescan '$scan'"; 1265 bwarn "cannot rescan '$scan'";
1265 } 1266 }
1266 close $f; 1267 close $f;
1267 } 1268 }
1268 binmode STDOUT; 1269 binmode STDOUT;
1269 return sub { 1270 return sub {
1270 if ($debug{-S}) { 1271 if ($debug{-S}) {
1271 my $header = B::Assembler::gen_header_hash; 1272 my $header = B::Assembler::gen_header_hash;
1272 asm sprintf("#%-10s\t","magic").sprintf("0x%x",$header->{magic}); 1273 asm sprintf("#%-10s\t","magic").sprintf("0x%x",$header->{magic});
1273 for (qw(archname blversion ivsize ptrsize byteorder longsize archflag 1274 for (qw(archname blversion ivsize ptrsize byteorder longsize archflag
1274 perlversion)) { 1275 perlversion)) {
1275 asm sprintf("#%-10s\t",$_).$header->{$_}; 1276 asm sprintf("#%-10s\t",$_).$header->{$_};
1276 } 1277 }
1277 } 1278 }
1278 print $head if $head; 1279 print $head if $head;
1279 newasm sub { print @_ }; 1280 newasm sub { print @_ };
1280 1281
1281 nice '<incav>' if $T_inhinc; 1282 nice '<incav>' if $T_inhinc;
1282 asm "incav", inc_gv->AV->ix if $T_inhinc; 1283 asm "incav", inc_gv->AV->ix if $T_inhinc;
1283 save_begin; 1284 save_begin;
1284 #asm "incav", inc_gv->AV->ix if $T_inhinc; 1285 #asm "incav", inc_gv->AV->ix if $T_inhinc;
1285 nice '<end_begin>'; 1286 nice '<end_begin>';
1286 if (!$PERL56) { 1287 if (!$PERL56) {
1287 defstash->bwalk; 1288 defstash->bwalk;
1288 } else { 1289 } else {
1289 if ( !@packages ) { 1290 if ( !@packages ) {
1290 # support modules? 1291 # support modules?
1291 @packages = qw(main); 1292 @packages = qw(main);
1292 } 1293 }
1293 for (@packages) { 1294 for (@packages) {
1294 no strict qw(refs); 1295 no strict qw(refs);
1295 #B::svref_2object( \%{"$_\::"} )->bwalk; 1296 #B::svref_2object( \%{"$_\::"} )->bwalk;
1296 walksymtable( \%{"$_\::"}, "bytecodecv", \&symwalk ); 1297 walksymtable( \%{"$_\::"}, "bytecodecv", \&symwalk );
1297 } 1298 }
1298 walkoptree( main_root, "bsave" ) unless ref(main_root) eq "B::NULL"; 1299 walkoptree( main_root, "bsave" ) unless ref(main_root) eq "B::NULL";
1299 } 1300 }
1300 unless ($module) { 1301 unless ($module) {
1301 nice '<main_start>'; 1302 nice '<main_start>';
1302 asm "main_start", $PERL56 ? main_start->ix : main_start->opwalk; 1303 asm "main_start", $PERL56 ? main_start->ix : main_start->opwalk;
1303 #asm "main_start", main_start->opwalk; 1304 #asm "main_start", main_start->opwalk;
1304 nice '<main_root>'; 1305 nice '<main_root>';
1305 asm "main_root", main_root->ix; 1306 asm "main_root", main_root->ix;
1306 nice '<main_cv>'; 1307 nice '<main_cv>';
1307 asm "main_cv", main_cv->ix; 1308 asm "main_cv", main_cv->ix;
1308 nice '<curpad>'; 1309 nice '<curpad>';
1309 asm "curpad", ( comppadlist->ARRAY )[1]->ix; 1310 asm "curpad", ( comppadlist->ARRAY )[1]->ix;
1310 } 1311 }
1311 1312
1312 asm "signal", cstring "__WARN__" # XXX 1313 asm "signal", cstring "__WARN__" # XXX
1313 if !$PERL56 and warnhook->ix; 1314 if !$PERL56 and warnhook->ix;
1314 save_init_end; 1315 save_init_end;
1315 asm "dowarn", dowarn unless $PERL56; 1316 asm "dowarn", dowarn unless $PERL56;
1316 1317
1317 { 1318 {
1318 no strict 'refs'; 1319 no strict 'refs';
1319 nice "<DATA>"; 1320 nice "<DATA>";
1320 my $dh = $PERL56 ? *main::DATA : *{ defstash->NAME . "::DATA" }; 1321 my $dh = $PERL56 ? *main::DATA : *{ defstash->NAME . "::DATA" };
1321 unless ( eof $dh ) { 1322 unless ( eof $dh ) {
1322 local undef $/; 1323 local undef $/;
1323 asm "data", ord 'D' if !$PERL56; 1324 asm "data", ord 'D' if !$PERL56;
1324 print <$dh>; 1325 print <$dh>;
1325 } 1326 }
1326 else { 1327 else {
1327 asm "ret"; 1328 asm "ret";
1328 } 1329 }
1329 } 1330 }
1330 1331
1331 endasm; 1332 endasm;
1332 } 1333 }
1333 } 1334 }
1334 1335
1335 1; 1336 1;
1336 1337
1337 =head1 NAME 1338 =head1 NAME
1338 1339
1339 B::Bytecode - Perl compiler's bytecode backend 1340 B::Bytecode - Perl compiler's bytecode backend
1340 1341
1341 =head1 SYNOPSIS 1342 =head1 SYNOPSIS
1342 1343
1343 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl> 1344 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
1344 1345
1345 =head1 DESCRIPTION 1346 =head1 DESCRIPTION
1346 1347
1347 Compiles a Perl script into a bytecode format that could be loaded 1348 Compiles a Perl script into a bytecode format that could be loaded
1348 later by the ByteLoader module and executed as a regular Perl script. 1349 later by the ByteLoader module and executed as a regular Perl script.
1349 This saves time for the optree parsing and compilation and space for 1350 This saves time for the optree parsing and compilation and space for
1350 the sourcecode in memory. 1351 the sourcecode in memory.
1351 1352
1352 =head1 EXAMPLE 1353 =head1 EXAMPLE
1353 1354
1354 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"' 1355 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
1355 $ perl hi 1356 $ perl hi
1356 hi! 1357 hi!
1357 1358
1358 =head1 OPTIONS 1359 =head1 OPTIONS
1359 1360
1360 =over 4 1361 =over 4
1361 1362
1362 =item B<-H> 1363 =item B<-H>
1363 1364
1364 Prepend a C<use ByteLoader VERSION;> line to the produced bytecode. 1365 Prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
1365 This way you will not need to add C<-MByteLoader> to your perl command-line. 1366 This way you will not need to add C<-MByteLoader> to your perl command-line.
1366 1367
1367 =item B<-i> includeall 1368 =item B<-i> includeall
1368 1369
1369 Include all used packages and its symbols. Does no run-time require from 1370 Include all used packages and its symbols. Does no run-time require from
1370 BEGIN blocks (C<use> package). 1371 BEGIN blocks (C<use> package).
1371 1372
1372 This creates bigger and more independent code, but is more error prone and 1373 This creates bigger and more independent code, but is more error prone and
1373 does not support pre-compiled C<.pmc> modules. 1374 does not support pre-compiled C<.pmc> modules.
1374 1375
1375 =item B<-b> savebegin 1376 =item B<-b> savebegin
1376 1377
1377 Save all the BEGIN blocks. 1378 Save all the BEGIN blocks.
1378 1379
1379 Normally only BEGIN blocks that C<require> 1380 Normally only BEGIN blocks that C<require>
1380 other files (ex. C<use Foo;>) or push|unshift 1381 other files (ex. C<use Foo;>) or push|unshift
1381 to @INC are saved. 1382 to @INC are saved.
1382 1383
1383 =item B<-k> 1384 =item B<-k>
1384 1385
1385 Keep the syntax tree - it is stripped by default. 1386 Keep the syntax tree - it is stripped by default.
1386 1387
1387 =item B<-o>I<outfile> 1388 =item B<-o>I<outfile>
1388 1389
1389 Put the bytecode in <outfile> instead of dumping it to STDOUT. 1390 Put the bytecode in <outfile> instead of dumping it to STDOUT.
1390 1391
1391 =item B<-s> 1392 =item B<-s>
1392 1393
1393 Scan the script for C<# line ..> directives and for <goto LABEL> 1394 Scan the script for C<# line ..> directives and for <goto LABEL>
1394 expressions. When gotos are found keep the syntax tree. 1395 expressions. When gotos are found keep the syntax tree.
1395 1396
1396 =item B<-S> 1397 =item B<-S>
1397 1398
1398 Output assembler source rather than piping it through the assembler 1399 Output assembler source rather than piping it through the assembler
1399 and outputting bytecode. 1400 and outputting bytecode.
1400 Without C<-q> the assembler source is commented. 1401 Without C<-q> the assembler source is commented.
1401 1402
1402 =item B<-m> 1403 =item B<-m>
1403 1404
1404 Compile to a F<.pmc> module rather than to a single standalone F<.plc> program. 1405 Compile to a F<.pmc> module rather than to a single standalone F<.plc> program.
1405 1406
1406 Currently this just means that the bytecodes for initialising C<main_start>, 1407 Currently this just means that the bytecodes for initialising C<main_start>,
1407 C<main_root>, C<main_cv> and C<curpad> are omitted. 1408 C<main_root>, C<main_cv> and C<curpad> are omitted.
1408 1409
1409 =item B<-u>I<package> 1410 =item B<-u>I<package>
1410 1411
1411 "use package." Might be needed of the package is not automatically detected. 1412 "use package." Might be needed of the package is not automatically detected.
1412 1413
1413 =item B<-f>I<file> 1414 =item B<-f>I<file>
1414 1415
1415 Include file. If not C<-i> define all symbols in the given included 1416 Include file. If not C<-i> define all symbols in the given included
1416 source file. C<-i> would all included files, C<-f> only a certain file - full path needed. 1417 source file. C<-i> would all included files, C<-f> only a certain file - full path needed.
1417 1418
1418 =item B<-q> 1419 =item B<-q>
1419 1420
1420 Be quiet. 1421 Be quiet.
1421 1422
1422 =item B<-v> 1423 =item B<-v>
1423 1424
1424 Be verbose. 1425 Be verbose.
1425 1426
1426 =item B<-TI> 1427 =item B<-TI>
1427 1428
1428 Restore full @INC for running within the CORE testsuite. 1429 Restore full @INC for running within the CORE testsuite.
1429 1430
1430 =item B<-TF> I<cop file> 1431 =item B<-TF> I<cop file>
1431 1432
1432 Set the COP file - for running within the CORE testsuite. 1433 Set the COP file - for running within the CORE testsuite.
1433 1434
1434 =item B<-Do> 1435 =item B<-Do>
1435 1436
1436 OPs, prints each OP as it's processed 1437 OPs, prints each OP as it's processed
1437 1438
1438 =item B<-DM> 1439 =item B<-DM>
1439 1440
1440 Debugging flag for more verbose STDERR output. 1441 Debugging flag for more verbose STDERR output.
1441 1442
1442 B<M> for Magic and Matches. 1443 B<M> for Magic and Matches.
1443 1444
1444 =item B<-DG> 1445 =item B<-DG>
1445 1446
1446 Debug GV's 1447 Debug GV's
1447 1448
1448 =item B<-DA> 1449 =item B<-DA>
1449 1450
1450 Set developer B<A>ssertions, to help find possible obj-indices out of range. 1451 Set developer B<A>ssertions, to help find possible obj-indices out of range.
1451 1452
1452 =back 1453 =back
1453 1454
1454 =head1 KNOWN BUGS 1455 =head1 KNOWN BUGS
1455 1456
1456 =over 4 1457 =over 4
1457 1458
1458 =item * 1459 =item *
1459 1460
1460 5.10 threaded fails with setting the wrong MATCH op_pmflags 1461 5.10 threaded fails with setting the wrong MATCH op_pmflags
1461 5.10 non-threaded fails calling anoncode, ... 1462 5.10 non-threaded fails calling anoncode, ...
1462 1463
1463 =item * 1464 =item *
1464 1465
1465 C<BEGIN { goto A: while 1; A: }> won't even compile. 1466 C<BEGIN { goto A: while 1; A: }> won't even compile.
1466 1467
1467 =item * 1468 =item *
1468 1469
1469 C<?...?> and C<reset> do not work as expected. 1470 C<?...?> and C<reset> do not work as expected.
1470 1471
1471 =item * 1472 =item *
1472 1473
1473 variables in C<(?{ ... })> constructs are not properly scoped. 1474 variables in C<(?{ ... })> constructs are not properly scoped.
1474 1475
1475 =item * 1476 =item *
1476 1477
1477 Scripts that use source filters will fail miserably. 1478 Scripts that use source filters will fail miserably.
1478 1479
1479 =item * 1480 =item *
1480 1481
1481 Special GV's fail. 1482 Special GV's fail.
1482 1483
1483 =back 1484 =back
1484 1485
1485 =head1 NOTICE 1486 =head1 NOTICE
1486 1487
1487 There are also undocumented bugs and options. 1488 There are also undocumented bugs and options.
1488 1489
1489 =head1 AUTHORS 1490 =head1 AUTHORS
1490 1491
1491 Originally written by Malcolm Beattie 1996 and 1492 Originally written by Malcolm Beattie 1996 and
1492 modified by Benjamin Stuhl <sho_pi@hotmail.com>. 1493 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
1493 1494
1494 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d. 1495 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
1495 1496
1496 Enhanced by Reini Urban <rurban@cpan.org>, 2008-2011 1497 Enhanced by Reini Urban <rurban@cpan.org>, 2008-2011
1497 1498
1498 =cut 1499 =cut
1499 1500
1500 # Local Variables: 1501 # Local Variables:
1501 # mode: cperl 1502 # mode: cperl
1502 # cperl-indent-level: 2 1503 # cperl-indent-level: 2
1503 # fill-column: 100 1504 # fill-column: 100
1504 # End: 1505 # End:
1505 # vim: expandtab shiftwidth=2: 1506 # vim: expandtab shiftwidth=2:
Powered by Google Project Hosting