My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
Changes to /lib/B/CC.pm
12359ce68210 vs. 3fc61aa69af2 Compare: vs.  Format:
Revision 3fc61aa69af2
Go to: 
Project members, sign in to write a code review
/lib/B/CC.pm   12359ce68210 /lib/B/CC.pm   3fc61aa69af2
1 # CC.pm 1 # CC.pm
2 # 2 #
3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie 3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
4 # Copyright (c) 2009, 2010, 2011 Reini Urban 4 # Copyright (c) 2009, 2010, 2011 Reini Urban
5 # Copyright (c) 2010 Heinz Knutzen 5 # Copyright (c) 2010 Heinz Knutzen
6 # Copyright (c) 2012 cPanel Inc 6 # Copyright (c) 2012 cPanel Inc
7 # 7 #
8 # You may distribute under the terms of either the GNU General Public 8 # You may distribute under the terms of either the GNU General Public
9 # License or the Artistic License, as specified in the README file. 9 # License or the Artistic License, as specified in the README file.
10 10
11 =head1 NAME 11 =head1 NAME
12 12
13 B::CC - Perl compiler's optimized C translation backend 13 B::CC - Perl compiler's optimized C translation backend
14 14
15 =head1 SYNOPSIS 15 =head1 SYNOPSIS
16 16
17 perl -MO=CC[,OPTIONS] foo.pl 17 perl -MO=CC[,OPTIONS] foo.pl
18 18
19 =head1 DESCRIPTION 19 =head1 DESCRIPTION
20 20
21 This compiler backend takes Perl source and generates C source code 21 This compiler backend takes Perl source and generates C source code
22 corresponding to the flow of your program with unrolled ops and optimised 22 corresponding to the flow of your program with unrolled ops and optimised
23 stack handling and lexicals variable types. In other words, this backend is 23 stack handling and lexicals variable types. In other words, this backend is
24 somewhat a "real" compiler in the sense that many people think about 24 somewhat a "real" compiler in the sense that many people think about
25 compilers. Note however that, currently, it is a very poor compiler in that 25 compilers. Note however that, currently, it is a very poor compiler in that
26 although it generates (mostly, or at least sometimes) correct code, it 26 although it generates (mostly, or at least sometimes) correct code, it
27 performs relatively few optimisations. This will change as the compiler and 27 performs relatively few optimisations. This will change as the compiler and
28 the types develops. The result is that running an executable compiled with 28 the types develops. The result is that running an executable compiled with
29 this backend may start up more quickly than running the original Perl program 29 this backend may start up more quickly than running the original Perl program
30 (a feature shared by the B<C> compiler backend--see L<B::C>) and may also 30 (a feature shared by the B<C> compiler backend--see L<B::C>) and may also
31 execute slightly faster. This is by no means a good optimising compiler--yet. 31 execute slightly faster. This is by no means a good optimising compiler--yet.
32 32
33 =head1 OPTIONS 33 =head1 OPTIONS
34 34
35 If there are any non-option arguments, they are taken to be 35 If there are any non-option arguments, they are taken to be
36 names of objects to be saved (probably doesn't work properly yet). 36 names of objects to be saved (probably doesn't work properly yet).
37 Without extra arguments, it saves the main program. 37 Without extra arguments, it saves the main program.
38 38
39 =over 4 39 =over 4
40 40
41 =item B<-ofilename> 41 =item B<-ofilename>
42 42
43 Output to filename instead of STDOUT 43 Output to filename instead of STDOUT
44 44
45 =item B<-c> 45 =item B<-c>
46 46
47 Check and abort. 47 Check and abort.
48 48
49 Compiles and prints only warnings, but does not emit C code. 49 Compiles and prints only warnings, but does not emit C code.
50 50
51 =item B<-v> 51 =item B<-v>
52 52
53 Verbose compilation (prints a few compilation stages). 53 Verbose compilation (prints a few compilation stages).
54 54
55 =item B<--> 55 =item B<-->
56 56
57 Force end of options 57 Force end of options
58 58
59 =item B<-uPackname> 59 =item B<-uPackname>
60 60
61 Force apparently unused subs from package Packname to be compiled. 61 Force apparently unused subs from package Packname to be compiled.
62 This allows programs to use eval "foo()" even when sub foo is never 62 This allows programs to use eval "foo()" even when sub foo is never
63 seen to be used at compile time. The down side is that any subs which 63 seen to be used at compile time. The down side is that any subs which
64 really are never used also have code generated. This option is 64 really are never used also have code generated. This option is
65 necessary, for example, if you have a signal handler foo which you 65 necessary, for example, if you have a signal handler foo which you
66 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just 66 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
67 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> 67 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
68 options. The compiler tries to figure out which packages may possibly 68 options. The compiler tries to figure out which packages may possibly
69 have subs in which need compiling but the current version doesn't do 69 have subs in which need compiling but the current version doesn't do
70 it very well. In particular, it is confused by nested packages (i.e. 70 it very well. In particular, it is confused by nested packages (i.e.
71 of the form C<A::B>) where package C<A> does not contain any subs. 71 of the form C<A::B>) where package C<A> does not contain any subs.
72 72
73 =item B<-UPackname> "unuse" skip Package 73 =item B<-UPackname> "unuse" skip Package
74 74
75 Ignore all subs from Package to be compiled. 75 Ignore all subs from Package to be compiled.
76 76
77 Certain packages might not be needed at run-time, even if the pessimistic 77 Certain packages might not be needed at run-time, even if the pessimistic
78 walker detects it. 78 walker detects it.
79 79
80 =item B<-mModulename> 80 =item B<-mModulename>
81 81
82 Instead of generating source for a runnable executable, generate 82 Instead of generating source for a runnable executable, generate
83 source for an XSUB module. The boot_Modulename function (which 83 source for an XSUB module. The boot_Modulename function (which
84 DynaLoader can look for) does the appropriate initialisation and runs 84 DynaLoader can look for) does the appropriate initialisation and runs
85 the main part of the Perl source that is being compiled. 85 the main part of the Perl source that is being compiled.
86 86
87 =item B<-nInitname> 87 =item B<-nInitname>
88 88
89 Provide a different init name for additional objects added via cmdline. 89 Provide a different init name for additional objects added via cmdline.
90 90
91 =item B<-strict> 91 =item B<-strict>
92 92
93 With a DEBUGGING perl compile-time errors for range and flip without 93 With a DEBUGGING perl compile-time errors for range and flip without
94 compile-time context are only warnings. 94 compile-time context are only warnings.
95 With C<-strict> these warnings are fatal, otherwise only run-time errors occur. 95 With C<-strict> these warnings are fatal, otherwise only run-time errors occur.
96 96
97 =item B<-On> 97 =item B<-On>
98 98
99 Optimisation level (n = 0, 1, 2). B<-O> means B<-O1>. 99 Optimisation level (n = 0, 1, 2). B<-O> means B<-O1>.
100 100
101 The following L<B::C> optimisations are applied automatically: 101 The following L<B::C> optimisations are applied automatically:
102 102
103 optimize_warn_sv save_data_fh av-init2|av_init save_sig destruct 103 optimize_warn_sv save_data_fh av-init2|av_init save_sig destruct
104 pv_copy_on_grow 104 pv_copy_on_grow
105 105
106 B<-O1> sets B<-ffreetmps-each-bblock>. 106 B<-O1> sets B<-ffreetmps-each-bblock>.
107 107
108 B<-O2> adds B<-ffreetmps-each-loop> and B<-fno-destruct> from L<B::C>. 108 B<-O2> adds B<-ffreetmps-each-loop> and B<-fno-destruct> from L<B::C>.
109 109
110 B<-fomit-taint> and B<-fslow-signals> must be set explicitly. 110 B<-fomit-taint> and B<-fslow-signals> must be set explicitly.
111 111
112 =item B<-f>C<OPTIM> 112 =item B<-f>C<OPTIM>
113 113
114 Force optimisations on or off one at a time. 114 Force optimisations on or off one at a time.
115 Unknown optimizations are passed down to L<B::C>. 115 Unknown optimizations are passed down to L<B::C>.
116 116
117 =item B<-ffreetmps-each-bblock> 117 =item B<-ffreetmps-each-bblock>
118 118
119 Delays FREETMPS from the end of each statement to the end of the each 119 Delays FREETMPS from the end of each statement to the end of the each
120 basic block. 120 basic block.
121 121
122 Enabled with B<-O1>. 122 Enabled with B<-O1>.
123 123
124 =item B<-ffreetmps-each-loop> 124 =item B<-ffreetmps-each-loop>
125 125
126 Delays FREETMPS from the end of each statement to the end of the group 126 Delays FREETMPS from the end of each statement to the end of the group
127 of basic blocks forming a loop. At most one of the freetmps-each-* 127 of basic blocks forming a loop. At most one of the freetmps-each-*
128 options can be used. 128 options can be used.
129 129
130 Enabled with B<-O2>. 130 Enabled with B<-O2>.
131 131
132 =item B<-fno-inline-ops> 132 =item B<-fno-inline-ops>
133 133
134 Do not inline calls to certain small pp ops. 134 Do not inline calls to certain small pp ops.
135 135
136 Most of the inlinable ops were already inlined. 136 Most of the inlinable ops were already inlined.
137 Turns off inlining for some new ops. 137 Turns off inlining for some new ops.
138 138
139 AUTOMATICALLY inlined: 139 AUTOMATICALLY inlined:
140 140
141 pp_null pp_stub pp_unstack pp_and pp_andassign pp_or pp_orassign pp_cond_expr 141 pp_null pp_stub pp_unstack pp_and pp_andassign pp_or pp_orassign pp_cond_expr
142 pp_padsv pp_const pp_nextstate pp_dbstate pp_rv2gv pp_sort pp_gv pp_gvsv 142 pp_padsv pp_const pp_nextstate pp_dbstate pp_rv2gv pp_sort pp_gv pp_gvsv
143 pp_aelemfast pp_ncmp pp_add pp_subtract pp_multiply pp_divide pp_modulo 143 pp_aelemfast pp_ncmp pp_add pp_subtract pp_multiply pp_divide pp_modulo
144 pp_left_shift pp_right_shift pp_i_add pp_i_subtract pp_i_multiply pp_i_divide 144 pp_left_shift pp_right_shift pp_i_add pp_i_subtract pp_i_multiply pp_i_divide
145 pp_i_modulo pp_eq pp_ne pp_lt pp_gt pp_le pp_ge pp_i_eq pp_i_ne pp_i_lt 145 pp_i_modulo pp_eq pp_ne pp_lt pp_gt pp_le pp_ge pp_i_eq pp_i_ne pp_i_lt
146 pp_i_gt pp_i_le pp_i_ge pp_scmp pp_slt pp_sgt pp_sle pp_sge pp_seq pp_sne 146 pp_i_gt pp_i_le pp_i_ge pp_scmp pp_slt pp_sgt pp_sle pp_sge pp_seq pp_sne
147 pp_sassign pp_preinc pp_pushmark pp_list pp_entersub pp_formline pp_goto 147 pp_sassign pp_preinc pp_pushmark pp_list pp_entersub pp_formline pp_goto
148 pp_enterwrite pp_leavesub pp_leavewrite pp_entergiven pp_leavegiven 148 pp_enterwrite pp_leavesub pp_leavewrite pp_entergiven pp_leavegiven
149 pp_entereval pp_dofile pp_require pp_entertry pp_leavetry pp_grepstart 149 pp_entereval pp_dofile pp_require pp_entertry pp_leavetry pp_grepstart
150 pp_mapstart pp_grepwhile pp_mapwhile pp_return pp_range pp_flip pp_flop 150 pp_mapstart pp_grepwhile pp_mapwhile pp_return pp_range pp_flip pp_flop
151 pp_enterloop pp_enteriter pp_leaveloop pp_next pp_redo pp_last pp_subst 151 pp_enterloop pp_enteriter pp_leaveloop pp_next pp_redo pp_last pp_subst
152 pp_substcont 152 pp_substcont
153 153
154 DONE with -finline-ops: 154 DONE with -finline-ops:
155 155
156 pp_enter pp_reset pp_regcreset pp_stringify 156 pp_enter pp_reset pp_regcreset pp_stringify
157 157
158 TODO with -finline-ops: 158 TODO with -finline-ops:
159 159
160 pp_anoncode pp_wantarray pp_srefgen pp_refgen pp_ref pp_trans pp_schop pp_chop 160 pp_anoncode pp_wantarray pp_srefgen pp_refgen pp_ref pp_trans pp_schop pp_chop
161 pp_schomp pp_chomp pp_not pp_sprintf pp_anonlist pp_shift pp_once pp_lock 161 pp_schomp pp_chomp pp_not pp_sprintf pp_anonlist pp_shift pp_once pp_lock
162 pp_rcatline pp_close pp_time pp_alarm pp_av2arylen: no lvalue, pp_length: no 162 pp_rcatline pp_close pp_time pp_alarm pp_av2arylen: no lvalue, pp_length: no
163 magic 163 magic
164 164
165 =item B<-fomit-taint> 165 =item B<-fomit-taint>
166 166
167 Omits generating code for handling perl's tainting mechanism. 167 Omits generating code for handling perl's tainting mechanism.
168 168
169 =item B<-fslow-signals> 169 =item B<-fslow-signals>
170 170
171 Add PERL_ASYNC_CHECK after every op as in the old Perl runloop before 5.13. 171 Add PERL_ASYNC_CHECK after every op as in the old Perl runloop before 5.13.
172 172
173 perl "Safe signals" check the state of incoming signals after every op. 173 perl "Safe signals" check the state of incoming signals after every op.
174 See L<http://perldoc.perl.org/perlipc.html#Deferred-Signals-(Safe-Signals)> 174 See L<http://perldoc.perl.org/perlipc.html#Deferred-Signals-(Safe-Signals)>
175 We trade safety for more speed and delay the execution of non-IO signals 175 We trade safety for more speed and delay the execution of non-IO signals
176 (IO signals are already handled in PerlIO) from after every single Perl op 176 (IO signals are already handled in PerlIO) from after every single Perl op
177 to the same ops as used in 5.14. 177 to the same ops as used in 5.14.
178 178
179 Only with -fslow-signals we get the old slow and safe behaviour. 179 Only with -fslow-signals we get the old slow and safe behaviour.
180 180
181 =item B<-fno-name-magic> 181 =item B<-fno-name-magic>
182 182
183 With the default C<-fname-magic> we infer the SCALAR type for specially named 183 With the default C<-fname-magic> we infer the SCALAR type for specially named
184 locals vars and most ops use C vars then, not the perl vars. 184 locals vars and most ops use C vars then, not the perl vars.
185 Arithmetic and comparison is inlined. Scalar magic is bypassed. 185 Arithmetic and comparison is inlined. Scalar magic is bypassed.
186 186
187 With C<-fno-name-magic> do not infer a local variable type from its name: 187 With C<-fno-name-magic> do not infer a local variable type from its name:
188 188
189 B<_i> suffix for int, B<_d> for double, B<_ir> for register int 189 B<_i> suffix for int, B<_d> for double, B<_ir> for register int
190 190
191 See the experimental C<-ftype-attr> type attributes. 191 See the experimental C<-ftype-attr> type attributes.
192 Currently supported are B<int> and B<double> only. See </load_pad>. 192 Currently supported are B<int> and B<double> only. See </load_pad>.
193 193
194 =item B<-ftype-attr> (DOES NOT WORK YET) 194 =item B<-ftype-attr> (DOES NOT WORK YET)
195 195
196 Experimentally support B<type attributes> for B<int> and B<double>, 196 Experimentally support B<type attributes> for B<int> and B<double>,
197 SCALAR only so far. 197 SCALAR only so far.
198 For most ops new C vars are used then, not the fat perl vars. 198 For most ops new C vars are used then, not the fat perl vars.
199 Very awkward to use until the basic type classes are supported from 199 Very awkward to use until the basic type classes are supported from
200 within core or use types. 200 within core or use types.
201 201
202 Enabled with B<-O2>. See L<TYPES> and </load_pad>. 202 Enabled with B<-O2>. See L<TYPES> and </load_pad>.
203 203
204 =item B<-D> 204 =item B<-D>
205 205
206 Debug options (concatenated or separate flags like C<perl -D>). 206 Debug options (concatenated or separate flags like C<perl -D>).
207 Verbose debugging options are crucial, because the interactive 207 Verbose debugging options are crucial, because the interactive
208 debugger L<Od> adds a lot of ballast to the resulting code. 208 debugger L<Od> adds a lot of ballast to the resulting code.
209 209
210 =item B<-Dr> 210 =item B<-Dr>
211 211
212 Writes debugging output to STDERR just as it's about to write to the 212 Writes debugging output to STDERR just as it's about to write to the
213 program's runtime (otherwise writes debugging info as comments in 213 program's runtime (otherwise writes debugging info as comments in
214 its C output). 214 its C output).
215 215
216 =item B<-DO> 216 =item B<-DO>
217 217
218 Outputs each OP as it's compiled 218 Outputs each OP as it's compiled
219 219
220 =item B<-Ds> 220 =item B<-Ds>
221 221
222 Outputs the contents of the shadow stack at each OP 222 Outputs the contents of the shadow stack at each OP
223 223
224 =item B<-Dp> 224 =item B<-Dp>
225 225
226 Outputs the contents of the shadow pad of lexicals as it's loaded for 226 Outputs the contents of the shadow pad of lexicals as it's loaded for
227 each sub or the main program. 227 each sub or the main program.
228 228
229 =item B<-Dq> 229 =item B<-Dq>
230 230
231 Outputs the name of each fake PP function in the queue as it's about 231 Outputs the name of each fake PP function in the queue as it's about
232 to process it. 232 to process it.
233 233
234 =item B<-Dl> 234 =item B<-Dl>
235 235
236 Output the filename and line number of each original line of Perl 236 Output the filename and line number of each original line of Perl
237 code as it's processed (C<pp_nextstate>). 237 code as it's processed (C<pp_nextstate>).
238 238
239 =item B<-Dt> 239 =item B<-Dt>
240 240
241 Outputs timing information of compilation stages. 241 Outputs timing information of compilation stages.
242 242
243 =item B<-DF> 243 =item B<-DF>
244 244
245 Add Flags info to the code. 245 Add Flags info to the code.
246 246
247 =back 247 =back
248 248
249 =head1 NOTABLE FUNCTIONS 249 =head1 NOTABLE FUNCTIONS
250 250
251 =cut 251 =cut
252 252
253 253
254 package B::CC; 254 package B::CC;
255 255
256 our $VERSION = '1.13'; 256 our $VERSION = '1.13';
257 257
258 # Start registering the L<types> namespaces. 258 # Start registering the L<types> namespaces.
259 $main::int::B_CC = $main::double::B_CC = $main::string::B_CC = $VERSION; 259 $main::int::B_CC = $main::double::B_CC = $main::string::B_CC = $VERSION;
260 260
261 use Config; 261 use Config;
262 use strict; 262 use strict;
263 #use 5.008; 263 #use 5.008;
264 use B qw(main_start main_root class comppadlist peekop svref_2object 264 use B qw(main_start main_root class comppadlist peekop svref_2object
265 timing_info init_av end_av sv_undef 265 timing_info init_av end_av sv_undef
266 OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_WANT 266 OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_WANT
267 OPf_MOD OPf_STACKED OPf_SPECIAL 267 OPf_MOD OPf_STACKED OPf_SPECIAL
268 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV 268 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
269 OPpDEREF OPpFLIP_LINENUM G_VOID G_SCALAR G_ARRAY ); 269 OPpDEREF OPpFLIP_LINENUM G_VOID G_SCALAR G_ARRAY );
270 #CXt_NULL CXt_SUB CXt_EVAL CXt_SUBST CXt_BLOCK 270 #CXt_NULL CXt_SUB CXt_EVAL CXt_SUBST CXt_BLOCK
271 use B::C qw(save_unused_subs objsym init_sections mark_unused mark_skip 271 use B::C qw(save_unused_subs objsym init_sections mark_unused mark_skip
272 output_all output_boilerplate output_main output_main_rest fixup_ppaddr save_sig 272 output_all output_boilerplate output_main output_main_rest fixup_ppaddr save_sig
273 inc_cleanup); 273 inc_cleanup);
274 use B::Bblock qw(find_leaders); 274 use B::Bblock qw(find_leaders);
275 use B::Stackobj qw(:types :flags); 275 use B::Stackobj qw(:types :flags);
276 use B::C::Flags; 276 use B::C::Flags;
277 # use attributes qw(get reftype); 277 # use attributes qw(get reftype);
278 278
279 @B::OP::ISA = qw(B::NULLOP B); # support -Do 279 @B::OP::ISA = qw(B::NULLOP B); # support -Do
280 @B::LISTOP::ISA = qw(B::BINOP B); # support -Do 280 @B::LISTOP::ISA = qw(B::BINOP B); # support -Do
281 281
282 # These should probably be elsewhere 282 # These should probably be elsewhere
283 # Flags for $op->flags 283 # Flags for $op->flags
284 284
285 my $module; # module name (when compiled with -m) 285 my $module; # module name (when compiled with -m)
286 my %done; # hash keyed by $$op of leaders of basic blocks 286 my %done; # hash keyed by $$op of leaders of basic blocks
287 # which have already been done. 287 # which have already been done.
288 my $leaders; # ref to hash of basic block leaders. Keys are $$op 288 my $leaders; # ref to hash of basic block leaders. Keys are $$op
289 # addresses, values are the $op objects themselves. 289 # addresses, values are the $op objects themselves.
290 my @bblock_todo; # list of leaders of basic blocks that need visiting 290 my @bblock_todo; # list of leaders of basic blocks that need visiting
291 # sometime. 291 # sometime.
292 my @cc_todo; # list of tuples defining what PP code needs to be 292 my @cc_todo; # list of tuples defining what PP code needs to be
293 # saved (e.g. CV, main or PMOP repl code). Each tuple 293 # saved (e.g. CV, main or PMOP repl code). Each tuple
294 # is [$name, $root, $start, @padlist]. PMOP repl code 294 # is [$name, $root, $start, @padlist]. PMOP repl code
295 # tuples inherit padlist. 295 # tuples inherit padlist.
296 my %cc_pp_sub; # hashed names of pp_sub functions already saved 296 my %cc_pp_sub; # hashed names of pp_sub functions already saved
297 my @stack; # shadows perl's stack when contents are known. 297 my @stack; # shadows perl's stack when contents are known.
298 # Values are objects derived from class B::Stackobj 298 # Values are objects derived from class B::Stackobj
299 my @pad; # Lexicals in current pad as Stackobj-derived objects 299 my @pad; # Lexicals in current pad as Stackobj-derived objects
300 my @padlist; # Copy of current padlist so PMOP repl code can find it 300 my @padlist; # Copy of current padlist so PMOP repl code can find it
301 my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo 301 my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
302 # This covers only a small part of the perl cxstack 302 # This covers only a small part of the perl cxstack
303 my $labels; # hashref to array of op labels 303 my $labels; # hashref to array of op labels
304 my %constobj; # OP_CONST constants as Stackobj-derived objects 304 my %constobj; # OP_CONST constants as Stackobj-derived objects
305 # keyed by $$sv. 305 # keyed by $$sv.
306 my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic 306 my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
307 # block or even to the end of each loop of blocks, 307 # block or even to the end of each loop of blocks,
308 # depending on optimisation options. 308 # depending on optimisation options.
309 my $know_op = 0; # Set when C variable op already holds the right op 309 my $know_op = 0; # Set when C variable op already holds the right op
310 # (from an immediately preceding DOOP(ppname)). 310 # (from an immediately preceding DOOP(ppname)).
311 my $errors = 0; # Number of errors encountered 311 my $errors = 0; # Number of errors encountered
312 my $op_count = 0; # for B::compile_stats on verbose 312 my $op_count = 0; # for B::compile_stats on verbose
313 my %no_stack; # PP names which don't need save pp restore stack 313 my %no_stack; # PP names which don't need save pp restore stack
314 my %skip_stack; # PP names which don't need write_back_stack (empty) 314 my %skip_stack; # PP names which don't need write_back_stack (empty)
315 my %skip_lexicals; # PP names which don't need write_back_lexicals 315 my %skip_lexicals; # PP names which don't need write_back_lexicals
316 my %skip_invalidate; # PP names which don't need invalidate_lexicals 316 my %skip_invalidate; # PP names which don't need invalidate_lexicals
317 my %ignore_op; # ops which do nothing except returning op_next 317 my %ignore_op; # ops which do nothing except returning op_next
318 my %need_curcop; # ops which need PL_curcop 318 my %need_curcop; # ops which need PL_curcop
319 my $package_pv; # sv->pv of previous op for method_named 319 my $package_pv; # sv->pv of previous op for method_named
320 320
321 my %lexstate; # state of padsvs at the start of a bblock 321 my %lexstate; # state of padsvs at the start of a bblock
322 my ( $verbose, $check ); 322 my ( $verbose, $check );
323 my ( $entertry_defined, $vivify_ref_defined ); 323 my ( $entertry_defined, $vivify_ref_defined );
324 my ( $init_name, %debug, $strict ); 324 my ( $init_name, %debug, $strict );
325 325
326 # Optimisation options. On the command line, use hyphens instead of 326 # Optimisation options. On the command line, use hyphens instead of
327 # underscores for compatibility with gcc-style options. We use 327 # underscores for compatibility with gcc-style options. We use
328 # underscores here because they are OK in (strict) barewords. 328 # underscores here because they are OK in (strict) barewords.
329 # Disable with -fno- 329 # Disable with -fno-
330 my ( $freetmps_each_bblock, $freetmps_each_loop, $inline_ops, $omit_taint, 330 my ( $freetmps_each_bblock, $freetmps_each_loop, $inline_ops, $omit_taint,
331 $slow_signals, $name_magic, $type_attr, %c_optimise ); 331 $slow_signals, $name_magic, $type_attr, %c_optimise );
332 $inline_ops = 1 unless $^O eq 'MSWin32'; # Win32 cannot link to unexported pp_op() XXX 332 $inline_ops = 1 unless $^O eq 'MSWin32'; # Win32 cannot link to unexported pp_op() XXX
333 $name_magic = 1; 333 $name_magic = 1;
334 my %optimise = ( 334 my %optimise = (
335 freetmps_each_bblock => \$freetmps_each_bblock, # -O1 335 freetmps_each_bblock => \$freetmps_each_bblock, # -O1
336 freetmps_each_loop => \$freetmps_each_loop, # -O2 336 freetmps_each_loop => \$freetmps_each_loop, # -O2
337 inline_ops => \$inline_ops, # not on Win32 337 inline_ops => \$inline_ops, # not on Win32
338 omit_taint => \$omit_taint, 338 omit_taint => \$omit_taint,
339 slow_signals => \$slow_signals, 339 slow_signals => \$slow_signals,
340 name_magic => \$name_magic, 340 name_magic => \$name_magic,
341 type_attr => \$type_attr 341 type_attr => \$type_attr
342 ); 342 );
343 my %async_signals = map { $_ => 1 } # 5.14 ops which do PERL_ASYNC_CHECK 343 my %async_signals = map { $_ => 1 } # 5.14 ops which do PERL_ASYNC_CHECK
344 qw(wait waitpid nextstate and cond_expr unstack or subst dorassign); 344 qw(wait waitpid nextstate and cond_expr unstack or subst dorassign);
345 # perl patchlevel to generate code for (defaults to current patchlevel) 345 # perl patchlevel to generate code for (defaults to current patchlevel)
346 my $patchlevel = int( 0.5 + 1000 * ( $] - 5 ) ); # XXX unused? 346 my $patchlevel = int( 0.5 + 1000 * ( $] - 5 ) ); # XXX unused?
347 my $MULTI = $Config{usemultiplicity}; 347 my $MULTI = $Config{usemultiplicity};
348 my $ITHREADS = $Config{useithreads}; 348 my $ITHREADS = $Config{useithreads};
349 my $PERL510 = ( $] >= 5.009005 ); 349 my $PERL510 = ( $] >= 5.009005 );
350 my $PERL512 = ( $] >= 5.011 ); 350 my $PERL512 = ( $] >= 5.011 );
351 351
352 my $SVt_PVLV = $PERL510 ? 10 : 9; 352 my $SVt_PVLV = $PERL510 ? 10 : 9;
353 my $SVt_PVAV = $PERL510 ? 11 : 10; 353 my $SVt_PVAV = $PERL510 ? 11 : 10;
354 # use sub qw(CXt_LOOP_PLAIN CXt_LOOP); 354 # use sub qw(CXt_LOOP_PLAIN CXt_LOOP);
355 if ($PERL512) { 355 if ($PERL512) {
356 sub CXt_LOOP_PLAIN {5} # CXt_LOOP_FOR CXt_LOOP_LAZYSV CXt_LOOP_LAZYIV 356 sub CXt_LOOP_PLAIN {5} # CXt_LOOP_FOR CXt_LOOP_LAZYSV CXt_LOOP_LAZYIV
357 } else { 357 } else {
358 sub CXt_LOOP {3} 358 sub CXt_LOOP {3}
359 } 359 }
360 sub CxTYPE_no_LOOP { 360 sub CxTYPE_no_LOOP {
361 $PERL512 361 $PERL512
362 ? ( $_[0]->{type} < 4 or $_[0]->{type} > 7 ) 362 ? ( $_[0]->{type} < 4 or $_[0]->{type} > 7 )
363 : $_[0]->{type} != 3 363 : $_[0]->{type} != 3
364 } 364 }
365 365
366 # Could rewrite push_runtime() and output_runtime() to use a 366 # Could rewrite push_runtime() and output_runtime() to use a
367 # temporary file if memory is at a premium. 367 # temporary file if memory is at a premium.
368 my $ppname; # name of current fake PP function 368 my $ppname; # name of current fake PP function
369 my $runtime_list_ref; 369 my $runtime_list_ref;
370 my $declare_ref; # Hash ref keyed by C variable type of declarations. 370 my $declare_ref; # Hash ref keyed by C variable type of declarations.
371 371
372 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref] 372 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
373 # tuples to be written out. 373 # tuples to be written out.
374 374
375 my ( $init, $decl ); 375 my ( $init, $decl );
376 376
377 sub init_hash { 377 sub init_hash {
378 map { $_ => 1 } @_; 378 map { $_ => 1 } @_;
379 } 379 }
380 380
381 # 381 #
382 # Initialise the hashes for the default PP functions where we can avoid 382 # Initialise the hashes for the default PP functions where we can avoid
383 # either stack save/restore,write_back_stack, write_back_lexicals or invalidate_lexicals. 383 # either stack save/restore,write_back_stack, write_back_lexicals or invalidate_lexicals.
384 # XXX We should really take some of this info from Opcodes (was: CORE opcode.pl) 384 # XXX We should really take some of this info from Opcodes (was: CORE opcode.pl)
385 # 385 #
386 # no args and no return value = Opcodes::argnum 0 386 # no args and no return value = Opcodes::argnum 0
387 %no_stack = init_hash qw(pp_unstack pp_break pp_continue); 387 %no_stack = init_hash qw(pp_unstack pp_break pp_continue);
388 # pp_enter pp_leave, use/change global stack. 388 # pp_enter pp_leave, use/change global stack.
389 #skip write_back_stack (no args) 389 #skip write_back_stack (no args)
390 %skip_stack = init_hash qw(pp_enter pp_leave pp_nextstate pp_dbstate); 390 %skip_stack = init_hash qw(pp_enter pp_leave pp_nextstate pp_dbstate);
391 # which ops do not read pad vars 391 # which ops do not read pad vars
392 %skip_lexicals = init_hash qw(pp_enter pp_enterloop pp_leave pp_nextstate pp_dbstate); 392 %skip_lexicals = init_hash qw(pp_enter pp_enterloop pp_leave pp_nextstate pp_dbstate);
393 # which ops no not write to pad vars 393 # which ops no not write to pad vars
394 %skip_invalidate = init_hash qw(pp_enter pp_enterloop pp_leave pp_nextstate pp_dbstate 394 %skip_invalidate = init_hash qw(pp_enter pp_enterloop pp_leave pp_nextstate pp_dbstate
395 pp_return pp_leavesub pp_list pp_pushmark 395 pp_return pp_leavesub pp_list pp_pushmark
396 pp_anonlist 396 pp_anonlist
397 ); 397 );
398 398
399 %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller 399 %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
400 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile 400 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
401 pp_entertry pp_enterloop pp_enteriter pp_entersub pp_entergiven 401 pp_entertry pp_enterloop pp_enteriter pp_entersub pp_entergiven
402 pp_enter pp_method); 402 pp_enter pp_method);
403 %ignore_op = init_hash qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null); 403 %ignore_op = init_hash qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null);
404 404
405 { # block necessary for caller to work 405 { # block necessary for caller to work
406 my $caller = caller; 406 my $caller = caller;
407 if ( $caller eq 'O' ) { 407 if ( $caller eq 'O' ) {
408 require XSLoader; 408 require XSLoader;
409 XSLoader::load('B::C'); # for r-magic only 409 XSLoader::load('B::C'); # for r-magic only
410 } 410 }
411 } 411 }
412 412
413 sub debug { 413 sub debug {
414 if ( $debug{runtime} ) { 414 if ( $debug{runtime} ) {
415 # TODO: fix COP to callers line number 415 # TODO: fix COP to callers line number
416 warn(@_) if $verbose; 416 warn(@_) if $verbose;
417 } 417 }
418 else { 418 else {
419 my @tmp = @_; 419 my @tmp = @_;
420 runtime( map { chomp; "/* $_ */" } @tmp ); 420 runtime( map { chomp; "/* $_ */" } @tmp );
421 } 421 }
422 } 422 }
423 423
424 sub declare { 424 sub declare {
425 my ( $type, $var ) = @_; 425 my ( $type, $var ) = @_;
426 push( @{ $declare_ref->{$type} }, $var ); 426 push( @{ $declare_ref->{$type} }, $var );
427 } 427 }
428 428
429 sub push_runtime { 429 sub push_runtime {
430 push( @$runtime_list_ref, @_ ); 430 push( @$runtime_list_ref, @_ );
431 warn join( "\n", @_ ) . "\n" if $debug{runtime}; 431 warn join( "\n", @_ ) . "\n" if $debug{runtime};
432 } 432 }
433 433
434 sub save_runtime { 434 sub save_runtime {
435 push( @pp_list, [ $ppname, $runtime_list_ref, $declare_ref ] ); 435 push( @pp_list, [ $ppname, $runtime_list_ref, $declare_ref ] );
436 } 436 }
437 437
438 sub output_runtime { 438 sub output_runtime {
439 my $ppdata; 439 my $ppdata;
440 print qq(\n#include "cc_runtime.h"\n); 440 print qq(\n#include "cc_runtime.h"\n);
441 # CC coverage: 12, 32 441 # CC coverage: 12, 32
442 442
443 # Perls >=5.8.9 have a broken PP_ENTERTRY. See PERL_FLEXIBLE_EXCEPTIONS in cop.h 443 # Perls >=5.8.9 have a broken PP_ENTERTRY. See PERL_FLEXIBLE_EXCEPTIONS in cop.h
444 # Fixed in CORE with 5.11.4 444 # Fixed in CORE with 5.11.4
445 print' 445 print'
446 #undef PP_ENTERTRY 446 #undef PP_ENTERTRY
447 #define PP_ENTERTRY(label) \ 447 #define PP_ENTERTRY(label) \
448 STMT_START { \ 448 STMT_START { \
449 dJMPENV; \ 449 dJMPENV; \
450 int ret; \ 450 int ret; \
451 JMPENV_PUSH(ret); \ 451 JMPENV_PUSH(ret); \
452 switch (ret) { \ 452 switch (ret) { \
453 case 1: JMPENV_POP; JMPENV_JUMP(1);\ 453 case 1: JMPENV_POP; JMPENV_JUMP(1);\
454 case 2: JMPENV_POP; JMPENV_JUMP(2);\ 454 case 2: JMPENV_POP; JMPENV_JUMP(2);\
455 case 3: JMPENV_POP; SPAGAIN; goto label;\ 455 case 3: JMPENV_POP; SPAGAIN; goto label;\
456 } \ 456 } \
457 } STMT_END' 457 } STMT_END'
458 if $entertry_defined and $] < 5.011004; 458 if $entertry_defined and $] < 5.011004;
459 # XXX need to find out when PERL_FLEXIBLE_EXCEPTIONS were actually active. 459 # XXX need to find out when PERL_FLEXIBLE_EXCEPTIONS were actually active.
460 # 5.6.2 not, 5.8.9 not. coverage 32 460 # 5.6.2 not, 5.8.9 not. coverage 32
461 461
462 # test 12. Used by entereval + dofile 462 # test 12. Used by entereval + dofile
463 if ($PERL510 or $MULTI) { 463 if ($PERL510 or $MULTI) {
464 # Threads error Bug#55302: too few arguments to function 464 # Threads error Bug#55302: too few arguments to function
465 # CALLRUNOPS()=>CALLRUNOPS(aTHX) 465 # CALLRUNOPS()=>CALLRUNOPS(aTHX)
466 # fixed with 5.11.4 466 # fixed with 5.11.4
467 print ' 467 print '
468 #undef PP_EVAL 468 #undef PP_EVAL
469 #define PP_EVAL(ppaddr, nxt) do { \ 469 #define PP_EVAL(ppaddr, nxt) do { \
470 dJMPENV; \ 470 dJMPENV; \
471 int ret; \ 471 int ret; \
472 PUTBACK; \ 472 PUTBACK; \
473 JMPENV_PUSH(ret); \ 473 JMPENV_PUSH(ret); \
474 switch (ret) { \ 474 switch (ret) { \
475 case 0: \ 475 case 0: \
476 PL_op = ppaddr(aTHX); \\'; 476 PL_op = ppaddr(aTHX); \\';
477 if ($PERL510) { 477 if ($PERL510) {
478 # pp_leaveeval sets: retop = cx->blk_eval.retop 478 # pp_leaveeval sets: retop = cx->blk_eval.retop
479 print ' 479 print '
480 cxstack[cxstack_ix].blk_eval.retop = Nullop; \\'; 480 cxstack[cxstack_ix].blk_eval.retop = Nullop; \\';
481 } else { 481 } else {
482 # up to 5.8 pp_entereval did set the retstack to next. 482 # up to 5.8 pp_entereval did set the retstack to next.
483 # nullify that so that we can now exec the rest of this bblock. 483 # nullify that so that we can now exec the rest of this bblock.
484 # (nextstate .. leaveeval) 484 # (nextstate .. leaveeval)
485 print ' 485 print '
486 PL_retstack[PL_retstack_ix - 1] = Nullop; \\'; 486 PL_retstack[PL_retstack_ix - 1] = Nullop; \\';
487 } 487 }
488 print ' 488 print '
489 if (PL_op != nxt) CALLRUNOPS(aTHX); \ 489 if (PL_op != nxt) CALLRUNOPS(aTHX); \
490 JMPENV_POP; \ 490 JMPENV_POP; \
491 break; \ 491 break; \
492 case 1: JMPENV_POP; JMPENV_JUMP(1); \ 492 case 1: JMPENV_POP; JMPENV_JUMP(1); \
493 case 2: JMPENV_POP; JMPENV_JUMP(2); \ 493 case 2: JMPENV_POP; JMPENV_JUMP(2); \
494 case 3: \ 494 case 3: \
495 JMPENV_POP; \ 495 JMPENV_POP; \
496 if (PL_restartop && PL_restartop != nxt) \ 496 if (PL_restartop && PL_restartop != nxt) \
497 JMPENV_JUMP(3); \ 497 JMPENV_JUMP(3); \
498 } \ 498 } \
499 PL_op = nxt; \ 499 PL_op = nxt; \
500 SPAGAIN; \ 500 SPAGAIN; \
501 } while (0) 501 } while (0)
502 '; 502 ';
503 } 503 }
504 504
505 # Perl_vivify_ref not exported on MSWin32 505 # Perl_vivify_ref not exported on MSWin32
506 # coverage: 18 506 # coverage: 18
507 if ($PERL510 and $^O eq 'MSWin32') { 507 if ($PERL510 and $^O eq 'MSWin32') {
508 # CC coverage: 18, 29 508 # CC coverage: 18, 29
509 print << '__EOV' if $vivify_ref_defined; 509 print << '__EOV' if $vivify_ref_defined;
510 510
511 /* Code to take a scalar and ready it to hold a reference */ 511 /* Code to take a scalar and ready it to hold a reference */
512 # ifndef SVt_RV 512 # ifndef SVt_RV
513 # define SVt_RV SVt_IV 513 # define SVt_RV SVt_IV
514 # endif 514 # endif
515 # define prepare_SV_for_RV(sv) \ 515 # define prepare_SV_for_RV(sv) \
516 STMT_START { \ 516 STMT_START { \
517 if (SvTYPE(sv) < SVt_RV) \ 517 if (SvTYPE(sv) < SVt_RV) \
518 sv_upgrade(sv, SVt_RV); \ 518 sv_upgrade(sv, SVt_RV); \
519 else if (SvPVX_const(sv)) { \ 519 else if (SvPVX_const(sv)) { \
520 SvPV_free(sv); \ 520 SvPV_free(sv); \
521 SvLEN_set(sv, 0); \ 521 SvLEN_set(sv, 0); \
522 SvCUR_set(sv, 0); \ 522 SvCUR_set(sv, 0); \
523 } \ 523 } \
524 } STMT_END 524 } STMT_END
525 525
526 #if (PERL_VERSION > 15) || ((PERL_VERSION == 15) && (PERL_SUBVERSION >= 2)) 526 #if (PERL_VERSION > 15) || ((PERL_VERSION == 15) && (PERL_SUBVERSION >= 2))
527 SV* 527 SV*
528 #else 528 #else
529 void 529 void
530 #endif 530 #endif
531 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) 531 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
532 { 532 {
533 SvGETMAGIC(sv); 533 SvGETMAGIC(sv);
534 if (!SvOK(sv)) { 534 if (!SvOK(sv)) {
535 if (SvREADONLY(sv)) 535 if (SvREADONLY(sv))
536 Perl_croak(aTHX_ "%s", PL_no_modify); 536 Perl_croak(aTHX_ "%s", PL_no_modify);
537 prepare_SV_for_RV(sv); 537 prepare_SV_for_RV(sv);
538 switch (to_what) { 538 switch (to_what) {
539 case OPpDEREF_SV: 539 case OPpDEREF_SV:
540 SvRV_set(sv, newSV(0)); 540 SvRV_set(sv, newSV(0));
541 break; 541 break;
542 case OPpDEREF_AV: 542 case OPpDEREF_AV:
543 SvRV_set(sv, newAV()); 543 SvRV_set(sv, newAV());
544 break; 544 break;
545 case OPpDEREF_HV: 545 case OPpDEREF_HV:
546 SvRV_set(sv, newHV()); 546 SvRV_set(sv, newHV());
547 break; 547 break;
548 } 548 }
549 SvROK_on(sv); 549 SvROK_on(sv);
550 SvSETMAGIC(sv); 550 SvSETMAGIC(sv);
551 } 551 }
552 } 552 }
553 553
554 __EOV 554 __EOV
555 555
556 } 556 }
557 557
558 foreach $ppdata (@pp_list) { 558 foreach $ppdata (@pp_list) {
559 my ( $name, $runtime, $declare ) = @$ppdata; 559 my ( $name, $runtime, $declare ) = @$ppdata;
560 print "\nstatic\nCCPP($name)\n{\n"; 560 print "\nstatic\nCCPP($name)\n{\n";
561 my ( $type, $varlist, $line ); 561 my ( $type, $varlist, $line );
562 while ( ( $type, $varlist ) = each %$declare ) { 562 while ( ( $type, $varlist ) = each %$declare ) {
563 print "\t$type ", join( ", ", @$varlist ), ";\n"; 563 print "\t$type ", join( ", ", @$varlist ), ";\n";
564 } 564 }
565 foreach $line (@$runtime) { 565 foreach $line (@$runtime) {
566 print $line, "\n"; 566 print $line, "\n";
567 } 567 }
568 print "}\n"; 568 print "}\n";
569 } 569 }
570 } 570 }
571 571
572 sub runtime { 572 sub runtime {
573 my $line; 573 my $line;
574 foreach $line (@_) { 574 foreach $line (@_) {
575 push_runtime("\t$line"); 575 push_runtime("\t$line");
576 } 576 }
577 } 577 }
578 578
579 sub init_pp { 579 sub init_pp {
580 $ppname = shift; 580 $ppname = shift;
581 $runtime_list_ref = []; 581 $runtime_list_ref = [];
582 $declare_ref = {}; 582 $declare_ref = {};
583 runtime("dSP;"); 583 runtime("dSP;");
584 declare( "I32", "oldsave" ); 584 declare( "I32", "oldsave" );
585 map { declare( "SV", "*$_" ) } qw(sv src dst left right); 585 map { declare( "SV", "*$_" ) } qw(sv src dst left right);
586 declare( "MAGIC", "*mg" ); 586 declare( "MAGIC", "*mg" );
587 $decl->add( "#undef cxinc", "#define cxinc() Perl_cxinc(aTHX)") 587 $decl->add( "#undef cxinc", "#define cxinc() Perl_cxinc(aTHX)")
588 if $] < 5.011001 and $inline_ops; 588 if $] < 5.011001 and $inline_ops;
589 declare( "PERL_CONTEXT", "*cx" ); 589 declare( "PERL_CONTEXT", "*cx" );
590 declare( "I32", "gimme"); 590 declare( "I32", "gimme");
591 $decl->add("static OP * $ppname (pTHX);"); 591 $decl->add("static OP * $ppname (pTHX);");
592 debug "init_pp: $ppname\n" if $debug{queue}; 592 debug "init_pp: $ppname\n" if $debug{queue};
593 } 593 }
594 594
595 # Initialise runtime_callback function for Stackobj class 595 # Initialise runtime_callback function for Stackobj class
596 BEGIN { B::Stackobj::set_callback( \&runtime ) } 596 BEGIN { B::Stackobj::set_callback( \&runtime ) }
597 597
598 =head2 cc_queue 598 =head2 cc_queue
599 599
600 Creates a new ccpp optree. 600 Creates a new ccpp optree.
601 601
602 Initialised by saveoptree_callback in L<B::C>, replaces B::C::walk_and_save_optree. 602 Initialised by saveoptree_callback in L<B::C>, replaces B::C::walk_and_save_optree.
603 Called by every C<CV::save> if ROOT. 603 Called by every C<CV::save> if ROOT.
604 B<blocksort> also creates its block closure with cc_queue. 604 B<blocksort> also creates its block closure with cc_queue.
605 605
606 =cut 606 =cut
607 607
608 # coverage: test 18, 28 (fixed with B-C-1.30 r971) 608 # coverage: test 18, 28 (fixed with B-C-1.30 r971)
609 sub cc_queue { 609 sub cc_queue {
610 my ( $name, $root, $start, @pl ) = @_; 610 my ( $name, $root, $start, @pl ) = @_;
611 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n" 611 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
612 if $debug{queue}; 612 if $debug{queue};
613 if ( $name eq "*ignore*" or $name =~ /^pp_sub_.*(FETCH|MODIFY)_SCALAR_ATTRIBUTES$/) { 613 if ( $name eq "*ignore*" or $name =~ /^pp_sub_.*(FETCH|MODIFY)_SCALAR_ATTRIBUTES$/) {
614 $name = ''; 614 $name = '';
615 } else { 615 } else {
616 push( @cc_todo, [ $name, $root, $start, ( @pl ? @pl : @padlist ) ] ); 616 push( @cc_todo, [ $name, $root, $start, ( @pl ? @pl : @padlist ) ] );
617 } 617 }
618 my $fakeop = B::FAKEOP->new( "next" => 0, sibling => 0, ppaddr => $name, 618 my $fakeop = B::FAKEOP->new( "next" => 0, sibling => 0, ppaddr => $name,
619 targ=>0, type=>0, flags=>0, private=>0); 619 targ=>0, type=>0, flags=>0, private=>0);
620 $start = $fakeop->save; 620 $start = $fakeop->save;
621 debug "cc_queue: name $name returns $start\n" if $debug{queue}; 621 debug "cc_queue: name $name returns $start\n" if $debug{queue};
622 return $start; 622 return $start;
623 } 623 }
624 BEGIN { B::C::set_callback( \&cc_queue ) } 624 BEGIN { B::C::set_callback( \&cc_queue ) }
625 625
626 sub valid_int { $_[0]->{flags} & VALID_INT } 626 sub valid_int { $_[0]->{flags} & VALID_INT }
627 sub valid_double { $_[0]->{flags} & VALID_DOUBLE } 627 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
628 sub valid_numeric { $_[0]->{flags} & ( VALID_INT | VALID_DOUBLE ) } 628 sub valid_numeric { $_[0]->{flags} & ( VALID_INT | VALID_DOUBLE ) }
629 sub valid_sv { $_[0]->{flags} & VALID_SV } 629 sub valid_sv { $_[0]->{flags} & VALID_SV }
630 630
631 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } 631 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
632 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } 632 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
633 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } 633 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
634 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } 634 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
635 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" } 635 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
636 636
637 sub pop_int { @stack ? ( pop @stack )->as_int : "POPi" } 637 sub pop_int { @stack ? ( pop @stack )->as_int : "POPi" }
638 sub pop_double { @stack ? ( pop @stack )->as_double : "POPn" } 638 sub pop_double { @stack ? ( pop @stack )->as_double : "POPn" }
639 sub pop_numeric { @stack ? ( pop @stack )->as_numeric : "POPn" } 639 sub pop_numeric { @stack ? ( pop @stack )->as_numeric : "POPn" }
640 sub pop_sv { @stack ? ( pop @stack )->as_sv : "POPs" } 640 sub pop_sv { @stack ? ( pop @stack )->as_sv : "POPs" }
641 641
642 sub pop_bool { 642 sub pop_bool {
643 if (@stack) { 643 if (@stack) {
644 return ( ( pop @stack )->as_bool ); 644 return ( ( pop @stack )->as_bool );
645 } 645 }
646 else { 646 else {
647 # Careful: POPs has an auto-decrement and SvTRUE evaluates 647 # Careful: POPs has an auto-decrement and SvTRUE evaluates
648 # its argument more than once. 648 # its argument more than once.
649 runtime("sv = POPs;"); 649 runtime("sv = POPs;");
650 return "SvTRUE(sv)"; 650 return "SvTRUE(sv)";
651 } 651 }
652 } 652 }
653 653
654 sub write_back_lexicals { 654 sub write_back_lexicals {
655 my $avoid = shift || 0; 655 my $avoid = shift || 0;
656 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n" 656 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
657 if $debug{shadow}; 657 if $debug{shadow};
658 my $lex; 658 my $lex;
659 foreach $lex (@pad) { 659 foreach $lex (@pad) {
660 next unless ref($lex); 660 next unless ref($lex);
661 $lex->write_back unless $lex->{flags} & $avoid; 661 $lex->write_back unless $lex->{flags} & $avoid;
662 } 662 }
663 } 663 }
664 664
665 =head1 save_or_restore_lexical_state 665 =head1 save_or_restore_lexical_state
666 666
667 The compiler tracks state of lexical variables in @pad to generate optimised 667 The compiler tracks state of lexical variables in @pad to generate optimised
668 code. But multiple execution paths lead to the entry point of a basic block. 668 code. But multiple execution paths lead to the entry point of a basic block.
669 The state of the first execution path is saved and all other execution 669 The state of the first execution path is saved and all other execution
670 paths are restored to the state of the first one. 670 paths are restored to the state of the first one.
671 671
672 Missing flags are regenerated by loading values. 672 Missing flags are regenerated by loading values.
673 673
674 Added flags must are removed; otherwise the compiler would be too optimistic, 674 Added flags must are removed; otherwise the compiler would be too optimistic,
675 hence generating code which doesn't match state of the other execution paths. 675 hence generating code which doesn't match state of the other execution paths.
676 676
677 =cut 677 =cut
678 678
679 sub save_or_restore_lexical_state { 679 sub save_or_restore_lexical_state {
680 my $bblock = shift; 680 my $bblock = shift;
681 unless ( exists $lexstate{$bblock} ) { 681 unless ( exists $lexstate{$bblock} ) {
682 foreach my $lex (@pad) { 682 foreach my $lex (@pad) {
683 next unless ref($lex); 683 next unless ref($lex);
684 ${ $lexstate{$bblock} }{ $lex->{iv} } = $lex->{flags}; 684 ${ $lexstate{$bblock} }{ $lex->{iv} } = $lex->{flags};
685 } 685 }
686 } 686 }
687 else { 687 else {
688 foreach my $lex (@pad) { 688 foreach my $lex (@pad) {
689 next unless ref($lex); 689 next unless ref($lex);
690 my $old_flags = ${ $lexstate{$bblock} }{ $lex->{iv} }; 690 my $old_flags = ${ $lexstate{$bblock} }{ $lex->{iv} };
691 next if ( $old_flags eq $lex->{flags} ); 691 next if ( $old_flags eq $lex->{flags} );
692 my $changed = $old_flags ^ $lex->{flags}; 692 my $changed = $old_flags ^ $lex->{flags};
693 if ( $changed & VALID_SV ) { 693 if ( $changed & VALID_SV ) {
694 ( $old_flags & VALID_SV ) ? $lex->write_back : $lex->invalidate; 694 ( $old_flags & VALID_SV ) ? $lex->write_back : $lex->invalidate;
695 } 695 }
696 if ( $changed & VALID_DOUBLE ) { 696 if ( $changed & VALID_DOUBLE ) {
697 ( $old_flags & VALID_DOUBLE ) ? $lex->load_double : $lex->invalidate_double; 697 ( $old_flags & VALID_DOUBLE ) ? $lex->load_double : $lex->invalidate_double;
698 } 698 }
699 if ( $changed & VALID_INT ) { 699 if ( $changed & VALID_INT ) {
700 ( $old_flags & VALID_INT ) ? $lex->load_int : $lex->invalidate_int; 700 ( $old_flags & VALID_INT ) ? $lex->load_int : $lex->invalidate_int;
701 } 701 }
702 } 702 }
703 } 703 }
704 } 704 }
705 705
706 sub write_back_stack { 706 sub write_back_stack {
707 debug "write_back_stack() ".scalar(@stack)." called from @{[(caller(1))[3]]}\n" 707 debug "write_back_stack() ".scalar(@stack)." called from @{[(caller(1))[3]]}\n"
708 if $debug{shadow}; 708 if $debug{shadow};
709 return unless @stack; 709 return unless @stack;
710 runtime( sprintf( "EXTEND(sp, %d);", scalar(@stack) ) ); 710 runtime( sprintf( "EXTEND(sp, %d);", scalar(@stack) ) );
711 foreach my $obj (@stack) { 711 foreach my $obj (@stack) {
712 runtime( sprintf( "PUSHs((SV*)%s);", $obj->as_sv ) ); 712 runtime( sprintf( "PUSHs((SV*)%s);", $obj->as_sv ) );
713 } 713 }
714 @stack = (); 714 @stack = ();
715 } 715 }
716 716
717 sub invalidate_lexicals { 717 sub invalidate_lexicals {
718 my $avoid = shift || 0; 718 my $avoid = shift || 0;
719 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" 719 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
720 if $debug{shadow}; 720 if $debug{shadow};
721 my $lex; 721 my $lex;
722 foreach $lex (@pad) { 722 foreach $lex (@pad) {
723 next unless ref($lex); 723 next unless ref($lex);
724 $lex->invalidate unless $lex->{flags} & $avoid; 724 $lex->invalidate unless $lex->{flags} & $avoid;
725 } 725 }
726 } 726 }
727 727
728 sub reload_lexicals { 728 sub reload_lexicals {
729 my $lex; 729 my $lex;
730 foreach $lex (@pad) { 730 foreach $lex (@pad) {
731 next unless ref($lex); 731 next unless ref($lex);
732 my $type = $lex->{type}; 732 my $type = $lex->{type};
733 if ( $type == T_INT ) { 733 if ( $type == T_INT ) {
734 $lex->as_int; 734 $lex->as_int;
735 } 735 }
736 elsif ( $type == T_DOUBLE ) { 736 elsif ( $type == T_DOUBLE ) {
737 $lex->as_double; 737 $lex->as_double;
738 } 738 }
739 else { 739 else {
740 $lex->as_sv; 740 $lex->as_sv;
741 } 741 }
742 } 742 }
743 } 743 }
744 744
745 { 745 {
746 746
747 package B::Pseudoreg; 747 package B::Pseudoreg;
748 748
749 # 749 #
750 # This class allocates pseudo-registers (OK, so they're C variables). 750 # This class allocates pseudo-registers (OK, so they're C variables).
751 # 751 #
752 my %alloc; # Keyed by variable name. A value of 1 means the 752 my %alloc; # Keyed by variable name. A value of 1 means the
753 # variable has been declared. A value of 2 means 753 # variable has been declared. A value of 2 means
754 # it's in use. 754 # it's in use.
755 755
756 sub new_scope { %alloc = () } 756 sub new_scope { %alloc = () }
757 757
758 sub new ($$$) { 758 sub new ($$$) {
759 my ( $class, $type, $prefix ) = @_; 759 my ( $class, $type, $prefix ) = @_;
760 my ( $ptr, $i, $varname, $status, $obj ); 760 my ( $ptr, $i, $varname, $status, $obj );
761 $prefix =~ s/^(\**)//; 761 $prefix =~ s/^(\**)//;
762 $ptr = $1; 762 $ptr = $1;
763 $i = 0; 763 $i = 0;
764 do { 764 do {
765 $varname = "$prefix$i"; 765 $varname = "$prefix$i";
766 $status = $alloc{$varname}; 766 $status = $alloc{$varname};
767 } while $status == 2; 767 } while $status == 2;
768 if ( $status != 1 ) { 768 if ( $status != 1 ) {
769 769
770 # Not declared yet 770 # Not declared yet
771 B::CC::declare( $type, "$ptr$varname" ); 771 B::CC::declare( $type, "$ptr$varname" );
772 $alloc{$varname} = 2; # declared and in use 772 $alloc{$varname} = 2; # declared and in use
773 } 773 }
774 $obj = bless \$varname, $class; 774 $obj = bless \$varname, $class;
775 return $obj; 775 return $obj;
776 } 776 }
777 777
778 sub DESTROY { 778 sub DESTROY {
779 my $obj = shift; 779 my $obj = shift;
780 $alloc{$$obj} = 1; # no longer in use but still declared 780 $alloc{$$obj} = 1; # no longer in use but still declared
781 } 781 }
782 } 782 }
783 { 783 {
784 784
785 package B::Shadow; 785 package B::Shadow;
786 786
787 # 787 #
788 # This class gives a standard API for a perl object to shadow a 788 # This class gives a standard API for a perl object to shadow a
789 # C variable and only generate reloads/write-backs when necessary. 789 # C variable and only generate reloads/write-backs when necessary.
790 # 790 #
791 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). 791 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
792 # Use $obj->write_back whenever shadowed_c_var needs to be up to date. 792 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
793 # Use $obj->invalidate whenever an unknown function may have 793 # Use $obj->invalidate whenever an unknown function may have
794 # set shadow itself. 794 # set shadow itself.
795 795
796 sub new { 796 sub new {
797 my ( $class, $write_back ) = @_; 797 my ( $class, $write_back ) = @_;
798 798
799 # Object fields are perl shadow variable, validity flag 799 # Object fields are perl shadow variable, validity flag
800 # (for *C* variable) and callback sub for write_back 800 # (for *C* variable) and callback sub for write_back
801 # (passed perl shadow variable as argument). 801 # (passed perl shadow variable as argument).
802 bless [ undef, 1, $write_back ], $class; 802 bless [ undef, 1, $write_back ], $class;
803 } 803 }
804 804
805 sub load { 805 sub load {
806 my ( $obj, $newval ) = @_; 806 my ( $obj, $newval ) = @_;
807 $obj->[1] = 0; # C variable no longer valid 807 $obj->[1] = 0; # C variable no longer valid
808 $obj->[0] = $newval; 808 $obj->[0] = $newval;
809 } 809 }
810 810
811 sub write_back { 811 sub write_back {
812 my $obj = shift; 812 my $obj = shift;
813 if ( !( $obj->[1] ) ) { 813 if ( !( $obj->[1] ) ) {
814 $obj->[1] = 1; # C variable will now be valid 814 $obj->[1] = 1; # C variable will now be valid
815 &{ $obj->[2] }( $obj->[0] ); 815 &{ $obj->[2] }( $obj->[0] );
816 } 816 }
817 } 817 }
818 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid 818 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
819 } 819 }
820 820
821 my $curcop = B::Shadow->new( 821 my $curcop = B::Shadow->new(
822 sub { 822 sub {
823 my $opsym = shift->save; 823 my $opsym = shift->save;
824 runtime("PL_curcop = (COP*)$opsym;"); 824 runtime("PL_curcop = (COP*)$opsym;");
825 } 825 }
826 ); 826 );
827 827
828 # 828 #
829 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on. 829 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
830 # 830 #
831 sub dopoptoloop { 831 sub dopoptoloop {
832 my $cxix = $#cxstack; 832 my $cxix = $#cxstack;
833 while ( $cxix >= 0 && CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 833 while ( $cxix >= 0 && CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
834 $cxix--; 834 $cxix--;
835 } 835 }
836 debug "dopoptoloop: returning $cxix" if $debug{cxstack}; 836 debug "dopoptoloop: returning $cxix" if $debug{cxstack};
837 return $cxix; 837 return $cxix;
838 } 838 }
839 839
840 sub dopoptolabel { 840 sub dopoptolabel {
841 my $label = shift; 841 my $label = shift;
842 my $cxix = $#cxstack; 842 my $cxix = $#cxstack;
843 while ( 843 while (
844 $cxix >= 0 844 $cxix >= 0
845 && ( CxTYPE_no_LOOP( $cxstack[$cxix] ) 845 && ( CxTYPE_no_LOOP( $cxstack[$cxix] )
846 || $cxstack[$cxix]->{label} ne $label ) 846 || $cxstack[$cxix]->{label} ne $label )
847 ) 847 )
848 { 848 {
849 $cxix--; 849 $cxix--;
850 } 850 }
851 debug "dopoptolabel: returning $cxix\n" if $debug{cxstack}; 851 debug "dopoptolabel: returning $cxix\n" if $debug{cxstack};
852 if ($cxix < 0 and $debug{cxstack}) { 852 if ($cxix < 0 and $debug{cxstack}) {
853 for my $cx (0 .. $#cxstack) { 853 for my $cx (0 .. $#cxstack) {
854 debug "$cx: ",$cxstack[$cx]->{label},"\n"; 854 debug "$cx: ",$cxstack[$cx]->{label},"\n";
855 } 855 }
856 for my $op (keys %{$labels->{label}}) { 856 for my $op (keys %{$labels->{label}}) {
857 debug $labels->{label}->{$op},"\n"; 857 debug $labels->{label}->{$op},"\n";
858 } 858 }
859 } 859 }
860 return $cxix; 860 return $cxix;
861 } 861 }
862 862
863 sub push_label { 863 sub push_label {
864 my $op = shift; 864 my $op = shift;
865 my $type = shift; 865 my $type = shift;
866 push @{$labels->{$type}}, ( $op ); 866 push @{$labels->{$type}}, ( $op );
867 } 867 }
868 868
869 sub pop_label { 869 sub pop_label {
870 my $type = shift; 870 my $type = shift;
871 my $op = pop @{$labels->{$type}}; 871 my $op = pop @{$labels->{$type}};
872 write_label ($op); # avoids duplicate labels 872 write_label ($op); # avoids duplicate labels
873 } 873 }
874 874
875 sub error { 875 sub error {
876 my $format = shift; 876 my $format = shift;
877 my $file = $curcop->[0]->file; 877 my $file = $curcop->[0]->file;
878 my $line = $curcop->[0]->line; 878 my $line = $curcop->[0]->line;
879 $errors++; 879 $errors++;
880 if (@_) { 880 if (@_) {
881 warn sprintf( "ERROR at %s:%d: $format\n", $file, $line, @_ ); 881 warn sprintf( "ERROR at %s:%d: $format\n", $file, $line, @_ );
882 } 882 }
883 else { 883 else {
884 warn sprintf( "ERROR at %s:%d: %s\n", $file, $line, $format ); 884 warn sprintf( "ERROR at %s:%d: %s\n", $file, $line, $format );
885 } 885 }
886 } 886 }
887 887
888 # run-time eval is too late for attrs being checked by perlcore. BEGIN does not help. 888 # run-time eval is too late for attrs being checked by perlcore. BEGIN does not help.
889 # use types is the right approach. But until types is fixed we use this hack. 889 # use types is the right approach. But until types is fixed we use this hack.
890 # Note that we also need a new CHECK_SCALAR_ATTRIBUTES hook, starting with v5.18. 890 # Note that we also need a new CHECK_SCALAR_ATTRIBUTES hook, starting with v5.18.
891 sub init_type_attrs { 891 sub init_type_attrs {
892 eval q[ 892 eval q[
893 893
894 our $valid_attr = '^(int|double|string|unsigned|register|temporary|ro|readonly|const)$'; 894 our $valid_attr = '^(int|double|string|unsigned|register|temporary|ro|readonly|const)$';
895 sub MODIFY_SCALAR_ATTRIBUTES { 895 sub MODIFY_SCALAR_ATTRIBUTES {
896 my $pkg = shift; 896 my $pkg = shift;
897 my $v = shift; 897 my $v = shift;
898 my $attr = $B::CC::valid_attr; 898 my $attr = $B::CC::valid_attr;
899 $attr =~ s/\b$pkg\b//; 899 $attr =~ s/\b$pkg\b//;
900 if (my @bad = grep !/$attr/, @_) { 900 if (my @bad = grep !/$attr/, @_) {
901 return @bad; 901 return @bad;
902 } else { 902 } else {
903 no strict 'refs'; 903 no strict 'refs';
904 push @{"$pkg\::$v\::attributes"}, @_; # create a magic glob 904 push @{"$pkg\::$v\::attributes"}, @_; # create a magic glob
905 return (); 905 return ();
906 } 906 }
907 } 907 }
908 sub FETCH_SCALAR_ATTRIBUTES { 908 sub FETCH_SCALAR_ATTRIBUTES {
909 my ($pkg, $v) = @_; 909 my ($pkg, $v) = @_;
910 no strict 'refs'; 910 no strict 'refs';
911 return @{"$pkg\::$v\::attributes"}; 911 return @{"$pkg\::$v\::attributes"};
912 } 912 }
913 913
914 # pollute our callers namespace for attributes to be accepted with -MB::CC 914 # pollute our callers namespace for attributes to be accepted with -MB::CC
915 *main::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 915 *main::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
916 *main::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 916 *main::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
917 917
918 # my int $i : register : ro; 918 # my int $i : register : ro;
919 *int::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 919 *int::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
920 *int::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 920 *int::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
921 921
922 # my double $d : ro; 922 # my double $d : ro;
923 *double::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 923 *double::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
924 *double::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 924 *double::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
925 925
926 *string::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 926 *string::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
927 *string::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 927 *string::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
928 ]; 928 ];
929 929
930 } 930 }
931 931
932 =head2 load_pad 932 =head2 load_pad
933 933
934 Load pad takes (the elements of) a PADLIST as arguments and loads up @pad 934 Load pad takes (the elements of) a PADLIST as arguments and loads up @pad
935 with Stackobj-derived objects which represent those lexicals. 935 with Stackobj-derived objects which represent those lexicals.
936 936
937 If/when perl itself can generate type information C<(my int $foo; my $foo : int)> then we'll 937 If/when perl itself can generate type information C<(my int $foo; my $foo : int)> then we'll
938 take advantage of that here. Until then, we'll use the L<-fname-magic/-fno-name-magic> 938 take advantage of that here. Until then, we'll use the L<-fname-magic/-fno-name-magic>
939 hack to tell the compiler when we want a lexical to be a particular type or to be a register. 939 hack to tell the compiler when we want a lexical to be a particular type or to be a register.
940 940
941 =cut 941 =cut
942 942
943 sub load_pad { 943 sub load_pad {
944 my ( $namelistav, $valuelistav ) = @_; 944 my ( $namelistav, $valuelistav ) = @_;
945 @padlist = @_; 945 @padlist = @_;
946 my @namelist = $namelistav->ARRAY; 946 my @namelist = $namelistav->ARRAY;
947 my @valuelist = $valuelistav->ARRAY; 947 my @valuelist = $valuelistav->ARRAY;
948 my $ix; 948 my $ix;
949 @pad = (); 949 @pad = ();
950 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug{pad}; 950 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug{pad};
951 951
952 # Temporary lexicals don't get named so it's possible for @valuelist 952 # Temporary lexicals don't get named so it's possible for @valuelist
953 # to be strictly longer than @namelist. We count $ix up to the end of 953 # to be strictly longer than @namelist. We count $ix up to the end of
954 # @valuelist but index into @namelist for the name. Any temporaries which 954 # @valuelist but index into @namelist for the name. Any temporaries which
955 # run off the end of @namelist will make $namesv undefined and we treat 955 # run off the end of @namelist will make $namesv undefined and we treat
956 # that the same as having an explicit SPECIAL sv_undef object in @namelist. 956 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
957 # [XXX If/when @_ becomes a lexical, we must start at 0 here.] 957 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
958 for ( $ix = 1 ; $ix < @valuelist ; $ix++ ) { 958 for ( $ix = 1 ; $ix < @valuelist ; $ix++ ) {
959 my $namesv = $namelist[$ix]; 959 my $namesv = $namelist[$ix];
960 my $type = T_UNKNOWN; 960 my $type = T_UNKNOWN;
961 my $flags = 0; 961 my $flags = 0;
962 my $name = "tmp"; 962 my $name = "tmp";
963 my $class = class($namesv); 963 my $class = class($namesv);
964 if ( !defined($namesv) || $class eq "SPECIAL" ) { 964 if ( !defined($namesv) || $class eq "SPECIAL" ) {
965 # temporaries have &PL_sv_undef instead of a PVNV for a name 965 # temporaries have &PL_sv_undef instead of a PVNV for a name
966 $flags = VALID_SV | TEMPORARY | REGISTER; 966 $flags = VALID_SV | TEMPORARY | REGISTER;
967 } 967 }
968 else { 968 else {
969 my ($nametry) = $namesv->PV =~ /^\$(.+)$/ if $namesv->PV; 969 my ($nametry) = $namesv->PV =~ /^\$(.+)$/ if $namesv->PV;
970 $name = $nametry if $nametry; 970 $name = $nametry if $nametry;
971 971
972 # my int $i; my double $d; compiled code only, unless the source provides the int and double packages. 972 # my int $i; my double $d; compiled code only, unless the source provides the int and double packages.
973 # With Ctypes it is easier. my c_int $i; defines an external Ctypes int, which can be efficiently 973 # With Ctypes it is easier. my c_int $i; defines an external Ctypes int, which can be efficiently
974 # compiled in Perl also. 974 # compiled in Perl also.
975 # XXX Better use attributes, like my $i:int; my $d:double; which works un-compiled also. 975 # XXX Better use attributes, like my $i:int; my $d:double; which works un-compiled also.
976 if (ref($namesv) eq 'B::PVMG' and ref($namesv->SvSTASH) eq 'B::HV') { # my int 976 if (ref($namesv) eq 'B::PVMG' and ref($namesv->SvSTASH) eq 'B::HV') { # my int
977 $class = $namesv->SvSTASH->NAME; 977 $class = $namesv->SvSTASH->NAME;
978 if ($class eq 'int') { 978 if ($class eq 'int') {
979 $type = T_INT; 979 $type = T_INT;
980 $flags = VALID_SV | VALID_INT; 980 $flags = VALID_SV | VALID_INT;
981 } 981 }
982 elsif ($class eq 'double') { # my double 982 elsif ($class eq 'double') { # my double
983 $type = T_DOUBLE; 983 $type = T_DOUBLE;
984 $flags = VALID_SV | VALID_DOUBLE; 984 $flags = VALID_SV | VALID_DOUBLE;
985 } 985 }
986 #elsif ($class eq 'c_int') { # use Ctypes; 986 #elsif ($class eq 'c_int') { # use Ctypes;
987 # $type = T_INT; 987 # $type = T_INT;
988 # $flags = VALID_SV | VALID_INT; 988 # $flags = VALID_SV | VALID_INT;
989 #} 989 #}
990 #elsif ($class eq 'c_double') { 990 #elsif ($class eq 'c_double') {
991 # $type = T_DOUBLE; 991 # $type = T_DOUBLE;
992 # $flags = VALID_SV | VALID_DOUBLE; 992 # $flags = VALID_SV | VALID_DOUBLE;
993 #} 993 #}
994 # TODO: MooseX::Types 994 # TODO: MooseX::Types
995 } 995 }
996 996
997 # Valid scalar type attributes: 997 # Valid scalar type attributes:
998 # int double string ro readonly const unsigned 998 # int double string ro readonly const unsigned
999 # Note: PVMG from above also. 999 # Note: PVMG from above also.
1000 # Typed arrays and hashes later. 1000 # Typed arrays and hashes later.
1001 if (0 and $class =~ /^(I|P|S|N)V/ 1001 if (0 and $class =~ /^(I|P|S|N)V/
1002 and $type_attr 1002 and $type_attr
1003 and UNIVERSAL::can($class,"CHECK_SCALAR_ATTRIBUTES")) # with 5.18 1003 and UNIVERSAL::can($class,"CHECK_SCALAR_ATTRIBUTES")) # with 5.18
1004 { 1004 {
1005 require attributes; 1005 require attributes;
1006 #my $svtype = uc reftype ($namesv); 1006 #my $svtype = uc reftype ($namesv);
1007 # test 105 1007 # test 105
1008 my @attr = attributes::get(\$namesv); # how to get em from B? see optimize 1008 my @attr = attributes::get(\$namesv); # how to get em from B? see optimize
1009 warn "\$$name attrs: ".@attr if $verbose or $debug{pad}; 1009 warn "\$$name attrs: ".@attr if $verbose or $debug{pad};
1010 #my $valid_types = ${"$class\::valid_attr"}; # They ARE valid, parser checked already. 1010 #my $valid_types = ${"$class\::valid_attr"}; # They ARE valid, parser checked already.
1011 } 1011 }
1012 1012
1013 # XXX We should try Devel::TypeCheck for type inference also 1013 # XXX We should try Devel::TypeCheck for type inference also
1014 1014
1015 # magic names: my $i_ir, my $d_d. without -fno-name-magic cmdline option only 1015 # magic names: my $i_ir, my $d_d. without -fno-name-magic cmdline option only
1016 if ( $type == T_UNKNOWN and $name_magic and $name =~ /^(.*)_([di])(r?)$/ ) { 1016 if ( $type == T_UNKNOWN and $name_magic and $name =~ /^(.*)_([di])(r?)$/ ) {
1017 $name = $1; 1017 $name = $1;
1018 if ( $2 eq "i" ) { 1018 if ( $2 eq "i" ) {
1019 $type = T_INT; 1019 $type = T_INT;
1020 $flags = VALID_SV | VALID_INT; 1020 $flags = VALID_SV | VALID_INT;
1021 } 1021 }
1022 elsif ( $2 eq "d" ) { 1022 elsif ( $2 eq "d" ) {
1023 $type = T_DOUBLE; 1023 $type = T_DOUBLE;
1024 $flags = VALID_SV | VALID_DOUBLE; 1024 $flags = VALID_SV | VALID_DOUBLE;
1025 } 1025 }
1026 $flags |= REGISTER if $3; 1026 $flags |= REGISTER if $3;
1027 } 1027 }
1028 } 1028 }
1029 $name = "${ix}_$name"; 1029 $name = "${ix}_$name";
1030 $pad[$ix] = 1030 $pad[$ix] =
1031 B::Stackobj::Padsv->new( $type, $flags, $ix, "i$name", "d$name" ); 1031 B::Stackobj::Padsv->new( $type, $flags, $ix, "i$name", "d$name" );
1032 1032
1033 debug sprintf( "PL_curpad[$ix] = %s\n", $pad[$ix]->peek ) if $debug{pad}; 1033 debug sprintf( "PL_curpad[$ix] = %s\n", $pad[$ix]->peek ) if $debug{pad};
1034 } 1034 }
1035 } 1035 }
1036 1036
1037 sub declare_pad { 1037 sub declare_pad {
1038 my $ix; 1038 my $ix;
1039 for ( $ix = 1 ; $ix <= $#pad ; $ix++ ) { 1039 for ( $ix = 1 ; $ix <= $#pad ; $ix++ ) {
1040 my $type = $pad[$ix]->{type}; 1040 my $type = $pad[$ix]->{type};
1041 declare( "IV", 1041 declare( "IV",
1042 $type == T_INT ? sprintf( "%s=0", $pad[$ix]->{iv} ) : $pad[$ix]->{iv} ) 1042 $type == T_INT ? sprintf( "%s=0", $pad[$ix]->{iv} ) : $pad[$ix]->{iv} )
1043 if $pad[$ix]->save_int; 1043 if $pad[$ix]->save_int;
1044 declare( "double", 1044 declare( "NV",
1045 $type == T_DOUBLE 1045 $type == T_DOUBLE
1046 ? sprintf( "%s = 0", $pad[$ix]->{nv} ) 1046 ? sprintf( "%s = 0", $pad[$ix]->{nv} )
1047 : $pad[$ix]->{nv} ) 1047 : $pad[$ix]->{nv} )
1048 if $pad[$ix]->save_double; 1048 if $pad[$ix]->save_double;
1049 1049
1050 } 1050 }
1051 } 1051 }
1052 1052
1053 # 1053 #
1054 # Debugging stuff 1054 # Debugging stuff
1055 # 1055 #
1056 sub peek_stack { 1056 sub peek_stack {
1057 sprintf "stack = %s\n", join( " ", map( $_->minipeek, @stack ) ); 1057 sprintf "stack = %s\n", join( " ", map( $_->minipeek, @stack ) );
1058 } 1058 }
1059 1059
1060 # 1060 #
1061 # OP stuff 1061 # OP stuff
1062 # 1062 #
1063 1063
1064 =head2 label 1064 =head2 label
1065 1065
1066 We not only mark named labels in C as such - with prefix "label_". 1066 We not only mark named labels in C as such - with prefix "label_".
1067 1067
1068 We also have to mark each known (back jumps) and yet unknown branch targets 1068 We also have to mark each known (back jumps) and yet unknown branch targets
1069 (forward jumps) for compile-time generated branch points, with the "lab_" 1069 (forward jumps) for compile-time generated branch points, with the "lab_"
1070 prefix. 1070 prefix.
1071 1071
1072 =cut 1072 =cut
1073 1073
1074 sub label { 1074 sub label {
1075 my $op = shift; 1075 my $op = shift;
1076 # Preserve original label name for "real" labels 1076 # Preserve original label name for "real" labels
1077 if ($op->can("label") and $op->label) { 1077 if ($op->can("label") and $op->label) {
1078 # cc should error on duplicate named labels 1078 # cc should error on duplicate named labels
1079 return sprintf( "label_%s_%x", $op->label, $$op); 1079 return sprintf( "label_%s_%x", $op->label, $$op);
1080 } else { 1080 } else {
1081 return sprintf( "lab_%x", $$op ); 1081 return sprintf( "lab_%x", $$op );
1082 } 1082 }
1083 } 1083 }
1084 1084
1085 sub write_label { 1085 sub write_label {
1086 my $op = shift; 1086 my $op = shift;
1087 # debug sprintf("lab_%x:?\n", $$op) if $debug{cxstack}; 1087 # debug sprintf("lab_%x:?\n", $$op) if $debug{cxstack};
1088 unless ($labels->{label}->{$$op}) { 1088 unless ($labels->{label}->{$$op}) {
1089 my $l = label($op); 1089 my $l = label($op);
1090 # named label but op not yet known? 1090 # named label but op not yet known?
1091 if ( $op->can("label") and $op->label ) { 1091 if ( $op->can("label") and $op->label ) {
1092 $l = "label_".$op->label; 1092 $l = "label_".$op->label;
1093 # only print first such label. test 21 1093 # only print first such label. test 21
1094 push_runtime(sprintf( " %s:", $l)) 1094 push_runtime(sprintf( " %s:", $l))
1095 unless $labels->{label}->{$l}; 1095 unless $labels->{label}->{$l};
1096 $labels->{label}->{$l} = $$op; 1096 $labels->{label}->{$l} = $$op;
1097 } 1097 }
1098 if ($verbose) { 1098 if ($verbose) {
1099 push_runtime(sprintf( " %s:\t/* %s */", label($op), $op->name )); 1099 push_runtime(sprintf( " %s:\t/* %s */", label($op), $op->name ));
1100 } else { 1100 } else {
1101 push_runtime(sprintf( " %s:", label($op) )); 1101 push_runtime(sprintf( " %s:", label($op) ));
1102 } 1102 }
1103 # avoid printing duplicate jump labels 1103 # avoid printing duplicate jump labels
1104 $labels->{label}->{$$op} = $l; 1104 $labels->{label}->{$$op} = $l;
1105 if ($op->can("label") and $op->label ) { 1105 if ($op->can("label") and $op->label ) {
1106 push(@cxstack, { 1106 push(@cxstack, {
1107 type => 0, 1107 type => 0,
1108 op => $op, 1108 op => $op,
1109 nextop => ((ref($op) eq 'B::LOOP') && $op->nextop) ? $op->nextop : $op, 1109 nextop => ((ref($op) eq 'B::LOOP') && $op->nextop) ? $op->nextop : $op,
1110 redoop => ((ref($op) eq 'B::LOOP') && $op->redoop) ? $op->redoop : $op, 1110 redoop => ((ref($op) eq 'B::LOOP') && $op->redoop) ? $op->redoop : $op,
1111 lastop => ((ref($op) eq 'B::LOOP') && $op->lastop) ? $op->lastop : $op, 1111 lastop => ((ref($op) eq 'B::LOOP') && $op->lastop) ? $op->lastop : $op,
1112 'label' => $op->can("label") && $op->label ? $op->label : $l 1112 'label' => $op->can("label") && $op->label ? $op->label : $l
1113 }); 1113 });
1114 } 1114 }
1115 } 1115 }
1116 } 1116 }
1117 1117
1118 sub loadop { 1118 sub loadop {
1119 my $op = shift; 1119 my $op = shift;
1120 my $opsym = $op->save; 1120 my $opsym = $op->save;
1121 $op_count++; # for statistics 1121 $op_count++; # for statistics
1122 runtime("PL_op = $opsym;") unless $know_op; 1122 runtime("PL_op = $opsym;") unless $know_op;
1123 return $opsym; 1123 return $opsym;
1124 } 1124 }
1125 1125
1126 sub doop { 1126 sub doop {
1127 my $op = shift; 1127 my $op = shift;
1128 my $ppaddr = $op->ppaddr; 1128 my $ppaddr = $op->ppaddr;
1129 my $sym = loadop($op); 1129 my $sym = loadop($op);
1130 my $ppname = "pp_" . $op->name; 1130 my $ppname = "pp_" . $op->name;
1131 if ($inline_ops) { 1131 if ($inline_ops) {
1132 # inlining direct calls is safe, just CALLRUNOPS for macros not 1132 # inlining direct calls is safe, just CALLRUNOPS for macros not
1133 $ppaddr = "Perl_".$ppname; 1133 $ppaddr = "Perl_".$ppname;
1134 $no_stack{$ppname} 1134 $no_stack{$ppname}
1135 ? runtime("PL_op = $ppaddr(aTHX);") 1135 ? runtime("PL_op = $ppaddr(aTHX);")
1136 : runtime("PUTBACK; PL_op = $ppaddr(aTHX); SPAGAIN;"); 1136 : runtime("PUTBACK; PL_op = $ppaddr(aTHX); SPAGAIN;");
1137 } else { 1137 } else {
1138 $no_stack{$ppname} 1138 $no_stack{$ppname}
1139 ? runtime("PL_op = $ppaddr(aTHX);") 1139 ? runtime("PL_op = $ppaddr(aTHX);")
1140 : runtime("DOOP($ppaddr);"); 1140 : runtime("DOOP($ppaddr);");
1141 } 1141 }
1142 $know_op = 1; 1142 $know_op = 1;
1143 return $sym; 1143 return $sym;
1144 } 1144 }
1145 1145
1146 sub gimme { 1146 sub gimme {
1147 my $op = shift; 1147 my $op = shift;
1148 my $want = $op->flags & OPf_WANT; 1148 my $want = $op->flags & OPf_WANT;
1149 return ( $want == OPf_WANT_VOID ? G_VOID : 1149 return ( $want == OPf_WANT_VOID ? G_VOID :
1150 $want == OPf_WANT_SCALAR ? G_SCALAR : 1150 $want == OPf_WANT_SCALAR ? G_SCALAR :
1151 $want == OPf_WANT_LIST ? G_ARRAY : 1151 $want == OPf_WANT_LIST ? G_ARRAY :
1152 undef ); 1152 undef );
1153 } 1153 }
1154 1154
1155 # 1155 #
1156 # Code generation for PP code 1156 # Code generation for PP code
1157 # 1157 #
1158 1158
1159 # coverage: 18,19,25,... 1159 # coverage: 18,19,25,...
1160 sub pp_null { 1160 sub pp_null {
1161 my $op = shift; 1161 my $op = shift;
1162 $B::C::nullop_count++; 1162 $B::C::nullop_count++;
1163 return $op->next; 1163 return $op->next;
1164 } 1164 }
1165 1165
1166 # coverage: 102 1166 # coverage: 102
1167 sub pp_stub { 1167 sub pp_stub {
1168 my $op = shift; 1168 my $op = shift;
1169 my $gimme = gimme($op); 1169 my $gimme = gimme($op);
1170 if ( not defined $gimme ) { 1170 if ( not defined $gimme ) {
1171 write_back_stack(); 1171 write_back_stack();
1172 runtime("if (block_gimme() == G_SCALAR)", 1172 runtime("if (block_gimme() == G_SCALAR)",
1173 "\tXPUSHs(&PL_sv_undef);"); 1173 "\tXPUSHs(&PL_sv_undef);");
1174 } elsif ( $gimme == G_SCALAR ) { 1174 } elsif ( $gimme == G_SCALAR ) {
1175 my $obj = B::Stackobj::Const->new(sv_undef); 1175 my $obj = B::Stackobj::Const->new(sv_undef);
1176 push( @stack, $obj ); 1176 push( @stack, $obj );
1177 } 1177 }
1178 return $op->next; 1178 return $op->next;
1179 } 1179 }
1180 1180
1181 # coverage: 2,21,28,30 1181 # coverage: 2,21,28,30
1182 sub pp_unstack { 1182 sub pp_unstack {
1183 my $op = shift; 1183 my $op = shift;
1184 @stack = (); 1184 @stack = ();
1185 runtime("PP_UNSTACK;"); 1185 runtime("PP_UNSTACK;");
1186 return $op->next; 1186 return $op->next;
1187 } 1187 }
1188 1188
1189 # coverage: 2,21,27,28,30 1189 # coverage: 2,21,27,28,30
1190 sub pp_and { 1190 sub pp_and {
1191 my $op = shift; 1191 my $op = shift;
1192 my $next = $op->next; 1192 my $next = $op->next;
1193 reload_lexicals(); 1193 reload_lexicals();
1194 unshift( @bblock_todo, $next ); 1194 unshift( @bblock_todo, $next );
1195 if ( @stack >= 1 ) { 1195 if ( @stack >= 1 ) {
1196 my $obj = pop @stack; 1196 my $obj = pop @stack;
1197 my $bool = $obj->as_bool; 1197 my $bool = $obj->as_bool;
1198 write_back_stack(); 1198 write_back_stack();
1199 save_or_restore_lexical_state($$next); 1199 save_or_restore_lexical_state($$next);
1200 runtime( 1200 runtime(
1201 sprintf( 1201 sprintf(
1202 "if (!$bool) { PUSHs((SV*)%s); goto %s;}", $obj->as_sv, label($next) 1202 "if (!$bool) { PUSHs((SV*)%s); goto %s;}", $obj->as_sv, label($next)
1203 ) 1203 )
1204 ); 1204 );
1205 } 1205 }
1206 else { 1206 else {
1207 save_or_restore_lexical_state($$next); 1207 save_or_restore_lexical_state($$next);
1208 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ), 1208 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ),
1209 "*sp--;" ); 1209 "*sp--;" );
1210 } 1210 }
1211 return $op->other; 1211 return $op->other;
1212 } 1212 }
1213 1213
1214 # Nearly identical to pp_and, but leaves stack unchanged. 1214 # Nearly identical to pp_and, but leaves stack unchanged.
1215 sub pp_andassign { 1215 sub pp_andassign {
1216 my $op = shift; 1216 my $op = shift;
1217 my $next = $op->next; 1217 my $next = $op->next;
1218 reload_lexicals(); 1218 reload_lexicals();
1219 unshift( @bblock_todo, $next ); 1219 unshift( @bblock_todo, $next );
1220 if ( @stack >= 1 ) { 1220 if ( @stack >= 1 ) {
1221 my $obj = pop @stack; 1221 my $obj = pop @stack;
1222 my $bool = $obj->as_bool; 1222 my $bool = $obj->as_bool;
1223 write_back_stack(); 1223 write_back_stack();
1224 save_or_restore_lexical_state($$next); 1224 save_or_restore_lexical_state($$next);
1225 runtime( 1225 runtime(
1226 sprintf( 1226 sprintf(
1227 "PUSHs((SV*)%s); if (!$bool) { goto %s;}", $obj->as_sv, label($next) 1227 "PUSHs((SV*)%s); if (!$bool) { goto %s;}", $obj->as_sv, label($next)
1228 ) 1228 )
1229 ); 1229 );
1230 } 1230 }
1231 else { 1231 else {
1232 save_or_restore_lexical_state($$next); 1232 save_or_restore_lexical_state($$next);
1233 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ) ); 1233 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ) );
1234 } 1234 }
1235 return $op->other; 1235 return $op->other;
1236 } 1236 }
1237 1237
1238 # coverage: 28 1238 # coverage: 28
1239 sub pp_or { 1239 sub pp_or {
1240 my $op = shift; 1240 my $op = shift;
1241 my $next = $op->next; 1241 my $next = $op->next;
1242 reload_lexicals(); 1242 reload_lexicals();
1243 unshift( @bblock_todo, $next ); 1243 unshift( @bblock_todo, $next );
1244 if ( @stack >= 1 ) { 1244 if ( @stack >= 1 ) {
1245 my $obj = pop @stack; 1245 my $obj = pop @stack;
1246 my $bool = $obj->as_bool; 1246 my $bool = $obj->as_bool;
1247 write_back_stack(); 1247 write_back_stack();
1248 save_or_restore_lexical_state($$next); 1248 save_or_restore_lexical_state($$next);
1249 runtime( 1249 runtime(
1250 sprintf( 1250 sprintf(
1251 "if ($bool) { PUSHs((SV*)%s); goto %s; }", $obj->as_sv, label($next) 1251 "if ($bool) { PUSHs((SV*)%s); goto %s; }", $obj->as_sv, label($next)
1252 ) 1252 )
1253 ); 1253 );
1254 } 1254 }
1255 else { 1255 else {
1256 save_or_restore_lexical_state($$next); 1256 save_or_restore_lexical_state($$next);
1257 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ), 1257 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ),
1258 "*sp--;" ); 1258 "*sp--;" );
1259 } 1259 }
1260 return $op->other; 1260 return $op->other;
1261 } 1261 }
1262 1262
1263 # Nearly identical to pp_or, but leaves stack unchanged. 1263 # Nearly identical to pp_or, but leaves stack unchanged.
1264 sub pp_orassign { 1264 sub pp_orassign {
1265 my $op = shift; 1265 my $op = shift;
1266 my $next = $op->next; 1266 my $next = $op->next;
1267 reload_lexicals(); 1267 reload_lexicals();
1268 unshift( @bblock_todo, $next ); 1268 unshift( @bblock_todo, $next );
1269 if ( @stack >= 1 ) { 1269 if ( @stack >= 1 ) {
1270 my $obj = pop @stack; 1270 my $obj = pop @stack;
1271 my $bool = $obj->as_bool; 1271 my $bool = $obj->as_bool;
1272 write_back_stack(); 1272 write_back_stack();
1273 save_or_restore_lexical_state($$next); 1273 save_or_restore_lexical_state($$next);
1274 runtime( 1274 runtime(
1275 sprintf( 1275 sprintf(
1276 "PUSHs((SV*)%s); if ($bool) { goto %s; }", $obj->as_sv, label($next) 1276 "PUSHs((SV*)%s); if ($bool) { goto %s; }", $obj->as_sv, label($next)
1277 ) 1277 )
1278 ); 1278 );
1279 } 1279 }
1280 else { 1280 else {
1281 save_or_restore_lexical_state($$next); 1281 save_or_restore_lexical_state($$next);
1282 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ) ); 1282 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ) );
1283 } 1283 }
1284 return $op->other; 1284 return $op->other;
1285 } 1285 }
1286 1286
1287 # coverage: issue 45 (1,2) 1287 # coverage: issue 45 (1,2)
1288 # in CORE aliased to pp_defined 1288 # in CORE aliased to pp_defined
1289 # default dor is okay issue 45 (3,4) 1289 # default dor is okay issue 45 (3,4)
1290 sub pp_dorassign { 1290 sub pp_dorassign {
1291 my $op = shift; 1291 my $op = shift;
1292 my $next = $op->next; 1292 my $next = $op->next;
1293 reload_lexicals(); 1293 reload_lexicals();
1294 unshift( @bblock_todo, $next ); 1294 unshift( @bblock_todo, $next );
1295 my $sv = pop @stack; 1295 my $sv = pop @stack;
1296 write_back_stack(); 1296 write_back_stack();
1297 save_or_restore_lexical_state($$next); 1297 save_or_restore_lexical_state($$next);
1298 runtime( sprintf( "PUSHs(%s); if (%s && SvANY(%s)) goto %s;\t/* dorassign */", 1298 runtime( sprintf( "PUSHs(%s); if (%s && SvANY(%s)) goto %s;\t/* dorassign */",
1299 $sv->as_sv, $sv->as_sv, $sv->as_sv, label($next)) ) if $sv; 1299 $sv->as_sv, $sv->as_sv, $sv->as_sv, label($next)) ) if $sv;
1300 return $op->other; 1300 return $op->other;
1301 } 1301 }
1302 1302
1303 # coverage: 102 1303 # coverage: 102
1304 sub pp_cond_expr { 1304 sub pp_cond_expr {
1305 my $op = shift; 1305 my $op = shift;
1306 my $false = $op->next; 1306 my $false = $op->next;
1307 unshift( @bblock_todo, $false ); 1307 unshift( @bblock_todo, $false );
1308 reload_lexicals(); 1308 reload_lexicals();
1309 my $bool = pop_bool(); 1309 my $bool = pop_bool();
1310 write_back_stack(); 1310 write_back_stack();
1311 save_or_restore_lexical_state($$false); 1311 save_or_restore_lexical_state($$false);
1312 runtime( sprintf( "if (!$bool) goto %s;\t/* cond_expr */", label($false) ) ); 1312 runtime( sprintf( "if (!$bool) goto %s;\t/* cond_expr */", label($false) ) );
1313 return $op->other; 1313 return $op->other;
1314 } 1314 }
1315 1315
1316 # coverage: 9,10,12,17,18,22,28,32 1316 # coverage: 9,10,12,17,18,22,28,32
1317 sub pp_padsv { 1317 sub pp_padsv {
1318 my $op = shift; 1318 my $op = shift;
1319 my $ix = $op->targ; 1319 my $ix = $op->targ;
1320 push( @stack, $pad[$ix] ) if $pad[$ix]; 1320 push( @stack, $pad[$ix] ) if $pad[$ix];
1321 if ( $op->flags & OPf_MOD ) { 1321 if ( $op->flags & OPf_MOD ) {
1322 my $private = $op->private; 1322 my $private = $op->private;
1323 if ( $private & OPpLVAL_INTRO ) { 1323 if ( $private & OPpLVAL_INTRO ) {
1324 # coverage: 9,10,12,17,18,19,20,22,27,28,31,32 1324 # coverage: 9,10,12,17,18,19,20,22,27,28,31,32
1325 runtime("SAVECLEARSV(PL_curpad[$ix]);"); 1325 runtime("SAVECLEARSV(PL_curpad[$ix]);");
1326 } 1326 }
1327 elsif ( $private & OPpDEREF ) { 1327 elsif ( $private & OPpDEREF ) {
1328 # coverage: 18 1328 # coverage: 18
1329 if ($] >= 5.015002) { 1329 if ($] >= 5.015002) {
1330 runtime(sprintf( "PL_curpad[%d] = Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);", 1330 runtime(sprintf( "PL_curpad[%d] = Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);",
1331 $ix, $ix, $private & OPpDEREF )); 1331 $ix, $ix, $private & OPpDEREF ));
1332 } else { 1332 } else {
1333 runtime(sprintf( "Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);", 1333 runtime(sprintf( "Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);",
1334 $ix, $private & OPpDEREF )); 1334 $ix, $private & OPpDEREF ));
1335 } 1335 }
1336 $vivify_ref_defined++; 1336 $vivify_ref_defined++;
1337 $pad[$ix]->invalidate; 1337 $pad[$ix]->invalidate;
1338 } 1338 }
1339 } 1339 }
1340 return $op->next; 1340 return $op->next;
1341 } 1341 }
1342 1342
1343 # coverage: 1-5,7-14,18-23,25,27-32 1343 # coverage: 1-5,7-14,18-23,25,27-32
1344 sub pp_const { 1344 sub pp_const {
1345 my $op = shift; 1345 my $op = shift;
1346 my $sv = $op->sv; 1346 my $sv = $op->sv;
1347 my $obj; 1347 my $obj;
1348 1348
1349 # constant could be in the pad (under useithreads) 1349 # constant could be in the pad (under useithreads)
1350 if ($$sv) { 1350 if ($$sv) {
1351 $obj = $constobj{$$sv}; 1351 $obj = $constobj{$$sv};
1352 if ( !defined($obj) ) { 1352 if ( !defined($obj) ) {
1353 $obj = $constobj{$$sv} = B::Stackobj::Const->new($sv); 1353 $obj = $constobj{$$sv} = B::Stackobj::Const->new($sv);
1354 } 1354 }
1355 } 1355 }
1356 else { 1356 else {
1357 $obj = $pad[ $op->targ ]; 1357 $obj = $pad[ $op->targ ];
1358 } 1358 }
1359 push( @stack, $obj ); 1359 push( @stack, $obj );
1360 return $op->next; 1360 return $op->next;
1361 } 1361 }
1362 1362
1363 # coverage: 1-39, fails in 33 1363 # coverage: 1-39, fails in 33
1364 sub pp_nextstate { 1364 sub pp_nextstate {
1365 my $op = shift; 1365 my $op = shift;
1366 if ($labels->{'nextstate'}->[-1] and $labels->{'nextstate'}->[-1] == $op) { 1366 if ($labels->{'nextstate'}->[-1] and $labels->{'nextstate'}->[-1] == $op) {
1367 debug sprintf("pop_label nextstate: cxstack label %s\n", $curcop->[0]->label) if $debug{cxstack}; 1367 debug sprintf("pop_label nextstate: cxstack label %s\n", $curcop->[0]->label) if $debug{cxstack};
1368 pop_label 'nextstate'; 1368 pop_label 'nextstate';
1369 } else { 1369 } else {
1370 write_label($op); 1370 write_label($op);
1371 } 1371 }
1372 $curcop->load($op); 1372 $curcop->load($op);
1373 @stack = (); 1373 @stack = ();
1374 debug( sprintf( "%s:%d\n", $op->file, $op->line ) ) if $debug{lineno}; 1374 debug( sprintf( "%s:%d\n", $op->file, $op->line ) ) if $debug{lineno};
1375 debug( sprintf( "CopLABEL %s\n", $op->label ) ) if $op->label and $debug{cxstack}; 1375 debug( sprintf( "CopLABEL %s\n", $op->label ) ) if $op->label and $debug{cxstack};
1376 runtime("TAINT_NOT;") unless $omit_taint; 1376 runtime("TAINT_NOT;") unless $omit_taint;
1377 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); 1377 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
1378 if ( $freetmps_each_bblock || $freetmps_each_loop ) { 1378 if ( $freetmps_each_bblock || $freetmps_each_loop ) {
1379 $need_freetmps = 1; 1379 $need_freetmps = 1;
1380 } 1380 }
1381 else { 1381 else {
1382 runtime("FREETMPS;"); 1382 runtime("FREETMPS;");
1383 } 1383 }
1384 return $op->next; 1384 return $op->next;
1385 } 1385 }
1386 1386
1387 # Like pp_nextstate, but used instead when the debugger is active. 1387 # Like pp_nextstate, but used instead when the debugger is active.
1388 sub pp_dbstate { pp_nextstate(@_) } 1388 sub pp_dbstate { pp_nextstate(@_) }
1389 1389
1390 #default_pp will handle this: 1390 #default_pp will handle this:
1391 #sub pp_repeat { $curcop->write_back; default_pp(@_) } 1391 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
1392 # The following subs need $curcop->write_back if we decide to support arybase: 1392 # The following subs need $curcop->write_back if we decide to support arybase:
1393 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice 1393 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
1394 #sub pp_caller { $curcop->write_back; default_pp(@_) } 1394 #sub pp_caller { $curcop->write_back; default_pp(@_) }
1395 1395
1396 # coverage: ny 1396 # coverage: ny
1397 sub bad_pp_reset { 1397 sub bad_pp_reset {
1398 if ($inline_ops) { 1398 if ($inline_ops) {
1399 my $op = shift; 1399 my $op = shift;
1400 warn "inlining reset\n" if $debug{op}; 1400 warn "inlining reset\n" if $debug{op};
1401 $curcop->write_back if $curcop; 1401 $curcop->write_back if $curcop;
1402 runtime '{ /* pp_reset */'; 1402 runtime '{ /* pp_reset */';
1403 runtime ' const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;'; 1403 runtime ' const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;';
1404 runtime ' sv_reset(tmps, CopSTASH(PL_curcop));}'; 1404 runtime ' sv_reset(tmps, CopSTASH(PL_curcop));}';
1405 runtime 'PUSHs(&PL_sv_yes);'; 1405 runtime 'PUSHs(&PL_sv_yes);';
1406 return $op->next; 1406 return $op->next;
1407 } else { 1407 } else {
1408 default_pp(@_); 1408 default_pp(@_);
1409 } 1409 }
1410 } 1410 }
1411 1411
1412 # coverage: 20 1412 # coverage: 20
1413 sub pp_regcreset { 1413 sub pp_regcreset {
1414 if ($inline_ops) { 1414 if ($inline_ops) {
1415 my $op = shift; 1415 my $op = shift;
1416 warn "inlining regcreset\n" if $debug{op}; 1416 warn "inlining regcreset\n" if $debug{op};
1417 $curcop->write_back if $curcop; 1417 $curcop->write_back if $curcop;
1418 runtime 'PL_reginterp_cnt = 0; /* pp_regcreset */'; 1418 runtime 'PL_reginterp_cnt = 0; /* pp_regcreset */';
1419 runtime 'TAINT_NOT;'; 1419 runtime 'TAINT_NOT;';
1420 return $op->next; 1420 return $op->next;
1421 } else { 1421 } else {
1422 default_pp(@_); 1422 default_pp(@_);
1423 } 1423 }
1424 } 1424 }
1425 1425
1426 # coverage: 103 1426 # coverage: 103
1427 sub pp_stringify { 1427 sub pp_stringify {
1428 if ($inline_ops and $] >= 5.008) { 1428 if ($inline_ops and $] >= 5.008) {
1429 my $op = shift; 1429 my $op = shift;
1430 warn "inlining stringify\n" if $debug{op}; 1430 warn "inlining stringify\n" if $debug{op};
1431 my $sv = top_sv(); 1431 my $sv = top_sv();
1432 my $ix = $op->targ; 1432 my $ix = $op->targ;
1433 my $targ = $pad[$ix]; 1433 my $targ = $pad[$ix];
1434 runtime "sv_copypv(PL_curpad[$ix], $sv);\t/* pp_stringify */"; 1434 runtime "sv_copypv(PL_curpad[$ix], $sv);\t/* pp_stringify */";
1435 $stack[-1] = $targ if @stack; 1435 $stack[-1] = $targ if @stack;
1436 return $op->next; 1436 return $op->next;
1437 } else { 1437 } else {
1438 default_pp(@_); 1438 default_pp(@_);
1439 } 1439 }
1440 } 1440 }
1441 1441
1442 # coverage: 9,10,27 1442 # coverage: 9,10,27
1443 sub bad_pp_anoncode { 1443 sub bad_pp_anoncode {
1444 if ($inline_ops) { 1444 if ($inline_ops) {
1445 my $op = shift; 1445 my $op = shift;
1446 warn "inlining anoncode\n" if $debug{op}; 1446 warn "inlining anoncode\n" if $debug{op};
1447 my $ix = $op->targ; 1447 my $ix = $op->targ;
1448 my $ppname = "pp_" . $op->name; 1448 my $ppname = "pp_" . $op->name;
1449 write_back_lexicals() unless $skip_lexicals{$ppname}; 1449 write_back_lexicals() unless $skip_lexicals{$ppname};
1450 write_back_stack() unless $skip_stack{$ppname}; 1450 write_back_stack() unless $skip_stack{$ppname};
1451 # XXX finish me. this works only with >= 5.10 1451 # XXX finish me. this works only with >= 5.10
1452 runtime '{ /* pp_anoncode */', 1452 runtime '{ /* pp_anoncode */',
1453 ' CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));', 1453 ' CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));',
1454 ' if (CvCLONE(cv))', 1454 ' if (CvCLONE(cv))',
1455 ' cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(Perl_cv_clone(aTHX_ cv))));', 1455 ' cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(Perl_cv_clone(aTHX_ cv))));',
1456 ' EXTEND(SP,1);', 1456 ' EXTEND(SP,1);',
1457 ' PUSHs(MUTABLE_SV(cv));', 1457 ' PUSHs(MUTABLE_SV(cv));',
1458 '}'; 1458 '}';
1459 invalidate_lexicals() unless $skip_invalidate{$ppname}; 1459 invalidate_lexicals() unless $skip_invalidate{$ppname};
1460 return $op->next; 1460 return $op->next;
1461 } else { 1461 } else {
1462 default_pp(@_); 1462 default_pp(@_);
1463 } 1463 }
1464 } 1464 }
1465 1465
1466 # coverage: 35 1466 # coverage: 35
1467 # XXX TODO store package_pv in entersub and bless 1467 # XXX TODO store package_pv in entersub and bless
1468 sub pp_method_named { 1468 sub pp_method_named {
1469 my ( $op ) = @_; 1469 my ( $op ) = @_;
1470 my $cv = B::C::method_named(B::C::svop_pv($op)); 1470 my $cv = B::C::method_named(B::C::svop_pv($op));
1471 $cv->save if $cv; 1471 $cv->save if $cv;
1472 default_pp(@_); 1472 default_pp(@_);
1473 } 1473 }
1474 1474
1475 # inconsequence: gvs are not passed around on the stack 1475 # inconsequence: gvs are not passed around on the stack
1476 # coverage: 26,103 1476 # coverage: 26,103
1477 sub bad_pp_srefgen { 1477 sub bad_pp_srefgen {
1478 if ($inline_ops) { 1478 if ($inline_ops) {
1479 my $op = shift; 1479 my $op = shift;
1480 warn "inlining srefgen\n" if $debug{op}; 1480 warn "inlining srefgen\n" if $debug{op};
1481 #my $ppname = "pp_" . $op->name; 1481 #my $ppname = "pp_" . $op->name;
1482 #$curcop->write_back; 1482 #$curcop->write_back;
1483 #write_back_lexicals() unless $skip_lexicals{$ppname}; 1483 #write_back_lexicals() unless $skip_lexicals{$ppname};
1484 #write_back_stack() unless $skip_stack{$ppname}; 1484 #write_back_stack() unless $skip_stack{$ppname};
1485 my $svobj = $stack[-1]->as_sv; 1485 my $svobj = $stack[-1]->as_sv;
1486 my $sv = pop_sv(); 1486 my $sv = pop_sv();
1487 # XXX fix me 1487 # XXX fix me
1488 runtime "{ /* pp_srefgen */ 1488 runtime "{ /* pp_srefgen */
1489 SV* rv; 1489 SV* rv;
1490 SV* sv = $sv;"; 1490 SV* sv = $sv;";
1491 # sv = POPs 1491 # sv = POPs
1492 #B::svref_2object(\$sv); 1492 #B::svref_2object(\$sv);
1493 if (($svobj->flags & 0xff) == $SVt_PVLV 1493 if (($svobj->flags & 0xff) == $SVt_PVLV
1494 and B::PVLV::LvTYPE($svobj) eq ord('y')) 1494 and B::PVLV::LvTYPE($svobj) eq ord('y'))
1495 { 1495 {
1496 runtime 'if (LvTARGLEN(sv)) 1496 runtime 'if (LvTARGLEN(sv))
1497 vivify_defelem(sv); 1497 vivify_defelem(sv);
1498 if (!(sv = LvTARG(sv))) 1498 if (!(sv = LvTARG(sv)))
1499 sv = &PL_sv_undef; 1499 sv = &PL_sv_undef;
1500 else 1500 else
1501 SvREFCNT_inc_void_NN(sv);'; 1501 SvREFCNT_inc_void_NN(sv);';
1502 } 1502 }
1503 elsif (($svobj->flags & 0xff) == $SVt_PVAV) { 1503 elsif (($svobj->flags & 0xff) == $SVt_PVAV) {
1504 runtime 'if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv)) 1504 runtime 'if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
1505 av_reify(MUTABLE_AV(sv)); 1505 av_reify(MUTABLE_AV(sv));
1506 SvTEMP_off(sv); 1506 SvTEMP_off(sv);
1507 SvREFCNT_inc_void_NN(sv);'; 1507 SvREFCNT_inc_void_NN(sv);';
1508 } 1508 }
1509 #elsif ($sv->SvPADTMP && !IS_PADGV(sv)) { 1509 #elsif ($sv->SvPADTMP && !IS_PADGV(sv)) {
1510 # runtime 'sv = newSVsv(sv);'; 1510 # runtime 'sv = newSVsv(sv);';
1511 #} 1511 #}
1512 else { 1512 else {
1513 runtime 'SvTEMP_off(sv); 1513 runtime 'SvTEMP_off(sv);
1514 SvREFCNT_inc_void_NN(sv);'; 1514 SvREFCNT_inc_void_NN(sv);';
1515 } 1515 }
1516 runtime 'rv = sv_newmortal(); 1516 runtime 'rv = sv_newmortal();
1517 sv_upgrade(rv, SVt_IV); 1517 sv_upgrade(rv, SVt_IV);
1518 SvRV_set(rv, sv); 1518 SvRV_set(rv, sv);
1519 SvROK_on(rv); 1519 SvROK_on(rv);
1520 PUSHBACK; 1520 PUSHBACK;
1521 }'; 1521 }';
1522 return $op->next; 1522 return $op->next;
1523 } else { 1523 } else {
1524 default_pp(@_); 1524 default_pp(@_);
1525 } 1525 }
1526 } 1526 }
1527 1527
1528 # coverage: 9,10,27 1528 # coverage: 9,10,27
1529 #sub pp_refgen 1529 #sub pp_refgen
1530 1530
1531 # coverage: 28, 14 1531 # coverage: 28, 14
1532 sub pp_rv2gv { 1532 sub pp_rv2gv {
1533 my $op = shift; 1533 my $op = shift;
1534 $curcop->write_back if $curcop; 1534 $curcop->write_back if $curcop;
1535 my $ppname = "pp_" . $op->name; 1535 my $ppname = "pp_" . $op->name;
1536 write_back_lexicals() unless $skip_lexicals{$ppname}; 1536 write_back_lexicals() unless $skip_lexicals{$ppname};
1537 write_back_stack() unless $skip_stack{$ppname}; 1537 write_back_stack() unless $skip_stack{$ppname};
1538 my $sym = doop($op); 1538 my $sym = doop($op);
1539 if ( $op->private & OPpDEREF ) { 1539 if ( $op->private & OPpDEREF ) {
1540 $init->add( sprintf("((UNOP *)$sym)->op_first = $sym;") ); 1540 $init->add( sprintf("((UNOP *)$sym)->op_first = $sym;") );
1541 $init->add( sprintf( "((UNOP *)$sym)->op_type = %d;", $op->first->type ) ); 1541 $init->add( sprintf( "((UNOP *)$sym)->op_type = %d;", $op->first->type ) );
1542 } 1542 }
1543 return $op->next; 1543 return $op->next;
1544 } 1544 }
1545 1545
1546 # coverage: 18,19,25 1546 # coverage: 18,19,25
1547 sub pp_sort { 1547 sub pp_sort {
1548 my $op = shift; 1548 my $op = shift;
1549 #my $ppname = $op->ppaddr; 1549 #my $ppname = $op->ppaddr;
1550 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED ) { 1550 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED ) {
1551 # blocksort is awful. E.g. we need to the leading NULL op, invalidates -fcop 1551 # blocksort is awful. E.g. we need to the leading NULL op, invalidates -fcop
1552 # Ugly surgery required. sort expects as block: pushmark rv2gv leave => enter 1552 # Ugly surgery required. sort expects as block: pushmark rv2gv leave => enter
1553 # pp_sort() OP *kid = cLISTOP->op_first->op_sibling;/* skip over pushmark 4 to null */ 1553 # pp_sort() OP *kid = cLISTOP->op_first->op_sibling;/* skip over pushmark 4 to null */
1554 # kid = cUNOPx(kid)->op_first; /* pass rv2gv (null'ed) */ 1554 # kid = cUNOPx(kid)->op_first; /* pass rv2gv (null'ed) */
1555 # kid = cUNOPx(kid)->op_first; /* pass leave */ 1555 # kid = cUNOPx(kid)->op_first; /* pass leave */
1556 # 1556 #
1557 #3 <0> pushmark s ->4 1557 #3 <0> pushmark s ->4
1558 #8 <@> sort lKS* ->9 1558 #8 <@> sort lKS* ->9
1559 #4 <0> pushmark s ->5 1559 #4 <0> pushmark s ->5
1560 #- <1> null sK/1 ->5 1560 #- <1> null sK/1 ->5
1561 #- <1> ex-leave sKP ->- 1561 #- <1> ex-leave sKP ->-
1562 #- <0> enter s ->- 1562 #- <0> enter s ->-
1563 # some code doing cmp or ncmp 1563 # some code doing cmp or ncmp
1564 # Example with 3 const args: print sort { bla; $b <=> $a } 1,4,3 1564 # Example with 3 const args: print sort { bla; $b <=> $a } 1,4,3
1565 #5 <$> const[IV 1] s ->6 1565 #5 <$> const[IV 1] s ->6
1566 #6 <$> const[IV 4] s ->7 1566 #6 <$> const[IV 4] s ->7
1567 #7 <$> const[IV 3] s ->8 => sort 1567 #7 <$> const[IV 3] s ->8 => sort
1568 # 1568 #
1569 my $root = $op->first->sibling->first; #leave or null 1569 my $root = $op->first->sibling->first; #leave or null
1570 my $start = $root->first; #enter 1570 my $start = $root->first; #enter
1571 warn "blocksort: root=",$root->name,", start=",$start->name,"\n" if $debug{op}; 1571 warn "blocksort: root=",$root->name,", start=",$start->name,"\n" if $debug{op};
1572 my $pushmark = $op->first->save; #pushmark sibling to null 1572 my $pushmark = $op->first->save; #pushmark sibling to null
1573 $op->first->sibling->save; #null->first to leave 1573 $op->first->sibling->save; #null->first to leave
1574 $root->save; #ex-leave 1574 $root->save; #ex-leave
1575 my $sym = $start->save; #enter 1575 my $sym = $start->save; #enter
1576 my $fakeop = cc_queue( "pp_sort" . $$op, $root, $start ); 1576 my $fakeop = cc_queue( "pp_sort" . $$op, $root, $start );
1577 $init->add( sprintf( "(%s)->op_next = %s;", $sym, $fakeop ) ); 1577 $init->add( sprintf( "(%s)->op_next = %s;", $sym, $fakeop ) );
1578 } 1578 }
1579 $curcop->write_back; 1579 $curcop->write_back;
1580 write_back_lexicals(); 1580 write_back_lexicals();
1581 write_back_stack(); 1581 write_back_stack();
1582 doop($op); 1582 doop($op);
1583 return $op->next; 1583 return $op->next;
1584 } 1584 }
1585 1585
1586 # coverage: 2-4,6,7,13,15,21,24,26,27,30,31 1586 # coverage: 2-4,6,7,13,15,21,24,26,27,30,31
1587 sub pp_gv { 1587 sub pp_gv {
1588 my $op = shift; 1588 my $op = shift;
1589 my $gvsym; 1589 my $gvsym;
1590 if ($ITHREADS) { 1590 if ($ITHREADS) {
1591 $gvsym = $pad[ $op->padix ]->as_sv; 1591 $gvsym = $pad[ $op->padix ]->as_sv;
1592 #push @stack, ($pad[$op->padix]); 1592 #push @stack, ($pad[$op->padix]);
1593 } 1593 }
1594 else { 1594 else {
1595 $gvsym = $op->gv->save; 1595 $gvsym = $op->gv->save;
1596 # XXX 1596 # XXX
1597 #my $obj = new B::Stackobj::Const($op->gv); 1597 #my $obj = new B::Stackobj::Const($op->gv);
1598 #push( @stack, $obj ); 1598 #push( @stack, $obj );
1599 } 1599 }
1600 write_back_stack(); 1600 write_back_stack();
1601 runtime("XPUSHs((SV*)$gvsym);"); 1601 runtime("XPUSHs((SV*)$gvsym);");
1602 return $op->next; 1602 return $op->next;
1603 } 1603 }
1604 1604
1605 # coverage: 2,3,4,9,11,14,20,21,23,28 1605 # coverage: 2,3,4,9,11,14,20,21,23,28
1606 sub pp_gvsv { 1606 sub pp_gvsv {
1607 my $op = shift; 1607 my $op = shift;
1608 my $gvsym; 1608 my $gvsym;
1609 if ($ITHREADS) { 1609 if ($ITHREADS) {
1610 #debug(sprintf("OP name=%s, class=%s\n",$op->name,class($op))) if $debug{pad}; 1610 #debug(sprintf("OP name=%s, class=%s\n",$op->name,class($op))) if $debug{pad};
1611 debug( sprintf( "GVSV->padix = %d\n", $op->padix ) ) if $debug{pad}; 1611 debug( sprintf( "GVSV->padix = %d\n", $op->padix ) ) if $debug{pad};
1612 $gvsym = $pad[ $op->padix ]->as_sv; 1612 $gvsym = $pad[ $op->padix ]->as_sv;
1613 debug( sprintf( "GVSV->private = 0x%x\n", $op->private ) ) if $debug{pad}; 1613 debug( sprintf( "GVSV->private = 0x%x\n", $op->private ) ) if $debug{pad};
1614 } 1614 }
1615 else { 1615 else {
1616 $gvsym = $op->gv->save; 1616 $gvsym = $op->gv->save;
1617 } 1617 }
1618 # Expects GV*, not SV* PL_curpad 1618 # Expects GV*, not SV* PL_curpad
1619 $gvsym = "(GV*)$gvsym" if $gvsym =~ /PL_curpad/; 1619 $gvsym = "(GV*)$gvsym" if $gvsym =~ /PL_curpad/;
1620 write_back_stack(); 1620 write_back_stack();
1621 if ( $op->private & OPpLVAL_INTRO ) { 1621 if ( $op->private & OPpLVAL_INTRO ) {
1622 runtime("XPUSHs(save_scalar($gvsym));"); 1622 runtime("XPUSHs(save_scalar($gvsym));");
1623 #my $obj = new B::Stackobj::Const($op->gv); 1623 #my $obj = new B::Stackobj::Const($op->gv);
1624 #push( @stack, $obj ); 1624 #push( @stack, $obj );
1625 } 1625 }
1626 else { 1626 else {
1627 $PERL510 1627 $PERL510
1628 ? runtime("XPUSHs(GvSVn($gvsym));") 1628 ? runtime("XPUSHs(GvSVn($gvsym));")
1629 : runtime("XPUSHs(GvSV($gvsym));"); 1629 : runtime("XPUSHs(GvSV($gvsym));");
1630 } 1630 }
1631 return $op->next; 1631 return $op->next;
1632 } 1632 }
1633 1633
1634 # coverage: 16, issue44 1634 # coverage: 16, issue44
1635 sub pp_aelemfast { 1635 sub pp_aelemfast {
1636 my $op = shift; 1636 my $op = shift;
1637 my $av; 1637 my $av;
1638 if ($op->flags & OPf_SPECIAL) { 1638 if ($op->flags & OPf_SPECIAL) {
1639 my $sv = $pad[ $op->targ ]->as_sv; 1639 my $sv = $pad[ $op->targ ]->as_sv;
1640 $av = $] > 5.01000 ? "MUTABLE_AV($sv)" : $sv; 1640 $av = $] > 5.01000 ? "MUTABLE_AV($sv)" : $sv;
1641 } else { 1641 } else {
1642 my $gvsym; 1642 my $gvsym;
1643 if ($ITHREADS) { #padop XXX if it's only a OP, no PADOP? t/CORE/op/ref.t test 36 1643 if ($ITHREADS) { #padop XXX if it's only a OP, no PADOP? t/CORE/op/ref.t test 36
1644 if ($op->can('padix')) { 1644 if ($op->can('padix')) {
1645 #warn "padix\n"; 1645 #warn "padix\n";
1646 $gvsym = $pad[ $op->padix ]->as_sv; 1646 $gvsym = $pad[ $op->padix ]->as_sv;
1647 } else { 1647 } else {
1648 $gvsym = 'PL_incgv'; # XXX passes, but need to investigate why. cc test 43 5.10.1 1648 $gvsym = 'PL_incgv'; # XXX passes, but need to investigate why. cc test 43 5.10.1
1649 #write_back_stack(); 1649 #write_back_stack();
1650 #runtime("PUSHs(&PL_sv_undef);"); 1650 #runtime("PUSHs(&PL_sv_undef);");
1651 #return $op->next; 1651 #return $op->next;
1652 } 1652 }
1653 } 1653 }
1654 else { #svop 1654 else { #svop
1655 $gvsym = $op->gv->save; 1655 $gvsym = $op->gv->save;
1656 } 1656 }
1657 $av = "GvAV($gvsym)"; 1657 $av = "GvAV($gvsym)";
1658 } 1658 }
1659 my $ix = $op->private; 1659 my $ix = $op->private;
1660 my $lval = $op->flags & OPf_MOD; 1660 my $lval = $op->flags & OPf_MOD;
1661 write_back_stack(); 1661 write_back_stack();
1662 runtime( 1662 runtime(
1663 "{ AV* av = $av;", 1663 "{ AV* av = $av;",
1664 " SV** const svp = av_fetch(av, $ix, $lval);", 1664 " SV** const svp = av_fetch(av, $ix, $lval);",
1665 " SV *sv = (svp ? *svp : &PL_sv_undef);", 1665 " SV *sv = (svp ? *svp : &PL_sv_undef);",
1666 !$lval ? " if (SvRMAGICAL(av) && SvGMAGICAL(sv)) mg_get(sv);" : "", 1666 !$lval ? " if (SvRMAGICAL(av) && SvGMAGICAL(sv)) mg_get(sv);" : "",
1667 " PUSHs(sv);", 1667 " PUSHs(sv);",
1668 "}" 1668 "}"
1669 ); 1669 );
1670 return $op->next; 1670 return $op->next;
1671 } 1671 }
1672 1672
1673 # coverage: ? 1673 # coverage: ?
1674 sub int_binop { 1674 sub int_binop {
1675 my ( $op, $operator, $unsigned ) = @_; 1675 my ( $op, $operator, $unsigned ) = @_;
1676 if ( $op->flags & OPf_STACKED ) { 1676 if ( $op->flags & OPf_STACKED ) {
1677 my $right = pop_int(); 1677 my $right = pop_int();
1678 if ( @stack >= 1 ) { 1678 if ( @stack >= 1 ) {
1679 my $left = top_int(); 1679 my $left = top_int();
1680 $stack[-1]->set_int( &$operator( $left, $right ), $unsigned ); 1680 $stack[-1]->set_int( &$operator( $left, $right ), $unsigned );
1681 } 1681 }
1682 else { 1682 else {
1683 my $sv_setxv = $unsigned ? 'sv_setuv' : 'sv_setiv'; 1683 my $sv_setxv = $unsigned ? 'sv_setuv' : 'sv_setiv';
1684 runtime( sprintf( "$sv_setxv(TOPs, %s);", &$operator( "TOPi", $right ) ) ); 1684 runtime( sprintf( "$sv_setxv(TOPs, %s);", &$operator( "TOPi", $right ) ) );
1685 } 1685 }
1686 } 1686 }
1687 else { 1687 else {
1688 my $targ = $pad[ $op->targ ]; 1688 my $targ = $pad[ $op->targ ];
1689 my $right = B::Pseudoreg->new( "IV", "riv" ); 1689 my $right = B::Pseudoreg->new( "IV", "riv" );
1690 my $left = B::Pseudoreg->new( "IV", "liv" ); 1690 my $left = B::Pseudoreg->new( "IV", "liv" );
1691 runtime( sprintf( "$$right = %s; $$left = %s;", pop_int(), pop_int ) ); 1691 runtime( sprintf( "$$right = %s; $$left = %s;", pop_int(), pop_int ) );
1692 $targ->set_int( &$operator( $$left, $$right ), $unsigned ); 1692 $targ->set_int( &$operator( $$left, $$right ), $unsigned );
1693 push( @stack, $targ ); 1693 push( @stack, $targ );
1694 } 1694 }
1695 return $op->next; 1695 return $op->next;
1696 } 1696 }
1697 1697
1698 sub INTS_CLOSED () { 0x1 } 1698 sub INTS_CLOSED () { 0x1 }
1699 sub INT_RESULT () { 0x2 } 1699 sub INT_RESULT () { 0x2 }
1700 sub NUMERIC_RESULT () { 0x4 } 1700 sub NUMERIC_RESULT () { 0x4 }
1701 1701
1702 # coverage: ? 1702 # coverage: ?
1703 sub numeric_binop { 1703 sub numeric_binop {
1704 my ( $op, $operator, $flags ) = @_; 1704 my ( $op, $operator, $flags ) = @_;
1705 my $force_int = 0; 1705 my $force_int = 0;
1706 $force_int ||= ( $flags & INT_RESULT ); 1706 $force_int ||= ( $flags & INT_RESULT );
1707 $force_int ||= 1707 $force_int ||=
1708 ( $flags & INTS_CLOSED 1708 ( $flags & INTS_CLOSED
1709 && @stack >= 2 1709 && @stack >= 2
1710 && valid_int( $stack[-2] ) 1710 && valid_int( $stack[-2] )
1711 && valid_int( $stack[-1] ) ); 1711 && valid_int( $stack[-1] ) );
1712 if ( $op->flags & OPf_STACKED ) { 1712 if ( $op->flags & OPf_STACKED ) {
1713 runtime(sprintf("/* %s */", $op->name)) if $verbose; 1713 runtime(sprintf("/* %s */", $op->name)) if $verbose;
1714 my $right = pop_numeric(); 1714 my $right = pop_numeric();
1715 if ( @stack >= 1 ) { 1715 if ( @stack >= 1 ) {
1716 my $left = top_numeric(); 1716 my $left = top_numeric();
1717 if ($force_int) { 1717 if ($force_int) {
1718 $stack[-1]->set_int( &$operator( $left, $right ) ); 1718 $stack[-1]->set_int( &$operator( $left, $right ) );
1719 } 1719 }
1720 else { 1720 else {
1721 $stack[-1]->set_numeric( &$operator( $left, $right ) ); 1721 $stack[-1]->set_numeric( &$operator( $left, $right ) );
1722 } 1722 }
1723 } 1723 }
1724 else { 1724 else {
1725 if ($force_int) { 1725 if ($force_int) {
1726 my $rightruntime = B::Pseudoreg->new( "IV", "riv" ); 1726 my $rightruntime = B::Pseudoreg->new( "IV", "riv" );
1727 runtime( sprintf( "$$rightruntime = %s;", $right ) ); 1727 runtime( sprintf( "$$rightruntime = %s;", $right ) );
1728 runtime( 1728 runtime(
1729 sprintf( 1729 sprintf(
1730 "sv_setiv(TOPs, %s);", &$operator( "TOPi", $$rightruntime ) 1730 "sv_setiv(TOPs, %s);", &$operator( "TOPi", $$rightruntime )
1731 ) 1731 )
1732 ); 1732 );
1733 } 1733 }
1734 else { 1734 else {
1735 my $rightruntime = B::Pseudoreg->new( "double", "rnv" ); 1735 my $rightruntime = B::Pseudoreg->new( "NV", "rnv" );
1736 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) ); 1736 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) );
1737 runtime( 1737 runtime(
1738 sprintf( 1738 sprintf(
1739 "sv_setnv(TOPs, %s);", &$operator( "TOPn", $$rightruntime ) 1739 "sv_setnv(TOPs, %s);", &$operator( "TOPn", $$rightruntime )
1740 ) 1740 )
1741 ); 1741 );
1742 } 1742 }
1743 } 1743 }
1744 } 1744 }
1745 else { 1745 else {
1746 my $targ = $pad[ $op->targ ]; 1746 my $targ = $pad[ $op->targ ];
1747 $force_int ||= ( $targ->{type} == T_INT ); 1747 $force_int ||= ( $targ->{type} == T_INT );
1748 if ($force_int) { 1748 if ($force_int) {
1749 my $right = B::Pseudoreg->new( "IV", "riv" ); 1749 my $right = B::Pseudoreg->new( "IV", "riv" );
1750 my $left = B::Pseudoreg->new( "IV", "liv" ); 1750 my $left = B::Pseudoreg->new( "IV", "liv" );
1751 runtime( 1751 runtime(
1752 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1752 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1753 pop_numeric(), pop_numeric, $op->name ) ); 1753 pop_numeric(), pop_numeric, $op->name ) );
1754 $targ->set_int( &$operator( $$left, $$right ) ); 1754 $targ->set_int( &$operator( $$left, $$right ) );
1755 } 1755 }
1756 else { 1756 else {
1757 my $right = B::Pseudoreg->new( "double", "rnv" ); 1757 my $right = B::Pseudoreg->new( "NV", "rnv" );
1758 my $left = B::Pseudoreg->new( "double", "lnv" ); 1758 my $left = B::Pseudoreg->new( "NV", "lnv" );
1759 runtime( 1759 runtime(
1760 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1760 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1761 pop_numeric(), pop_numeric, $op->name ) ); 1761 pop_numeric(), pop_numeric, $op->name ) );
1762 $targ->set_numeric( &$operator( $$left, $$right ) ); 1762 $targ->set_numeric( &$operator( $$left, $$right ) );
1763 } 1763 }
1764 push( @stack, $targ ); 1764 push( @stack, $targ );
1765 } 1765 }
1766 return $op->next; 1766 return $op->next;
1767 } 1767 }
1768 1768
1769 # coverage: 18 1769 # coverage: 18
1770 sub pp_ncmp { 1770 sub pp_ncmp {
1771 my ($op) = @_; 1771 my ($op) = @_;
1772 if ( $op->flags & OPf_STACKED ) { 1772 if ( $op->flags & OPf_STACKED ) {
1773 my $right = pop_numeric(); 1773 my $right = pop_numeric();
1774 if ( @stack >= 1 ) { 1774 if ( @stack >= 1 ) {
1775 my $left = top_numeric(); 1775 my $left = top_numeric();
1776 runtime sprintf( "if (%s > %s){\t/* %s */", $left, $right, $op->name ); 1776 runtime sprintf( "if (%s > %s){\t/* %s */", $left, $right, $op->name );
1777 $stack[-1]->set_int(1); 1777 $stack[-1]->set_int(1);
1778 $stack[-1]->write_back(); 1778 $stack[-1]->write_back();
1779 runtime sprintf( "}else if (%s < %s ) {", $left, $right ); 1779 runtime sprintf( "}else if (%s < %s ) {", $left, $right );
1780 $stack[-1]->set_int(-1); 1780 $stack[-1]->set_int(-1);
1781 $stack[-1]->write_back(); 1781 $stack[-1]->write_back();
1782 runtime sprintf( "}else if (%s == %s) {", $left, $right ); 1782 runtime sprintf( "}else if (%s == %s) {", $left, $right );
1783 $stack[-1]->set_int(0); 1783 $stack[-1]->set_int(0);
1784 $stack[-1]->write_back(); 1784 $stack[-1]->write_back();
1785 runtime sprintf("}else {"); 1785 runtime sprintf("}else {");
1786 $stack[-1]->set_sv("&PL_sv_undef"); 1786 $stack[-1]->set_sv("&PL_sv_undef");
1787 runtime "}"; 1787 runtime "}";
1788 } 1788 }
1789 else { 1789 else {
1790 my $rightruntime = B::Pseudoreg->new( "double", "rnv" ); 1790 my $rightruntime = B::Pseudoreg->new( "NV", "rnv" );
1791 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) ); 1791 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) );
1792 runtime sprintf( qq/if ("TOPn" > %s){/, $rightruntime ); 1792 runtime sprintf( qq/if ("TOPn" > %s){/, $rightruntime );
1793 runtime sprintf(" sv_setiv(TOPs,1);"); 1793 runtime sprintf(" sv_setiv(TOPs,1);");
1794 runtime sprintf( qq/}else if ( "TOPn" < %s ) {/, $$rightruntime ); 1794 runtime sprintf( qq/}else if ( "TOPn" < %s ) {/, $$rightruntime );
1795 runtime sprintf(" sv_setiv(TOPs,-1);"); 1795 runtime sprintf(" sv_setiv(TOPs,-1);");
1796 runtime sprintf( qq/} else if ("TOPn" == %s) {/, $$rightruntime ); 1796 runtime sprintf( qq/} else if ("TOPn" == %s) {/, $$rightruntime );
1797 runtime sprintf(" sv_setiv(TOPs,0);"); 1797 runtime sprintf(" sv_setiv(TOPs,0);");
1798 runtime sprintf(qq/}else {/); 1798 runtime sprintf(qq/}else {/);
1799 runtime sprintf(" sv_setiv(TOPs,&PL_sv_undef;"); 1799 runtime sprintf(" sv_setiv(TOPs,&PL_sv_undef;");
1800 runtime "}"; 1800 runtime "}";
1801 } 1801 }
1802 } 1802 }
1803 else { 1803 else {
1804 my $targ = $pad[ $op->targ ]; 1804 my $targ = $pad[ $op->targ ];
1805 my $right = B::Pseudoreg->new( "double", "rnv" ); 1805 my $right = B::Pseudoreg->new( "NV", "rnv" );
1806 my $left = B::Pseudoreg->new( "double", "lnv" ); 1806 my $left = B::Pseudoreg->new( "NV", "lnv" );
1807 runtime( 1807 runtime(
1808 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1808 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1809 pop_numeric(), pop_numeric, $op->name ) ); 1809 pop_numeric(), pop_numeric, $op->name ) );
1810 runtime sprintf( "if (%s > %s){ /*targ*/", $$left, $$right ); 1810 runtime sprintf( "if (%s > %s){ /*targ*/", $$left, $$right );
1811 $targ->set_int(1); 1811 $targ->set_int(1);
1812 $targ->write_back(); 1812 $targ->write_back();
1813 runtime sprintf( "}else if (%s < %s ) {", $$left, $$right ); 1813 runtime sprintf( "}else if (%s < %s ) {", $$left, $$right );
1814 $targ->set_int(-1); 1814 $targ->set_int(-1);
1815 $targ->write_back(); 1815 $targ->write_back();
1816 runtime sprintf( "}else if (%s == %s) {", $$left, $$right ); 1816 runtime sprintf( "}else if (%s == %s) {", $$left, $$right );
1817 $targ->set_int(0); 1817 $targ->set_int(0);
1818 $targ->write_back(); 1818 $targ->write_back();
1819 runtime sprintf("}else {"); 1819 runtime sprintf("}else {");
1820 $targ->set_sv("&PL_sv_undef"); 1820 $targ->set_sv("&PL_sv_undef");
1821 runtime "}"; 1821 runtime "}";
1822 push( @stack, $targ ); 1822 push( @stack, $targ );
1823 } 1823 }
1824 #runtime "return NULL;"; 1824 #runtime "return NULL;";
1825 return $op->next; 1825 return $op->next;
1826 } 1826 }
1827 1827
1828 # coverage: ? 1828 # coverage: ?
1829 sub sv_binop { 1829 sub sv_binop {
1830 my ( $op, $operator, $flags ) = @_; 1830 my ( $op, $operator, $flags ) = @_;
1831 if ( $op->flags & OPf_STACKED ) { 1831 if ( $op->flags & OPf_STACKED ) {
1832 my $right = pop_sv(); 1832 my $right = pop_sv();
1833 if ( @stack >= 1 ) { 1833 if ( @stack >= 1 ) {
1834 my $left = top_sv(); 1834 my $left = top_sv();
1835 if ( $flags & INT_RESULT ) { 1835 if ( $flags & INT_RESULT ) {
1836 $stack[-1]->set_int( &$operator( $left, $right ) ); 1836 $stack[-1]->set_int( &$operator( $left, $right ) );
1837 } 1837 }
1838 elsif ( $flags & NUMERIC_RESULT ) { 1838 elsif ( $flags & NUMERIC_RESULT ) {
1839 $stack[-1]->set_numeric( &$operator( $left, $right ) ); 1839 $stack[-1]->set_numeric( &$operator( $left, $right ) );
1840 } 1840 }
1841 else { 1841 else {
1842 # XXX Does this work? 1842 # XXX Does this work?
1843 runtime( 1843 runtime(
1844 sprintf( "sv_setsv($left, %s);\t/* %s */", 1844 sprintf( "sv_setsv($left, %s);\t/* %s */",
1845 &$operator( $left, $right ), $op->name ) ); 1845 &$operator( $left, $right ), $op->name ) );
1846 $stack[-1]->invalidate; 1846 $stack[-1]->invalidate;
1847 } 1847 }
1848 } 1848 }
1849 else { 1849 else {
1850 my $f; 1850 my $f;
1851 if ( $flags & INT_RESULT ) { 1851 if ( $flags & INT_RESULT ) {
1852 $f = "sv_setiv"; 1852 $f = "sv_setiv";
1853 } 1853 }
1854 elsif ( $flags & NUMERIC_RESULT ) { 1854 elsif ( $flags & NUMERIC_RESULT ) {
1855 $f = "sv_setnv"; 1855 $f = "sv_setnv";
1856 } 1856 }
1857 else { 1857 else {
1858 $f = "sv_setsv"; 1858 $f = "sv_setsv";
1859 } 1859 }
1860 runtime( sprintf( "%s(TOPs, %s);\t/* %s */", 1860 runtime( sprintf( "%s(TOPs, %s);\t/* %s */",
1861 $f, &$operator( "TOPs", $right ), $op->name ) ); 1861 $f, &$operator( "TOPs", $right ), $op->name ) );
1862 } 1862 }
1863 } 1863 }
1864 else { 1864 else {
1865 my $targ = $pad[ $op->targ ]; 1865 my $targ = $pad[ $op->targ ];
1866 runtime( sprintf( "right = %s; left = %s;\t/* %s */", 1866 runtime( sprintf( "right = %s; left = %s;\t/* %s */",
1867 pop_sv(), pop_sv, $op->name ) ); 1867 pop_sv(), pop_sv, $op->name ) );
1868 if ( $flags & INT_RESULT ) { 1868 if ( $flags & INT_RESULT ) {
1869 $targ->set_int( &$operator( "left", "right" ) ); 1869 $targ->set_int( &$operator( "left", "right" ) );
1870 } 1870 }
1871 elsif ( $flags & NUMERIC_RESULT ) { 1871 elsif ( $flags & NUMERIC_RESULT ) {
1872 $targ->set_numeric( &$operator( "left", "right" ) ); 1872 $targ->set_numeric( &$operator( "left", "right" ) );
1873 } 1873 }
1874 else { 1874 else {
1875 # XXX Does this work? 1875 # XXX Does this work?
1876 runtime(sprintf("sv_setsv(%s, %s);", 1876 runtime(sprintf("sv_setsv(%s, %s);",
1877 $targ->as_sv, &$operator( "left", "right" ) )); 1877 $targ->as_sv, &$operator( "left", "right" ) ));
1878 $targ->invalidate; 1878 $targ->invalidate;
1879 } 1879 }
1880 push( @stack, $targ ); 1880 push( @stack, $targ );
1881 } 1881 }
1882 return $op->next; 1882 return $op->next;
1883 } 1883 }
1884 1884
1885 # coverage: ? 1885 # coverage: ?
1886 sub bool_int_binop { 1886 sub bool_int_binop {
1887 my ( $op, $operator ) = @_; 1887 my ( $op, $operator ) = @_;
1888 my $right = B::Pseudoreg->new( "IV", "riv" ); 1888 my $right = B::Pseudoreg->new( "IV", "riv" );
1889 my $left = B::Pseudoreg->new( "IV", "liv" ); 1889 my $left = B::Pseudoreg->new( "IV", "liv" );
1890 runtime( sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1890 runtime( sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1891 pop_int(), pop_int(), $op->name ) ); 1891 pop_int(), pop_int(), $op->name ) );
1892 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) ); 1892 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
1893 $bool->set_int( &$operator( $$left, $$right ) ); 1893 $bool->set_int( &$operator( $$left, $$right ) );
1894 push( @stack, $bool ); 1894 push( @stack, $bool );
1895 return $op->next; 1895 return $op->next;
1896 } 1896 }
1897 1897
1898 # coverage: ? 1898 # coverage: ?
1899 sub bool_numeric_binop { 1899 sub bool_numeric_binop {
1900 my ( $op, $operator ) = @_; 1900 my ( $op, $operator ) = @_;
1901 my $right = B::Pseudoreg->new( "double", "rnv" ); 1901 my $right = B::Pseudoreg->new( "NV", "rnv" );
1902 my $left = B::Pseudoreg->new( "double", "lnv" ); 1902 my $left = B::Pseudoreg->new( "NV", "lnv" );
1903 runtime( 1903 runtime(
1904 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1904 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1905 pop_numeric(), pop_numeric(), $op->name ) ); 1905 pop_numeric(), pop_numeric(), $op->name ) );
1906 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) ); 1906 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
1907 $bool->set_numeric( &$operator( $$left, $$right ) ); 1907 $bool->set_numeric( &$operator( $$left, $$right ) );
1908 push( @stack, $bool ); 1908 push( @stack, $bool );
1909 return $op->next; 1909 return $op->next;
1910 } 1910 }
1911 1911
1912 # coverage: ? 1912 # coverage: ?
1913 sub bool_sv_binop { 1913 sub bool_sv_binop {
1914 my ( $op, $operator ) = @_; 1914 my ( $op, $operator ) = @_;
1915 runtime( sprintf( "right = %s; left = %s;\t/* %s */", 1915 runtime( sprintf( "right = %s; left = %s;\t/* %s */",
1916 pop_sv(), pop_sv(), $op->name ) ); 1916 pop_sv(), pop_sv(), $op->name ) );
1917 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) ); 1917 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
1918 $bool->set_numeric( &$operator( "left", "right" ) ); 1918 $bool->set_numeric( &$operator( "left", "right" ) );
1919 push( @stack, $bool ); 1919 push( @stack, $bool );
1920 return $op->next; 1920 return $op->next;
1921 } 1921 }
1922 1922
1923 # coverage: ? 1923 # coverage: ?
1924 sub infix_op { 1924 sub infix_op {
1925 my $opname = shift; 1925 my $opname = shift;
1926 return sub { "$_[0] $opname $_[1]" } 1926 return sub { "$_[0] $opname $_[1]" }
1927 } 1927 }
1928 1928
1929 # coverage: ? 1929 # coverage: ?
1930 sub prefix_op { 1930 sub prefix_op {
1931 my $opname = shift; 1931 my $opname = shift;
1932 return sub { sprintf( "%s(%s)", $opname, join( ", ", @_ ) ) } 1932 return sub { sprintf( "%s(%s)", $opname, join( ", ", @_ ) ) }
1933 } 1933 }
1934 1934
1935 BEGIN { 1935 BEGIN {
1936 my $plus_op = infix_op("+"); 1936 my $plus_op = infix_op("+");
1937 my $minus_op = infix_op("-"); 1937 my $minus_op = infix_op("-");
1938 my $multiply_op = infix_op("*"); 1938 my $multiply_op = infix_op("*");
1939 my $divide_op = infix_op("/"); 1939 my $divide_op = infix_op("/");
1940 my $modulo_op = infix_op("%"); 1940 my $modulo_op = infix_op("%");
1941 my $lshift_op = infix_op("<<"); 1941 my $lshift_op = infix_op("<<");
1942 my $rshift_op = infix_op(">>"); 1942 my $rshift_op = infix_op(">>");
1943 my $scmp_op = prefix_op("sv_cmp"); 1943 my $scmp_op = prefix_op("sv_cmp");
1944 my $seq_op = prefix_op("sv_eq"); 1944 my $seq_op = prefix_op("sv_eq");
1945 my $sne_op = prefix_op("!sv_eq"); 1945 my $sne_op = prefix_op("!sv_eq");
1946 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; 1946 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
1947 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; 1947 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
1948 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; 1948 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
1949 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; 1949 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
1950 my $eq_op = infix_op("=="); 1950 my $eq_op = infix_op("==");
1951 my $ne_op = infix_op("!="); 1951 my $ne_op = infix_op("!=");
1952 my $lt_op = infix_op("<"); 1952 my $lt_op = infix_op("<");
1953 my $gt_op = infix_op(">"); 1953 my $gt_op = infix_op(">");
1954 my $le_op = infix_op("<="); 1954 my $le_op = infix_op("<=");
1955 my $ge_op = infix_op(">="); 1955 my $ge_op = infix_op(">=");
1956 1956
1957 # 1957 #
1958 # XXX The standard perl PP code has extra handling for 1958 # XXX The standard perl PP code has extra handling for
1959 # some special case arguments of these operators. 1959 # some special case arguments of these operators.
1960 # 1960 #
1961 sub pp_add { numeric_binop( $_[0], $plus_op ) } 1961 sub pp_add { numeric_binop( $_[0], $plus_op ) }
1962 sub pp_subtract { numeric_binop( $_[0], $minus_op ) } 1962 sub pp_subtract { numeric_binop( $_[0], $minus_op ) }
1963 sub pp_multiply { numeric_binop( $_[0], $multiply_op ) } 1963 sub pp_multiply { numeric_binop( $_[0], $multiply_op ) }
1964 sub pp_divide { numeric_binop( $_[0], $divide_op ) } 1964 sub pp_divide { numeric_binop( $_[0], $divide_op ) }
1965 1965
1966 sub pp_modulo { int_binop( $_[0], $modulo_op ) } # differs from perl's 1966 sub pp_modulo { int_binop( $_[0], $modulo_op ) } # differs from perl's
1967 # http://perldoc.perl.org/perlop.html#Shift-Operators: 1967 # http://perldoc.perl.org/perlop.html#Shift-Operators:
1968 # If use integer is in force then signed C integers are used, 1968 # If use integer is in force then signed C integers are used,
1969 # else unsigned C integers are used. 1969 # else unsigned C integers are used.
1970 sub pp_left_shift { int_binop( $_[0], $lshift_op, VALID_UNSIGNED ) } 1970 sub pp_left_shift { int_binop( $_[0], $lshift_op, VALID_UNSIGNED ) }
1971 sub pp_right_shift { int_binop( $_[0], $rshift_op, VALID_UNSIGNED ) } 1971 sub pp_right_shift { int_binop( $_[0], $rshift_op, VALID_UNSIGNED ) }
1972 sub pp_i_add { int_binop( $_[0], $plus_op ) } 1972 sub pp_i_add { int_binop( $_[0], $plus_op ) }
1973 sub pp_i_subtract { int_binop( $_[0], $minus_op ) } 1973 sub pp_i_subtract { int_binop( $_[0], $minus_op ) }
1974 sub pp_i_multiply { int_binop( $_[0], $multiply_op ) } 1974 sub pp_i_multiply { int_binop( $_[0], $multiply_op ) }
1975 sub pp_i_divide { int_binop( $_[0], $divide_op ) } 1975 sub pp_i_divide { int_binop( $_[0], $divide_op ) }
1976 sub pp_i_modulo { int_binop( $_[0], $modulo_op ) } 1976 sub pp_i_modulo { int_binop( $_[0], $modulo_op ) }
1977 1977
1978 sub pp_eq { bool_numeric_binop( $_[0], $eq_op ) } 1978 sub pp_eq { bool_numeric_binop( $_[0], $eq_op ) }
1979 sub pp_ne { bool_numeric_binop( $_[0], $ne_op ) } 1979 sub pp_ne { bool_numeric_binop( $_[0], $ne_op ) }
1980 # coverage: 21 1980 # coverage: 21
1981 sub pp_lt { bool_numeric_binop( $_[0], $lt_op ) } 1981 sub pp_lt { bool_numeric_binop( $_[0], $lt_op ) }
1982 # coverage: 28 1982 # coverage: 28
1983 sub pp_gt { bool_numeric_binop( $_[0], $gt_op ) } 1983 sub pp_gt { bool_numeric_binop( $_[0], $gt_op ) }
1984 sub pp_le { bool_numeric_binop( $_[0], $le_op ) } 1984 sub pp_le { bool_numeric_binop( $_[0], $le_op ) }
1985 sub pp_ge { bool_numeric_binop( $_[0], $ge_op ) } 1985 sub pp_ge { bool_numeric_binop( $_[0], $ge_op ) }
1986 1986
1987 sub pp_i_eq { bool_int_binop( $_[0], $eq_op ) } 1987 sub pp_i_eq { bool_int_binop( $_[0], $eq_op ) }
1988 sub pp_i_ne { bool_int_binop( $_[0], $ne_op ) } 1988 sub pp_i_ne { bool_int_binop( $_[0], $ne_op ) }
1989 sub pp_i_lt { bool_int_binop( $_[0], $lt_op ) } 1989 sub pp_i_lt { bool_int_binop( $_[0], $lt_op ) }
1990 sub pp_i_gt { bool_int_binop( $_[0], $gt_op ) } 1990 sub pp_i_gt { bool_int_binop( $_[0], $gt_op ) }
1991 sub pp_i_le { bool_int_binop( $_[0], $le_op ) } 1991 sub pp_i_le { bool_int_binop( $_[0], $le_op ) }
1992 sub pp_i_ge { bool_int_binop( $_[0], $ge_op ) } 1992 sub pp_i_ge { bool_int_binop( $_[0], $ge_op ) }
1993 1993
1994 sub pp_scmp { sv_binop( $_[0], $scmp_op, INT_RESULT ) } 1994 sub pp_scmp { sv_binop( $_[0], $scmp_op, INT_RESULT ) }
1995 sub pp_slt { bool_sv_binop( $_[0], $slt_op ) } 1995 sub pp_slt { bool_sv_binop( $_[0], $slt_op ) }
1996 sub pp_sgt { bool_sv_binop( $_[0], $sgt_op ) } 1996 sub pp_sgt { bool_sv_binop( $_[0], $sgt_op ) }
1997 sub pp_sle { bool_sv_binop( $_[0], $sle_op ) } 1997 sub pp_sle { bool_sv_binop( $_[0], $sle_op ) }
1998 sub pp_sge { bool_sv_binop( $_[0], $sge_op ) } 1998 sub pp_sge { bool_sv_binop( $_[0], $sge_op ) }
1999 sub pp_seq { bool_sv_binop( $_[0], $seq_op ) } 1999 sub pp_seq { bool_sv_binop( $_[0], $seq_op ) }
2000 sub pp_sne { bool_sv_binop( $_[0], $sne_op ) } 2000 sub pp_sne { bool_sv_binop( $_[0], $sne_op ) }
2001 } 2001 }
2002 2002
2003 # coverage: 3,4,9,10,11,12,17,18,20,21,23 2003 # coverage: 3,4,9,10,11,12,17,18,20,21,23
2004 sub pp_sassign { 2004 sub pp_sassign {
2005 my $op = shift; 2005 my $op = shift;
2006 my $backwards = $op->private & OPpASSIGN_BACKWARDS; 2006 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
2007 debug( sprintf( "sassign->private=0x%x\n", $op->private ) ) if $debug{op}; 2007 debug( sprintf( "sassign->private=0x%x\n", $op->private ) ) if $debug{op};
2008 my ( $dst, $src ); 2008 my ( $dst, $src );
2009 runtime("/* pp_sassign */") if $verbose; 2009 runtime("/* pp_sassign */") if $verbose;
2010 if ( @stack >= 2 ) { 2010 if ( @stack >= 2 ) {
2011 $dst = pop @stack; 2011 $dst = pop @stack;
2012 $src = pop @stack; 2012 $src = pop @stack;
2013 ( $src, $dst ) = ( $dst, $src ) if $backwards; 2013 ( $src, $dst ) = ( $dst, $src ) if $backwards;
2014 my $type = $src->{type}; 2014 my $type = $src->{type};
2015 if ( $type == T_INT ) { 2015 if ( $type == T_INT ) {
2016 $dst->set_int( $src->as_int, $src->{flags} & VALID_UNSIGNED ); 2016 $dst->set_int( $src->as_int, $src->{flags} & VALID_UNSIGNED );
2017 } 2017 }
2018 elsif ( $type == T_DOUBLE ) { 2018 elsif ( $type == T_DOUBLE ) {
2019 $dst->set_numeric( $src->as_numeric ); 2019 $dst->set_numeric( $src->as_numeric );
2020 } 2020 }
2021 else { 2021 else {
2022 $dst->set_sv( $src->as_sv ); 2022 $dst->set_sv( $src->as_sv );
2023 } 2023 }
2024 push( @stack, $dst ); 2024 push( @stack, $dst );
2025 } 2025 }
2026 elsif ( @stack == 1 ) { 2026 elsif ( @stack == 1 ) {
2027 if ($backwards) { 2027 if ($backwards) {
2028 my $src = pop @stack; 2028 my $src = pop @stack;
2029 my $type = $src->{type}; 2029 my $type = $src->{type};
2030 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); 2030 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
2031 if ( $type == T_INT ) { 2031 if ( $type == T_INT ) {
2032 if ( $src->{flags} & VALID_UNSIGNED ) { 2032 if ( $src->{flags} & VALID_UNSIGNED ) {
2033 runtime sprintf( "sv_setuv(TOPs, %s);", $src->as_int ); 2033 runtime sprintf( "sv_setuv(TOPs, %s);", $src->as_int );
2034 } 2034 }
2035 else { 2035 else {
2036 runtime sprintf( "sv_setiv(TOPs, %s);", $src->as_int ); 2036 runtime sprintf( "sv_setiv(TOPs, %s);", $src->as_int );
2037 } 2037 }
2038 } 2038 }
2039 elsif ( $type == T_DOUBLE ) { 2039 elsif ( $type == T_DOUBLE ) {
2040 runtime sprintf( "sv_setnv(TOPs, %s);", $src->as_double ); 2040 runtime sprintf( "sv_setnv(TOPs, %s);", $src->as_double );
2041 } 2041 }
2042 else { 2042 else {
2043 runtime sprintf( "sv_setsv(TOPs, %s);", $src->as_sv ); 2043 runtime sprintf( "sv_setsv(TOPs, %s);", $src->as_sv );
2044 } 2044 }
2045 runtime("SvSETMAGIC(TOPs);"); 2045 runtime("SvSETMAGIC(TOPs);");
2046 } 2046 }
2047 else { 2047 else {
2048 my $dst = $stack[-1]; 2048 my $dst = $stack[-1];
2049 my $type = $dst->{type}; 2049 my $type = $dst->{type};
2050 runtime("sv = POPs;"); 2050 runtime("sv = POPs;");
2051 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); 2051 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
2052 if ( $type == T_INT ) { 2052 if ( $type == T_INT ) {
2053 $dst->set_int("SvIV(sv)"); 2053 $dst->set_int("SvIV(sv)");
2054 } 2054 }
2055 elsif ( $type == T_DOUBLE ) { 2055 elsif ( $type == T_DOUBLE ) {
2056 $dst->set_double("SvNV(sv)"); 2056 $dst->set_double("SvNV(sv)");
2057 } 2057 }
2058 else { 2058 else {
2059 runtime("SvSetMagicSV($dst->{sv}, sv);"); 2059 runtime("SvSetMagicSV($dst->{sv}, sv);");
2060 $dst->invalidate; 2060 $dst->invalidate;
2061 } 2061 }
2062 } 2062 }
2063 } 2063 }
2064 else { 2064 else {
2065 # empty perl stack, both at run-time 2065 # empty perl stack, both at run-time
2066 if ($backwards) { 2066 if ($backwards) {
2067 runtime("src = POPs; dst = TOPs;"); 2067 runtime("src = POPs; dst = TOPs;");
2068 } 2068 }
2069 else { 2069 else {
2070 runtime("dst = POPs; src = TOPs;"); 2070 runtime("dst = POPs; src = TOPs;");
2071 } 2071 }
2072 runtime( 2072 runtime(
2073 "MAYBE_TAINT_SASSIGN_SRC(src);", "SvSetSV(dst, src);", 2073 "MAYBE_TAINT_SASSIGN_SRC(src);", "SvSetSV(dst, src);",
2074 "SvSETMAGIC(dst);", "SETs(dst);" 2074 "SvSETMAGIC(dst);", "SETs(dst);"
2075 ); 2075 );
2076 } 2076 }
2077 return $op->next; 2077 return $op->next;
2078 } 2078 }
2079 2079
2080 # coverage: ny 2080 # coverage: ny
2081 sub pp_preinc { 2081 sub pp_preinc {
2082 my $op = shift; 2082 my $op = shift;
2083 if ( @stack >= 1 ) { 2083 if ( @stack >= 1 ) {
2084 my $obj = $stack[-1]; 2084 my $obj = $stack[-1];
2085 my $type = $obj->{type}; 2085 my $type = $obj->{type};
2086 if ( $type == T_INT || $type == T_DOUBLE ) { 2086 if ( $type == T_INT || $type == T_DOUBLE ) {
2087 $obj->set_int( $obj->as_int . " + 1" ); 2087 $obj->set_int( $obj->as_int . " + 1" );
2088 } 2088 }
2089 else { 2089 else {
2090 runtime sprintf( "PP_PREINC(%s);", $obj->as_sv ); 2090 runtime sprintf( "PP_PREINC(%s);", $obj->as_sv );
2091 $obj->invalidate(); 2091 $obj->invalidate();
2092 } 2092 }
2093 } 2093 }
2094 else { 2094 else {
2095 runtime sprintf("PP_PREINC(TOPs);"); 2095 runtime sprintf("PP_PREINC(TOPs);");
2096 } 2096 }
2097 return $op->next; 2097 return $op->next;
2098 } 2098 }
2099 2099
2100 # coverage: 1-32,35 2100 # coverage: 1-32,35
2101 sub pp_pushmark { 2101 sub pp_pushmark {
2102 my $op = shift; 2102 my $op = shift;
2103 # runtime(sprintf("/* %s */", $op->name)) if $verbose; 2103 # runtime(sprintf("/* %s */", $op->name)) if $verbose;
2104 write_back_stack(); 2104 write_back_stack();
2105 runtime("PUSHMARK(sp);"); 2105 runtime("PUSHMARK(sp);");
2106 return $op->next; 2106 return $op->next;
2107 } 2107 }
2108 2108
2109 # coverage: 28 2109 # coverage: 28
2110 sub pp_list { 2110 sub pp_list {
2111 my $op = shift; 2111 my $op = shift;
2112 runtime(sprintf("/* %s */", $op->name)) if $verbose; 2112 runtime(sprintf("/* %s */", $op->name)) if $verbose;
2113 write_back_stack(); 2113 write_back_stack();
2114 my $gimme = gimme($op); 2114 my $gimme = gimme($op);
2115 if ( not defined $gimme ) { 2115 if ( not defined $gimme ) {
2116 runtime("PP_LIST(block_gimme());"); 2116 runtime("PP_LIST(block_gimme());");
2117 } elsif ( $gimme == G_ARRAY ) { # sic 2117 } elsif ( $gimme == G_ARRAY ) { # sic
2118 runtime("POPMARK;"); # need this even though not a "full" pp_list 2118 runtime("POPMARK;"); # need this even though not a "full" pp_list
2119 } 2119 }
2120 else { 2120 else {
2121 runtime("PP_LIST($gimme);"); 2121 runtime("PP_LIST($gimme);");
2122 } 2122 }
2123 return $op->next; 2123 return $op->next;
2124 } 2124 }
2125 2125
2126 # coverage: 6,8,9,10,24,26,27,31,35 2126 # coverage: 6,8,9,10,24,26,27,31,35
2127 sub pp_entersub { 2127 sub pp_entersub {
2128 my $op = shift; 2128 my $op = shift;
2129 runtime(sprintf("/* %s */", $op->name)) if $verbose; 2129 runtime(sprintf("/* %s */", $op->name)) if $verbose;
2130 $curcop->write_back if $curcop; 2130 $curcop->write_back if $curcop;
2131 write_back_lexicals( REGISTER | TEMPORARY ); 2131 write_back_lexicals( REGISTER | TEMPORARY );
2132 write_back_stack(); 2132 write_back_stack();
2133 my $sym = doop($op); 2133 my $sym = doop($op);
2134 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){", 2134 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){",
2135 "\tPL_op = (*PL_op->op_ppaddr)(aTHX);", 2135 "\tPL_op = (*PL_op->op_ppaddr)(aTHX);",
2136 "\tSPAGAIN;}"); 2136 "\tSPAGAIN;}");
2137 $know_op = 0; 2137 $know_op = 0;
2138 invalidate_lexicals( REGISTER | TEMPORARY ); 2138 invalidate_lexicals( REGISTER | TEMPORARY );
2139 B::C::check_entersub($op); 2139 B::C::check_entersub($op);
2140 return $op->next; 2140 return $op->next;
2141 } 2141 }
2142 2142
2143 # coverage: 16,26,35,51,72,73 2143 # coverage: 16,26,35,51,72,73
2144 sub pp_bless { 2144 sub pp_bless {
2145 my $op = shift; 2145 my $op = shift;
2146 $curcop->write_back if $curcop; 2146 $curcop->write_back if $curcop;
2147 B::C::check_bless($op); 2147 B::C::check_bless($op);
2148 default_pp($op); 2148 default_pp($op);
2149 } 2149 }
2150 2150
2151 2151
2152 # coverage: ny 2152 # coverage: ny
2153 sub pp_formline { 2153 sub pp_formline {
2154 my $op = shift; 2154 my $op = shift;
2155 my $ppname = "pp_" . $op->name; 2155 my $ppname = "pp_" . $op->name;
2156 runtime(sprintf("/* %s */", $ppname)) if $verbose; 2156 runtime(sprintf("/* %s */", $ppname)) if $verbose;
2157 write_back_lexicals() unless $skip_lexicals{$ppname}; 2157 write_back_lexicals() unless $skip_lexicals{$ppname};
2158 write_back_stack() unless $skip_stack{$ppname}; 2158 write_back_stack() unless $skip_stack{$ppname};
2159 my $sym = doop($op); 2159 my $sym = doop($op);
2160 2160
2161 # See comment in pp_grepwhile to see why! 2161 # See comment in pp_grepwhile to see why!
2162 $init->add("((LISTOP*)$sym)->op_first = $sym;"); 2162 $init->add("((LISTOP*)$sym)->op_first = $sym;");
2163 runtime("if (PL_op == ((LISTOP*)($sym))->op_first) {"); 2163 runtime("if (PL_op == ((LISTOP*)($sym))->op_first) {");
2164 save_or_restore_lexical_state( ${ $op->first } ); 2164 save_or_restore_lexical_state( ${ $op->first } );
2165 runtime( sprintf( "goto %s;", label( $op->first ) ), 2165 runtime( sprintf( "goto %s;", label( $op->first ) ),
2166 "}"); 2166 "}");
2167 return $op->next; 2167 return $op->next;
2168 } 2168 }
2169 2169
2170 # coverage: 2,17,21,28,30 2170 # coverage: 2,17,21,28,30
2171 sub pp_goto { 2171 sub pp_goto {
2172 my $op = shift; 2172 my $op = shift;
2173 my $ppname = "pp_" . $op->name; 2173 my $ppname = "pp_" . $op->name;
2174 runtime(sprintf("/* %s */", $ppname)) if $verbose; 2174 runtime(sprintf("/* %s */", $ppname)) if $verbose;
2175 write_back_lexicals() unless $skip_lexicals{$ppname}; 2175 write_back_lexicals() unless $skip_lexicals{$ppname};
2176 write_back_stack() unless $skip_stack{$ppname}; 2176 write_back_stack() unless $skip_stack{$ppname};
2177 my $sym = doop($op); 2177 my $sym = doop($op);
2178 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}"); 2178 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
2179 invalidate_lexicals() unless $skip_invalidate{$ppname}; 2179 invalidate_lexicals() unless $skip_invalidate{$ppname};
2180 return $op->next; 2180 return $op->next;
2181 } 2181 }
2182 2182
2183 # coverage: 1-39, c_argv.t 2 2183 # coverage: 1-39, c_argv.t 2
2184 sub pp_enter { 2184 sub pp_enter {
2185 # XXX fails with simple c_argv.t 2. no cxix. Disabled for now 2185 # XXX fails with simple c_argv.t 2. no cxix. Disabled for now
2186 if (0 and $inline_ops) { 2186 if (0 and $inline_ops) {
2187 my $op = shift; 2187 my $op = shift;
2188 runtime(sprintf("/* %s */", $op->name)) if $verbose; 2188 runtime(sprintf("/* %s */", $op->name)) if $verbose;
2189 warn "inlining enter\n" if $debug{op}; 2189 warn "inlining enter\n" if $debug{op};
2190 $curcop->write_back if $curcop; 2190 $curcop->write_back if $curcop;
2191 if (!($op->flags & OPf_WANT)) { 2191 if (!($op->flags & OPf_WANT)) {
2192 my $cxix = $#cxstack; 2192 my $cxix = $#cxstack;
2193 if ( $cxix >= 0 ) { 2193 if ( $cxix >= 0 ) {
2194 if ( $op->flags & OPf_SPECIAL ) { 2194 if ( $op->flags & OPf_SPECIAL ) {
2195 runtime "gimme = block_gimme();"; 2195 runtime "gimme = block_gimme();";
2196 } else { 2196 } else {
2197 runtime "gimme = cxstack[cxstack_ix].blk_gimme;"; 2197 runtime "gimme = cxstack[cxstack_ix].blk_gimme;";
2198 } 2198 }
2199 } else { 2199 } else {
2200 runtime "gimme = G_SCALAR;"; 2200 runtime "gimme = G_SCALAR;";
2201 } 2201 }
2202 } else { 2202 } else {
2203 runtime "gimme = OP_GIMME(PL_op, -1);"; 2203 runtime "gimme = OP_GIMME(PL_op, -1);";
2204 } 2204 }
2205 runtime($] >= 5.011001 and $] < 5.011004 2205 runtime($] >= 5.011001 and $] < 5.011004
2206 ? 'ENTER_with_name("block");' : 'ENTER;', 2206 ? 'ENTER_with_name("block");' : 'ENTER;',
2207 "SAVETMPS;", 2207 "SAVETMPS;",
2208 "PUSHBLOCK(cx, CXt_BLOCK, SP);"); 2208 "PUSHBLOCK(cx, CXt_BLOCK, SP);");
2209 return $op->next; 2209 return $op->next;
2210 } else { 2210 } else {
2211 return default_pp(@_); 2211 return default_pp(@_);
2212 } 2212 }
2213 } 2213 }
2214 2214
2215 # coverage: ny 2215 # coverage: ny
2216 sub pp_enterwrite { pp_entersub(@_) } 2216 sub pp_enterwrite { pp_entersub(@_) }
2217 2217
2218 # coverage: 6,8,9,10,24,26,27,31 2218 # coverage: 6,8,9,10,24,26,27,31
2219 sub pp_leavesub { 2219 sub pp_leavesub {
2220 my $op = shift; 2220 my $op = shift;
2221 my $ppname = "pp_" . $op->name; 2221 my $ppname = "pp_" . $op->name;
2222 write_back_lexicals() unless $skip_lexicals{$ppname}; 2222 write_back_lexicals() unless $skip_lexicals{$ppname};
2223 write_back_stack() unless $skip_stack{$ppname}; 2223 write_back_stack() unless $skip_stack{$ppname};
2224 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){", 2224 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){",
2225 "\tPUTBACK;return 0;", 2225 "\tPUTBACK;return 0;",
2226 "}"); 2226 "}");
2227 doop($op); 2227 doop($op);
2228 return $op->next; 2228 return $op->next;
2229 } 2229 }
2230 2230
2231 # coverage: ny 2231 # coverage: ny
2232 sub pp_leavewrite { 2232 sub pp_leavewrite {
2233 my $op = shift; 2233 my $op = shift;
2234 write_back_lexicals( REGISTER | TEMPORARY ); 2234 write_back_lexicals( REGISTER | TEMPORARY );
2235 write_back_stack(); 2235 write_back_stack();
2236 my $sym = doop($op); 2236 my $sym = doop($op);
2237 2237
2238 # XXX Is this the right way to distinguish between it returning 2238 # XXX Is this the right way to distinguish between it returning
2239 # CvSTART(cv) (via doform) and pop_return()? 2239 # CvSTART(cv) (via doform) and pop_return()?
2240 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); 2240 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
2241 runtime("SPAGAIN;"); 2241 runtime("SPAGAIN;");
2242 $know_op = 0; 2242 $know_op = 0;
2243 invalidate_lexicals( REGISTER | TEMPORARY ); 2243 invalidate_lexicals( REGISTER | TEMPORARY );
2244 return $op->next; 2244 return $op->next;
2245 } 2245 }
2246 2246
2247 # coverage: ny 2247 # coverage: ny
2248 sub pp_entergiven { pp_enterwrite(@_) } 2248 sub pp_entergiven { pp_enterwrite(@_) }
2249 # coverage: ny 2249 # coverage: ny
2250 sub pp_leavegiven { pp_leavewrite(@_) } 2250 sub pp_leavegiven { pp_leavewrite(@_) }
2251 2251
2252 sub doeval { 2252 sub doeval {
2253 my $op = shift; 2253 my $op = shift;
2254 $curcop->write_back; 2254 $curcop->write_back;
2255 write_back_lexicals( REGISTER | TEMPORARY ); 2255 write_back_lexicals( REGISTER | TEMPORARY );
2256 write_back_stack(); 2256 write_back_stack();
2257 my $sym = loadop($op); 2257 my $sym = loadop($op);
2258 my $ppaddr = $op->ppaddr; 2258 my $ppaddr = $op->ppaddr;
2259 runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); 2259 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
2260 $know_op = 1; 2260 $know_op = 1;
2261 invalidate_lexicals( REGISTER | TEMPORARY ); 2261 invalidate_lexicals( REGISTER | TEMPORARY );
2262 return $op->next; 2262 return $op->next;
2263 } 2263 }
2264 2264
2265 # coverage: 12 2265 # coverage: 12
2266 sub pp_entereval { doeval(@_) } 2266 sub pp_entereval { doeval(@_) }
2267 # coverage: ny 2267 # coverage: ny
2268 sub pp_dofile { doeval(@_) } 2268 sub pp_dofile { doeval(@_) }
2269 2269
2270 # coverage: 28 2270 # coverage: 28
2271 #pp_require is protected by pp_entertry, so no protection for it. 2271 #pp_require is protected by pp_entertry, so no protection for it.
2272 sub pp_require { 2272 sub pp_require {
2273 my $op = shift; 2273 my $op = shift;
2274 $curcop->write_back; 2274 $curcop->write_back;
2275 write_back_lexicals( REGISTER | TEMPORARY ); 2275 write_back_lexicals( REGISTER | TEMPORARY );
2276 write_back_stack(); 2276 write_back_stack();
2277 my $sym = doop($op); 2277 my $sym = doop($op);
2278 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ) {", 2278 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ) {",
2279 #(test 28). 2279 #(test 28).
2280 " PL_op = (*PL_op->op_ppaddr)(aTHX);", 2280 " PL_op = (*PL_op->op_ppaddr)(aTHX);",
2281 " SPAGAIN;", 2281 " SPAGAIN;",
2282 "}"); 2282 "}");
2283 $know_op = 1; 2283 $know_op = 1;
2284 invalidate_lexicals( REGISTER | TEMPORARY ); 2284 invalidate_lexicals( REGISTER | TEMPORARY );
2285 B::C::check_require($op); # mark package 2285 B::C::check_require($op); # mark package
2286 return $op->next; 2286 return $op->next;
2287 } 2287 }
2288 2288
2289 # coverage: 32 2289 # coverage: 32
2290 sub pp_entertry { 2290 sub pp_entertry {
2291 my $op = shift; 2291 my $op = shift;
2292 $curcop->write_back; 2292 $curcop->write_back;
2293 write_back_lexicals( REGISTER | TEMPORARY ); 2293 write_back_lexicals( REGISTER | TEMPORARY );
2294 write_back_stack(); 2294 write_back_stack();
2295 my $sym = doop($op); 2295 my $sym = doop($op);
2296 $entertry_defined = 1; 2296 $entertry_defined = 1;
2297 my $next = $op->next; # broken in 5.12, fixed in B::C by upgrading BASEOP 2297 my $next = $op->next; # broken in 5.12, fixed in B::C by upgrading BASEOP
2298 # jump past leavetry 2298 # jump past leavetry
2299 $next = $op->other->next if $op->can("other"); # before 5.11.4 and after 5.13.8 2299 $next = $op->other->next if $op->can("other"); # before 5.11.4 and after 5.13.8
2300 my $l = label( $next ); 2300 my $l = label( $next );
2301 debug "ENTERTRY label=$l (".ref($op).") ->".$next->name."(".ref($next).")\n"; 2301 debug "ENTERTRY label=$l (".ref($op).") ->".$next->name."(".ref($next).")\n";
2302 runtime(sprintf( "PP_ENTERTRY(%s);", $l)); 2302 runtime(sprintf( "PP_ENTERTRY(%s);", $l));
2303 if ($next->isa('B::COP')) { 2303 if ($next->isa('B::COP')) {
2304 push_label($next, 'nextstate'); 2304 push_label($next, 'nextstate');
2305 } else { 2305 } else {
2306 push_label($op->other, 'leavetry') if $op->can("other"); 2306 push_label($op->other, 'leavetry') if $op->can("other");
2307 } 2307 }
2308 invalidate_lexicals( REGISTER | TEMPORARY ); 2308 invalidate_lexicals( REGISTER | TEMPORARY );
2309 return $op->next; 2309 return $op->next;
2310 } 2310 }
2311 2311
2312 # coverage: 32 2312 # coverage: 32
2313 sub pp_leavetry { 2313 sub pp_leavetry {
2314 my $op = shift; 2314 my $op = shift;
2315 pop_label 'leavetry' if $labels->{'leavetry'}->[-1] and $labels->{'leavetry'}->[-1] == $op; 2315 pop_label 'leavetry' if $labels->{'leavetry'}->[-1] and $labels->{'leavetry'}->[-1] == $op;
2316 default_pp($op); 2316 default_pp($op);
2317 runtime("PP_LEAVETRY;"); 2317 runtime("PP_LEAVETRY;");
2318 write_label($op->next); 2318 write_label($op->next);
2319 return $op->next; 2319 return $op->next;
2320 } 2320 }
2321 2321
2322 # coverage: ny 2322 # coverage: ny
2323 sub pp_grepstart { 2323 sub pp_grepstart {
2324 my $op = shift; 2324 my $op = shift;
2325 if ( $need_freetmps && $freetmps_each_loop ) { 2325 if ( $need_freetmps && $freetmps_each_loop ) {
2326 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up 2326 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
2327 $need_freetmps = 0; 2327 $need_freetmps = 0;
2328 } 2328 }
2329 write_back_stack(); 2329 write_back_stack();
2330 my $sym = doop($op); 2330 my $sym = doop($op);
2331 my $next = $op->next; 2331 my $next = $op->next;
2332 $next->save; 2332 $next->save;
2333 my $nexttonext = $next->next; 2333 my $nexttonext = $next->next;
2334 $nexttonext->save; 2334 $nexttonext->save;
2335 save_or_restore_lexical_state($$nexttonext); 2335 save_or_restore_lexical_state($$nexttonext);
2336 runtime( 2336 runtime(
2337 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;", 2337 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;",
2338 label($nexttonext) ) 2338 label($nexttonext) )
2339 ); 2339 );
2340 return $op->next->other; 2340 return $op->next->other;
2341 } 2341 }
2342 2342
2343 # coverage: ny 2343 # coverage: ny
2344 sub pp_mapstart { 2344 sub pp_mapstart {
2345 my $op = shift; 2345 my $op = shift;
2346 if ( $need_freetmps && $freetmps_each_loop ) { 2346 if ( $need_freetmps && $freetmps_each_loop ) {
2347 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up 2347 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
2348 $need_freetmps = 0; 2348 $need_freetmps = 0;
2349 } 2349 }
2350 write_back_stack(); 2350 write_back_stack();
2351 2351
2352 # pp_mapstart can return either op_next->op_next or op_next->op_other and 2352 # pp_mapstart can return either op_next->op_next or op_next->op_other and
2353 # we need to be able to distinguish the two at runtime. 2353 # we need to be able to distinguish the two at runtime.
2354 my $sym = doop($op); 2354 my $sym = doop($op);
2355 my $next = $op->next; 2355 my $next = $op->next;
2356 $next->save; 2356 $next->save;
2357 my $nexttonext = $next->next; 2357 my $nexttonext = $next->next;
2358 $nexttonext->save; 2358 $nexttonext->save;
2359 save_or_restore_lexical_state($$nexttonext); 2359 save_or_restore_lexical_state($$nexttonext);
2360 runtime( 2360 runtime(
2361 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;", 2361 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;",
2362 label($nexttonext) ) 2362 label($nexttonext) )
2363 ); 2363 );
2364 return $op->next->other; 2364 return $op->next->other;
2365 } 2365 }
2366 2366
2367 # coverage: ny 2367 # coverage: ny
2368 sub pp_grepwhile { 2368 sub pp_grepwhile {
2369 my $op = shift; 2369 my $op = shift;
2370 my $next = $op->next; 2370 my $next = $op->next;
2371 unshift( @bblock_todo, $next ); 2371 unshift( @bblock_todo, $next );
2372 write_back_lexicals(); 2372 write_back_lexicals();
2373 write_back_stack(); 2373 write_back_stack();
2374 my $sym = doop($op); 2374 my $sym = doop($op);
2375 2375
2376 # pp_grepwhile can return either op_next or op_other and we need to 2376 # pp_grepwhile can return either op_next or op_other and we need to
2377 # be able to distinguish the two at runtime. Since it's possible for 2377 # be able to distinguish the two at runtime. Since it's possible for
2378 # both ops to be "inlined", the fields could both be zero. To get 2378 # both ops to be "inlined", the fields could both be zero. To get
2379 # around that, we hack op_next to be our own op (purely because we 2379 # around that, we hack op_next to be our own op (purely because we
2380 # know it's a non-NULL pointer and can't be the same as op_other). 2380 # know it's a non-NULL pointer and can't be the same as op_other).
2381 $init->add("((LOGOP*)$sym)->op_next = $sym;"); 2381 $init->add("((LOGOP*)$sym)->op_next = $sym;");
2382 save_or_restore_lexical_state($$next); 2382 save_or_restore_lexical_state($$next);
2383 runtime( sprintf( "if (PL_op == ($sym)->op_next) goto %s;", label($next) ) ); 2383 runtime( sprintf( "if (PL_op == ($sym)->op_next) goto %s;", label($next) ) );
2384 $know_op = 0; 2384 $know_op = 0;
2385 return $op->other; 2385 return $op->other;
2386 } 2386 }
2387 2387
2388 # coverage: ny 2388 # coverage: ny
2389 sub pp_mapwhile { pp_grepwhile(@_) } 2389 sub pp_mapwhile { pp_grepwhile(@_) }
2390 2390
2391 # coverage: 24 2391 # coverage: 24
2392 sub pp_return { 2392 sub pp_return {
2393 my $op = shift; 2393 my $op = shift;
2394 write_back_lexicals( REGISTER | TEMPORARY ); 2394 write_back_lexicals( REGISTER | TEMPORARY );
2395 write_back_stack(); 2395 write_back_stack();
2396 doop($op); 2396 doop($op);
2397 runtime( "PUTBACK;", "return PL_op;" ); 2397 runtime( "PUTBACK;", "return PL_op;" );
2398 $know_op = 0; 2398 $know_op = 0;
2399 return $op->next; 2399 return $op->next;
2400 } 2400 }
2401 2401
2402 sub nyi { 2402 sub nyi {
2403 my $op = shift; 2403 my $op = shift;
2404 warn sprintf( "%s not yet implemented properly\n", $op->ppaddr ); 2404 warn sprintf( "%s not yet implemented properly\n", $op->ppaddr );
2405 return default_pp($op); 2405 return default_pp($op);
2406 } 2406 }
2407 2407
2408 # coverage: 17 2408 # coverage: 17
2409 sub pp_range { 2409 sub pp_range {
2410 my $op = shift; 2410 my $op = shift;
2411 my $flags = $op->flags; 2411 my $flags = $op->flags;
2412 if ( !( $flags & OPf_WANT ) ) { 2412 if ( !( $flags & OPf_WANT ) ) {
2413 if ($strict) { 2413 if ($strict) {
2414 error("context of range unknown at compile-time\n"); 2414 error("context of range unknown at compile-time\n");
2415 } else { 2415 } else {
2416 warn("context of range unknown at compile-time\n"); 2416 warn("context of range unknown at compile-time\n");
2417 runtime('warn("context of range unknown at compile-time");'); 2417 runtime('warn("context of range unknown at compile-time");');
2418 } 2418 }
2419 return default_pp($op); 2419 return default_pp($op);
2420 } 2420 }
2421 write_back_lexicals(); 2421 write_back_lexicals();
2422 write_back_stack(); 2422 write_back_stack();
2423 unless ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) { 2423 unless ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) {
2424 # We need to save our UNOP structure since pp_flop uses 2424 # We need to save our UNOP structure since pp_flop uses
2425 # it to find and adjust out targ. We don't need it ourselves. 2425 # it to find and adjust out targ. We don't need it ourselves.
2426 $op->save; 2426 $op->save;
2427 save_or_restore_lexical_state( ${ $op->other } ); 2427 save_or_restore_lexical_state( ${ $op->other } );
2428 runtime sprintf( "if (SvTRUE(PL_curpad[%d])) goto %s;", 2428 runtime sprintf( "if (SvTRUE(PL_curpad[%d])) goto %s;",
2429 $op->targ, label( $op->other ) ); 2429 $op->targ, label( $op->other ) );
2430 unshift( @bblock_todo, $op->other ); 2430 unshift( @bblock_todo, $op->other );
2431 } 2431 }
2432 return $op->next; 2432 return $op->next;
2433 } 2433 }
2434 2434
2435 # coverage: 17, 30 2435 # coverage: 17, 30
2436 sub pp_flip { 2436 sub pp_flip {
2437 my $op = shift; 2437 my $op = shift;
2438 my $flags = $op->flags; 2438 my $flags = $op->flags;
2439 if ( !( $flags & OPf_WANT ) ) { 2439 if ( !( $flags & OPf_WANT ) ) {
2440 if ($strict) { 2440 if ($strict) {
2441 error("context of flip unknown at compile-time\n"); 2441 error("context of flip unknown at compile-time\n");
2442 } else { 2442 } else {
2443 warn("context of flip unknown at compile-time\n"); 2443 warn("context of flip unknown at compile-time\n");
2444 runtime('warn("context of flip unknown at compile-time");'); 2444 runtime('warn("context of flip unknown at compile-time");');
2445 } 2445 }
2446 return default_pp($op); 2446 return default_pp($op);
2447 } 2447 }
2448 if ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) { 2448 if ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) {
2449 return $op->first->other; 2449 return $op->first->other;
2450 } 2450 }
2451 write_back_lexicals(); 2451 write_back_lexicals();
2452 write_back_stack(); 2452 write_back_stack();
2453 # We need to save our UNOP structure since pp_flop uses 2453 # We need to save our UNOP structure since pp_flop uses
2454 # it to find and adjust out targ. We don't need it ourselves. 2454 # it to find and adjust out targ. We don't need it ourselves.
2455 $op->save; 2455 $op->save;
2456 my $ix = $op->targ; 2456 my $ix = $op->targ;
2457 my $rangeix = $op->first->targ; 2457 my $rangeix = $op->first->targ;
2458 runtime( 2458 runtime(
2459 ( $op->private & OPpFLIP_LINENUM ) 2459 ( $op->private & OPpFLIP_LINENUM )
2460 ? "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {" 2460 ? "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
2461 : "if (SvTRUE(TOPs)) {" 2461 : "if (SvTRUE(TOPs)) {"
2462 ); 2462 );
2463 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);"); 2463 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
2464 if ( $op->flags & OPf_SPECIAL ) { 2464 if ( $op->flags & OPf_SPECIAL ) {
2465 runtime("sv_setiv(PL_curpad[$ix], 1);"); 2465 runtime("sv_setiv(PL_curpad[$ix], 1);");
2466 } 2466 }
2467 else { 2467 else {
2468 save_or_restore_lexical_state( ${ $op->first->other } ); 2468 save_or_restore_lexical_state( ${ $op->first->other } );
2469 runtime( "\tsv_setiv(PL_curpad[$ix], 0);", 2469 runtime( "\tsv_setiv(PL_curpad[$ix], 0);",
2470 "\tsp--;", sprintf( "\tgoto %s;", label( $op->first->other ) ) ); 2470 "\tsp--;", sprintf( "\tgoto %s;", label( $op->first->other ) ) );
2471 } 2471 }
2472 runtime( "}", qq{sv_setpv(PL_curpad[$ix], "");}, "SETs(PL_curpad[$ix]);" ); 2472 runtime( "}", qq{sv_setpv(PL_curpad[$ix], "");}, "SETs(PL_curpad[$ix]);" );
2473 $know_op = 0; 2473 $know_op = 0;
2474 return $op->next; 2474 return $op->next;
2475 } 2475 }
2476 2476
2477 # coverage: 17 2477 # coverage: 17
2478 sub pp_flop { 2478 sub pp_flop {
2479 my $op = shift; 2479 my $op = shift;
2480 default_pp($op); 2480 default_pp($op);
2481 $know_op = 0; 2481 $know_op = 0;
2482 return $op->next; 2482 return $op->next;
2483 } 2483 }
2484 2484
2485 sub enterloop { 2485 sub enterloop {
2486 my $op = shift; 2486 my $op = shift;
2487 my $nextop = $op->nextop; 2487 my $nextop = $op->nextop;
2488 my $lastop = $op->lastop; 2488 my $lastop = $op->lastop;
2489 my $redoop = $op->redoop; 2489 my $redoop = $op->redoop;
2490 $curcop->write_back if $curcop; 2490 $curcop->write_back if $curcop;
2491 debug "enterloop: pushing on cxstack\n" if $debug{cxstack}; 2491 debug "enterloop: pushing on cxstack\n" if $debug{cxstack};
2492 push( 2492 push(
2493 @cxstack, 2493 @cxstack,
2494 { 2494 {
2495 type => $PERL512 ? CXt_LOOP_PLAIN : CXt_LOOP, 2495 type => $PERL512 ? CXt_LOOP_PLAIN : CXt_LOOP,
2496 op => $op, 2496 op => $op,
2497 "label" => $curcop->[0]->label, 2497 "label" => $curcop->[0]->label,
2498 nextop => $nextop, 2498 nextop => $nextop,
2499 lastop => $lastop, 2499 lastop => $lastop,
2500 redoop => $redoop 2500 redoop => $redoop
2501 } 2501 }
2502 ); 2502 );
2503 debug sprintf("enterloop: cxstack label %s\n", $curcop->[0]->label) if $debug{cxstack}; 2503 debug sprintf("enterloop: cxstack label %s\n", $curcop->[0]->label) if $debug{cxstack};
2504 $nextop->save; 2504 $nextop->save;
2505 $lastop->save; 2505 $lastop->save;
2506 $redoop->save; 2506 $redoop->save;
2507 # We need to compile the corresponding pp_leaveloop even if it's 2507 # We need to compile the corresponding pp_leaveloop even if it's
2508 # never executed. This is needed to get @cxstack right. 2508 # never executed. This is needed to get @cxstack right.
2509 # Use case: while(1) { .. } 2509 # Use case: while(1) { .. }
2510 unshift @bblock_todo, ($lastop); 2510 unshift @bblock_todo, ($lastop);
2511 if (0 and $inline_ops and $op->name eq 'enterloop') { 2511 if (0 and $inline_ops and $op->name eq 'enterloop') {
2512 warn "inlining enterloop\n" if $debug{op}; 2512 warn "inlining enterloop\n" if $debug{op};
2513 # XXX = GIMME_V fails on freebsd7 5.8.8 (28) 2513 # XXX = GIMME_V fails on freebsd7 5.8.8 (28)
2514 # = block_gimme() fails on the rest, but passes on freebsd7 2514 # = block_gimme() fails on the rest, but passes on freebsd7
2515 runtime "gimme = GIMME_V;"; # XXX 2515 runtime "gimme = GIMME_V;"; # XXX
2516 if ($PERL512) { 2516 if ($PERL512) {
2517 runtime('ENTER_with_name("loop1");', 2517 runtime('ENTER_with_name("loop1");',
2518 'SAVETMPS;', 2518 'SAVETMPS;',
2519 'ENTER_with_name("loop2");', 2519 'ENTER_with_name("loop2");',
2520 'PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);', 2520 'PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);',
2521 'PUSHLOOP_PLAIN(cx, SP);'); 2521 'PUSHLOOP_PLAIN(cx, SP);');
2522 } else { 2522 } else {
2523 runtime('ENTER;', 2523 runtime('ENTER;',
2524 'SAVETMPS;', 2524 'SAVETMPS;',
2525 'ENTER;', 2525 'ENTER;',
2526 'PUSHBLOCK(cx, CXt_LOOP, SP);', 2526 'PUSHBLOCK(cx, CXt_LOOP, SP);',
2527 'PUSHLOOP(cx, 0, SP);'); 2527 'PUSHLOOP(cx, 0, SP);');
2528 } 2528 }
2529 return $op->next; 2529 return $op->next;
2530 } else { 2530 } else {
2531 return default_pp($op); 2531 return default_pp($op);
2532 } 2532 }
2533 } 2533 }
2534 2534
2535 # coverage: 6,21,28,30 2535 # coverage: 6,21,28,30
2536 sub pp_enterloop { enterloop(@_) } 2536 sub pp_enterloop { enterloop(@_) }
2537 # coverage: 2 2537 # coverage: 2
2538 sub pp_enteriter { enterloop(@_) } 2538 sub pp_enteriter { enterloop(@_) }
2539 2539
2540 # coverage: 6,21,28,30 2540 # coverage: 6,21,28,30
2541 sub pp_leaveloop { 2541 sub pp_leaveloop {
2542 my $op = shift; 2542 my $op = shift;
2543 if ( !@cxstack ) { 2543 if ( !@cxstack ) {
2544 die "panic: leaveloop, no cxstack"; 2544 die "panic: leaveloop, no cxstack";
2545 } 2545 }
2546 debug "leaveloop: popping from cxstack\n" if $debug{cxstack}; 2546 debug "leaveloop: popping from cxstack\n" if $debug{cxstack};
2547 pop(@cxstack); 2547 pop(@cxstack);
2548 return default_pp($op); 2548 return default_pp($op);
2549 } 2549 }
2550 2550
2551 # coverage: ? 2551 # coverage: ?
2552 sub pp_next { 2552 sub pp_next {
2553 my $op = shift; 2553 my $op = shift;
2554 my $cxix; 2554 my $cxix;
2555 if ( $op->flags & OPf_SPECIAL ) { 2555 if ( $op->flags & OPf_SPECIAL ) {
2556 $cxix = dopoptoloop(); 2556 $cxix = dopoptoloop();
2557 if ( $cxix < 0 ) { 2557 if ( $cxix < 0 ) {
2558 warn "Warning: \"next\" used outside loop\n"; 2558 warn "Warning: \"next\" used outside loop\n";
2559 return default_pp($op); # no optimization 2559 return default_pp($op); # no optimization
2560 } 2560 }
2561 } 2561 }
2562 else { 2562 else {
2563 my $label = $op->pv; 2563 my $label = $op->pv;
2564 if ($label) { 2564 if ($label) {
2565 $cxix = dopoptolabel( $label ); 2565 $cxix = dopoptolabel( $label );
2566 if ( $cxix < 0 ) { 2566 if ( $cxix < 0 ) {
2567 # coverage: t/testcc 21 2567 # coverage: t/testcc 21
2568 warn(sprintf("Warning: Label not found at compile time for \"next %s\"\n", $label )); 2568 warn(sprintf("Warning: Label not found at compile time for \"next %s\"\n", $label ));
2569 $labels->{nlabel}->{$label} = $$op; 2569 $labels->{nlabel}->{$label} = $$op;
2570 return $op->next; 2570 return $op->next;
2571 } 2571 }
2572 } 2572 }
2573 # Add support to leave non-loop blocks. 2573 # Add support to leave non-loop blocks.
2574 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 2574 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
2575 if (!$cxstack[$cxix]->{'nextop'} or !$cxstack[$cxix]->{'label'}) { 2575 if (!$cxstack[$cxix]->{'nextop'} or !$cxstack[$cxix]->{'label'}) {
2576 error("Use of \"next\" for non-loop and non-label blocks not yet implemented\n"); 2576 error("Use of \"next\" for non-loop and non-label blocks not yet implemented\n");
2577 } 2577 }
2578 } 2578 }
2579 } 2579 }
2580 default_pp($op); 2580 default_pp($op);
2581 my $nextop = $cxstack[$cxix]->{nextop}; 2581 my $nextop = $cxstack[$cxix]->{nextop};
2582 if ($nextop) { 2582 if ($nextop) {
2583 push( @bblock_todo, $nextop ); 2583 push( @bblock_todo, $nextop );
2584 save_or_restore_lexical_state($$nextop); 2584 save_or_restore_lexical_state($$nextop);
2585 runtime( sprintf( "goto %s;", label($nextop) ) ); 2585 runtime( sprintf( "goto %s;", label($nextop) ) );
2586 } 2586 }
2587 return $op->next; 2587 return $op->next;
2588 } 2588 }
2589 2589
2590 # coverage: ? 2590 # coverage: ?
2591 sub pp_redo { 2591 sub pp_redo {
2592 my $op = shift; 2592 my $op = shift;
2593 my $cxix; 2593 my $cxix;
2594 if ( $op->flags & OPf_SPECIAL ) { 2594 if ( $op->flags & OPf_SPECIAL ) {
2595 $cxix = dopoptoloop(); 2595 $cxix = dopoptoloop();
2596 if ( $cxix < 0 ) { 2596 if ( $cxix < 0 ) {
2597 warn("Warning: \"redo\" used outside loop\n"); 2597 warn("Warning: \"redo\" used outside loop\n");
2598 return default_pp($op); # no optimization 2598 return default_pp($op); # no optimization
2599 } 2599 }
2600 } 2600 }
2601 else { 2601 else {
2602 my $label = $op->pv; 2602 my $label = $op->pv;
2603 if ($label) { 2603 if ($label) {
2604 $cxix = dopoptolabel( $label ); 2604 $cxix = dopoptolabel( $label );
2605 if ( $cxix < 0 ) { 2605 if ( $cxix < 0 ) {
2606 warn(sprintf("Warning: Label not found at compile time for \"redo %s\"\n", $label )); 2606 warn(sprintf("Warning: Label not found at compile time for \"redo %s\"\n", $label ));
2607 $labels->{nlabel}->{$label} = $$op; 2607 $labels->{nlabel}->{$label} = $$op;
2608 return $op->next; 2608 return $op->next;
2609 } 2609 }
2610 } 2610 }
2611 # Add support to leave non-loop blocks. 2611 # Add support to leave non-loop blocks.
2612 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 2612 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
2613 if (!$cxstack[$cxix]->{'redoop'} or !$cxstack[$cxix]->{'label'}) { 2613 if (!$cxstack[$cxix]->{'redoop'} or !$cxstack[$cxix]->{'label'}) {
2614 error("Use of \"redo\" for non-loop and non-label blocks not yet implemented\n"); 2614 error("Use of \"redo\" for non-loop and non-label blocks not yet implemented\n");
2615 } 2615 }
2616 } 2616 }
2617 } 2617 }
2618 default_pp($op); 2618 default_pp($op);
2619 my $redoop = $cxstack[$cxix]->{redoop}; 2619 my $redoop = $cxstack[$cxix]->{redoop};
2620 if ($redoop) { 2620 if ($redoop) {
2621 push( @bblock_todo, $redoop ); 2621 push( @bblock_todo, $redoop );
2622 save_or_restore_lexical_state($$redoop); 2622 save_or_restore_lexical_state($$redoop);
2623 runtime( sprintf( "goto %s;", label($redoop) ) ); 2623 runtime( sprintf( "goto %s;", label($redoop) ) );
2624 } 2624 }
2625 return $op->next; 2625 return $op->next;
2626 } 2626 }
2627 2627
2628 # coverage: issue36, cc_last.t 2628 # coverage: issue36, cc_last.t
2629 sub pp_last { 2629 sub pp_last {
2630 my $op = shift; 2630 my $op = shift;
2631 my $cxix; 2631 my $cxix;
2632 if ( $op->flags & OPf_SPECIAL ) { 2632 if ( $op->flags & OPf_SPECIAL ) {
2633 $cxix = dopoptoloop(); 2633 $cxix = dopoptoloop();
2634 if ( $cxix < 0 ) { 2634 if ( $cxix < 0 ) {
2635 warn("Warning: \"last\" used outside loop\n"); 2635 warn("Warning: \"last\" used outside loop\n");
2636 #return default_pp($op); # no optimization 2636 #return default_pp($op); # no optimization
2637 } 2637 }
2638 } 2638 }
2639 else { 2639 else {
2640 my $label = $op->pv; 2640 my $label = $op->pv;
2641 if ($label) { 2641 if ($label) {
2642 $cxix = dopoptolabel( $label ); 2642 $cxix = dopoptolabel( $label );
2643 if ( $cxix < 0 ) { 2643 if ( $cxix < 0 ) {
2644 # coverage: cc_last.t 2 (ok) 4 (ok) 2644 # coverage: cc_last.t 2 (ok) 4 (ok)
2645 warn( sprintf("Warning: Label not found at compile time for \"last %s\"\n", $label )); 2645 warn( sprintf("Warning: Label not found at compile time for \"last %s\"\n", $label ));
2646 # last does not jump into the future, by name without $$op 2646 # last does not jump into the future, by name without $$op
2647 # instead it should jump to the block afterwards 2647 # instead it should jump to the block afterwards
2648 $labels->{nlabel}->{$label} = $$op; 2648 $labels->{nlabel}->{$label} = $$op;
2649 return $op->next; 2649 return $op->next;
2650 } 2650 }
2651 } 2651 }
2652 2652
2653 # Add support to leave non-loop blocks. label fixed with 1.11 2653 # Add support to leave non-loop blocks. label fixed with 1.11
2654 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 2654 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
2655 if (!$cxstack[$cxix]->{'lastop'} or !$cxstack[$cxix]->{'label'}) { 2655 if (!$cxstack[$cxix]->{'lastop'} or !$cxstack[$cxix]->{'label'}) {
2656 error("Use of \"last\" for non-loop and non-label blocks not yet implemented\n"); 2656 error("Use of \"last\" for non-loop and non-label blocks not yet implemented\n");
2657 } 2657 }
2658 } 2658 }
2659 } 2659 }
2660 default_pp($op); 2660 default_pp($op);
2661 if ($cxstack[$cxix]->{lastop} and $cxstack[$cxix]->{lastop}->next) { 2661 if ($cxstack[$cxix]->{lastop} and $cxstack[$cxix]->{lastop}->next) {
2662 my $lastop = $cxstack[$cxix]->{lastop}->next; 2662 my $lastop = $cxstack[$cxix]->{lastop}->next;
2663 push( @bblock_todo, $lastop ); 2663 push( @bblock_todo, $lastop );
2664 save_or_restore_lexical_state($$lastop); 2664 save_or_restore_lexical_state($$lastop);
2665 runtime( sprintf( "goto %s;", label($lastop) ) ); 2665 runtime( sprintf( "goto %s;", label($lastop) ) );
2666 } 2666 }
2667 return $op->next; 2667 return $op->next;
2668 } 2668 }
2669 2669
2670 # coverage: 3,4 2670 # coverage: 3,4
2671 sub pp_subst { 2671 sub pp_subst {
2672 my $op = shift; 2672 my $op = shift;
2673 write_back_lexicals(); 2673 write_back_lexicals();
2674 write_back_stack(); 2674 write_back_stack();
2675 my $sym = doop($op); 2675 my $sym = doop($op);
2676 my $replroot = $op->pmreplroot; 2676 my $replroot = $op->pmreplroot;
2677 if ($$replroot) { 2677 if ($$replroot) {
2678 save_or_restore_lexical_state($$replroot); 2678 save_or_restore_lexical_state($$replroot);
2679 runtime sprintf( 2679 runtime sprintf(
2680 "if (PL_op == ((PMOP*)(%s))%s) goto %s;", 2680 "if (PL_op == ((PMOP*)(%s))%s) goto %s;",
2681 $sym, $PERL510 ? "->op_pmreplrootu.op_pmreplroot" : "->op_pmreplroot", 2681 $sym, $PERL510 ? "->op_pmreplrootu.op_pmreplroot" : "->op_pmreplroot",
2682 label($replroot) 2682 label($replroot)
2683 ); 2683 );
2684 $op->pmreplstart->save; 2684 $op->pmreplstart->save;
2685 push( @bblock_todo, $replroot ); 2685 push( @bblock_todo, $replroot );
2686 } 2686 }
2687 invalidate_lexicals(); 2687 invalidate_lexicals();
2688 return $op->next; 2688 return $op->next;
2689 } 2689 }
2690 2690
2691 # coverage: 3 2691 # coverage: 3
2692 sub pp_substcont { 2692 sub pp_substcont {
2693 my $op = shift; 2693 my $op = shift;
2694 write_back_lexicals(); 2694 write_back_lexicals();
2695 write_back_stack(); 2695 write_back_stack();
2696 doop($op); 2696 doop($op);
2697 my $pmop = $op->other; 2697 my $pmop = $op->other;
2698 #warn sprintf( "substcont: op = %s, pmop = %s\n", peekop($op), peekop($pmop) ) if $verbose; 2698 #warn sprintf( "substcont: op = %s, pmop = %s\n", peekop($op), peekop($pmop) ) if $verbose;
2699 2699
2700 # my $pmopsym = objsym($pmop); 2700 # my $pmopsym = objsym($pmop);
2701 my $pmopsym = $pmop->save; # XXX can this recurse? 2701 my $pmopsym = $pmop->save; # XXX can this recurse?
2702 # warn "pmopsym = $pmopsym\n" if $verbose; 2702 # warn "pmopsym = $pmopsym\n" if $verbose;
2703 save_or_restore_lexical_state( ${ $pmop->pmreplstart } ); 2703 save_or_restore_lexical_state( ${ $pmop->pmreplstart } );
2704 runtime sprintf( 2704 runtime sprintf(
2705 "if (PL_op == ((PMOP*)(%s))%s) goto %s;", 2705 "if (PL_op == ((PMOP*)(%s))%s) goto %s;",
2706 $pmopsym, 2706 $pmopsym,
2707 $PERL510 ? "->op_pmstashstartu.op_pmreplstart" : "->op_pmreplstart", 2707 $PERL510 ? "->op_pmstashstartu.op_pmreplstart" : "->op_pmreplstart",
2708 label( $pmop->pmreplstart ) 2708 label( $pmop->pmreplstart )
2709 ); 2709 );
2710 push( @bblock_todo, $pmop->pmreplstart ); 2710 push( @bblock_todo, $pmop->pmreplstart );
2711 invalidate_lexicals(); 2711 invalidate_lexicals();
2712 return $pmop->next; 2712 return $pmop->next;
2713 } 2713 }
2714 2714
2715 # coverage: issue24 2715 # coverage: issue24
2716 # resolve the DBM library at compile-time, not at run-time 2716 # resolve the DBM library at compile-time, not at run-time
2717 sub pp_dbmopen { 2717 sub pp_dbmopen {
2718 my $op = shift; 2718 my $op = shift;
2719 require AnyDBM_File; 2719 require AnyDBM_File;
2720 my $dbm = $AnyDBM_File::ISA[0]; 2720 my $dbm = $AnyDBM_File::ISA[0];
2721 svref_2object( \&{"$dbm\::bootstrap"} )->save; 2721 svref_2object( \&{"$dbm\::bootstrap"} )->save;
2722 return default_pp($op); 2722 return default_pp($op);
2723 } 2723 }
2724 2724
2725 sub default_pp { 2725 sub default_pp {
2726 my $op = shift; 2726 my $op = shift;
2727 my $ppname = "pp_" . $op->name; 2727 my $ppname = "pp_" . $op->name;
2728 # runtime(sprintf("/* %s */", $ppname)) if $verbose; 2728 # runtime(sprintf("/* %s */", $ppname)) if $verbose;
2729 if ( $curcop and $need_curcop{$ppname} ) { 2729 if ( $curcop and $need_curcop{$ppname} ) {
2730 $curcop->write_back; 2730 $curcop->write_back;
2731 } 2731 }
2732 write_back_lexicals() unless $skip_lexicals{$ppname}; 2732 write_back_lexicals() unless $skip_lexicals{$ppname};
2733 write_back_stack() unless $skip_stack{$ppname}; 2733 write_back_stack() unless $skip_stack{$ppname};
2734 doop($op); 2734 doop($op);
2735 2735
2736 # XXX If the only way that ops can write to a TEMPORARY lexical is 2736 # XXX If the only way that ops can write to a TEMPORARY lexical is
2737 # when it's named in $op->targ then we could call 2737 # when it's named in $op->targ then we could call
2738 # invalidate_lexicals(TEMPORARY) and avoid having to write back all 2738 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
2739 # the temporaries. For now, we'll play it safe and write back the lot. 2739 # the temporaries. For now, we'll play it safe and write back the lot.
2740 invalidate_lexicals() unless $skip_invalidate{$ppname}; 2740 invalidate_lexicals() unless $skip_invalidate{$ppname};
2741 return $op->next; 2741 return $op->next;
2742 } 2742 }
2743 2743
2744 sub compile_op { 2744 sub compile_op {
2745 my $op = shift; 2745 my $op = shift;
2746 my $ppname = "pp_" . $op->name; 2746 my $ppname = "pp_" . $op->name;
2747 if ( exists $ignore_op{$ppname} ) { 2747 if ( exists $ignore_op{$ppname} ) {
2748 return $op->next; 2748 return $op->next;
2749 } 2749 }
2750 debug peek_stack() if $debug{stack}; 2750 debug peek_stack() if $debug{stack};
2751 if ( $debug{op} ) { 2751 if ( $debug{op} ) {
2752 debug sprintf( "%s [%s]\n", 2752 debug sprintf( "%s [%s]\n",
2753 peekop($op), $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ ); 2753 peekop($op), $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ );
2754 } 2754 }
2755 no strict 'refs'; 2755 no strict 'refs';
2756 if ( defined(&$ppname) ) { 2756 if ( defined(&$ppname) ) {
2757 $know_op = 0; 2757 $know_op = 0;
2758 return &$ppname($op); 2758 return &$ppname($op);
2759 } 2759 }
2760 else { 2760 else {
2761 return default_pp($op); 2761 return default_pp($op);
2762 } 2762 }
2763 } 2763 }
2764 2764
2765 sub compile_bblock { 2765 sub compile_bblock {
2766 my $op = shift; 2766 my $op = shift;
2767 warn "compile_bblock: ", peekop($op), "\n" if $debug{bblock}; 2767 warn "compile_bblock: ", peekop($op), "\n" if $debug{bblock};
2768 save_or_restore_lexical_state($$op); 2768 save_or_restore_lexical_state($$op);
2769 write_label($op); 2769 write_label($op);
2770 $know_op = 0; 2770 $know_op = 0;
2771 do { 2771 do {
2772 $op = compile_op($op); 2772 $op = compile_op($op);
2773 if ($] < 5.013 and ($slow_signals or ($$op and $async_signals{$op->name}))) { 2773 if ($] < 5.013 and ($slow_signals or ($$op and $async_signals{$op->name}))) {
2774 runtime("PERL_ASYNC_CHECK();"); 2774 runtime("PERL_ASYNC_CHECK();");
2775 } 2775 }
2776 } while ( defined($op) && $$op && !exists( $leaders->{$$op} ) ); 2776 } while ( defined($op) && $$op && !exists( $leaders->{$$op} ) );
2777 write_back_stack(); # boo hoo: big loss 2777 write_back_stack(); # boo hoo: big loss
2778 reload_lexicals(); 2778 reload_lexicals();
2779 return $op; 2779 return $op;
2780 } 2780 }
2781 2781
2782 sub cc { 2782 sub cc {
2783 my ( $name, $root, $start, @padlist ) = @_; 2783 my ( $name, $root, $start, @padlist ) = @_;
2784 my $op; 2784 my $op;
2785 if ( $done{$$start} ) { 2785 if ( $done{$$start} ) {
2786 warn "repeat=>" . ref($start) . " $name,\n" if $verbose; 2786 warn "repeat=>" . ref($start) . " $name,\n" if $verbose;
2787 $decl->add( sprintf( "#define $name %s", $done{$$start} ) ); 2787 $decl->add( sprintf( "#define $name %s", $done{$$start} ) );
2788 return; 2788 return;
2789 } 2789 }
2790 warn "cc $name\n" if $verbose; 2790 warn "cc $name\n" if $verbose;
2791 init_pp($name); 2791 init_pp($name);
2792 load_pad(@padlist); 2792 load_pad(@padlist);
2793 %lexstate = (); 2793 %lexstate = ();
2794 B::Pseudoreg->new_scope; 2794 B::Pseudoreg->new_scope;
2795 @cxstack = (); 2795 @cxstack = ();
2796 if ( $debug{timings} ) { 2796 if ( $debug{timings} ) {
2797 warn sprintf( "Basic block analysis at %s\n", timing_info ); 2797 warn sprintf( "Basic block analysis at %s\n", timing_info );
2798 } 2798 }
2799 $leaders = find_leaders( $root, $start ); 2799 $leaders = find_leaders( $root, $start );
2800 my @leaders = keys %$leaders; 2800 my @leaders = keys %$leaders;
2801 if ( $#leaders > -1 ) { 2801 if ( $#leaders > -1 ) {
2802 # Don't add basic blocks of dead code. 2802 # Don't add basic blocks of dead code.
2803 # It would produce errors when processing $cxstack. 2803 # It would produce errors when processing $cxstack.
2804 # @bblock_todo = ( values %$leaders ); 2804 # @bblock_todo = ( values %$leaders );
2805 # Instead, save $root (pp_leavesub) separately, 2805 # Instead, save $root (pp_leavesub) separately,
2806 # because it will not get compiled if located in dead code. 2806 # because it will not get compiled if located in dead code.
2807 $root->save; 2807 $root->save;
2808 unshift @bblock_todo, ($start) if $$start; 2808 unshift @bblock_todo, ($start) if $$start;
2809 } 2809 }
2810 else { 2810 else {
2811 runtime("return PL_op?PL_op->op_next:0;"); 2811 runtime("return PL_op?PL_op->op_next:0;");
2812 } 2812 }
2813 if ( $debug{timings} ) { 2813 if ( $debug{timings} ) {
2814 warn sprintf( "Compilation at %s\n", timing_info ); 2814 warn sprintf( "Compilation at %s\n", timing_info );
2815 } 2815 }
2816 while (@bblock_todo) { 2816 while (@bblock_todo) {
2817 $op = shift @bblock_todo; 2817 $op = shift @bblock_todo;
2818 warn sprintf( "Considering basic block %s\n", peekop($op) ) if $debug{bblock}; 2818 warn sprintf( "Considering basic block %s\n", peekop($op) ) if $debug{bblock};
2819 next if !defined($op) || !$$op || $done{$$op}; 2819 next if !defined($op) || !$$op || $done{$$op};
2820 warn "...compiling it\n" if $debug{bblock}; 2820 warn "...compiling it\n" if $debug{bblock};
2821 do { 2821 do {
2822 $done{$$op} = $name; 2822 $done{$$op} = $name;
2823 $op = compile_bblock($op); 2823 $op = compile_bblock($op);
2824 if ( $need_freetmps && $freetmps_each_bblock ) { 2824 if ( $need_freetmps && $freetmps_each_bblock ) {
2825 runtime("FREETMPS;"); 2825 runtime("FREETMPS;");
2826 $need_freetmps = 0; 2826 $need_freetmps = 0;
2827 } 2827 }
2828 } while defined($op) && $$op && !$done{$$op}; 2828 } while defined($op) && $$op && !$done{$$op};
2829 if ( $need_freetmps && $freetmps_each_loop ) { 2829 if ( $need_freetmps && $freetmps_each_loop ) {
2830 runtime("FREETMPS;"); 2830 runtime("FREETMPS;");
2831 $need_freetmps = 0; 2831 $need_freetmps = 0;
2832 } 2832 }
2833 if ( !$$op ) { 2833 if ( !$$op ) {
2834 runtime( "PUTBACK;", 2834 runtime( "PUTBACK;",
2835 "return NULL;" ); 2835 "return NULL;" );
2836 } 2836 }
2837 elsif ( $done{$$op} ) { 2837 elsif ( $done{$$op} ) {
2838 save_or_restore_lexical_state($$op); 2838 save_or_restore_lexical_state($$op);
2839 runtime( sprintf( "goto %s;", label($op) ) ); 2839 runtime( sprintf( "goto %s;", label($op) ) );
2840 } 2840 }
2841 } 2841 }
2842 if ( $debug{timings} ) { 2842 if ( $debug{timings} ) {
2843 warn sprintf( "Saving runtime at %s\n", timing_info ); 2843 warn sprintf( "Saving runtime at %s\n", timing_info );
2844 } 2844 }
2845 declare_pad(@padlist); 2845 declare_pad(@padlist);
2846 save_runtime(); 2846 save_runtime();
2847 } 2847 }
2848 2848
2849 sub cc_recurse { 2849 sub cc_recurse {
2850 my ($ccinfo); 2850 my ($ccinfo);
2851 my $start = cc_queue(@_) if @_; 2851 my $start = cc_queue(@_) if @_;
2852 2852
2853 while ( $ccinfo = shift @cc_todo ) { 2853 while ( $ccinfo = shift @cc_todo ) {
2854 if ($DB::deep and $ccinfo->[0] =~ /^pp_sub_(DB|Term__ReadLine)_/) { 2854 if ($DB::deep and $ccinfo->[0] =~ /^pp_sub_(DB|Term__ReadLine)_/) {
2855 warn "cc $ccinfo->[0] skipped (debugging)\n" if $verbose; 2855 warn "cc $ccinfo->[0] skipped (debugging)\n" if $verbose;
2856 debug "cc(ccinfo): @$ccinfo skipped (debugging)\n" if $debug{queue}; 2856 debug "cc(ccinfo): @$ccinfo skipped (debugging)\n" if $debug{queue};
2857 } 2857 }
2858 elsif ($cc_pp_sub{$ccinfo->[0]}) { # skip duplicates 2858 elsif ($cc_pp_sub{$ccinfo->[0]}) { # skip duplicates
2859 warn "cc $ccinfo->[0] already defined\n" if $verbose; 2859 warn "cc $ccinfo->[0] already defined\n" if $verbose;
2860 debug "cc(ccinfo): @$ccinfo already defined\n" if $debug{queue}; 2860 debug "cc(ccinfo): @$ccinfo already defined\n" if $debug{queue};
2861 } else { 2861 } else {
2862 debug "cc(ccinfo): @$ccinfo\n" if $debug{queue}; 2862 debug "cc(ccinfo): @$ccinfo\n" if $debug{queue};
2863 cc(@$ccinfo); 2863 cc(@$ccinfo);
2864 $cc_pp_sub{$ccinfo->[0]}++; 2864 $cc_pp_sub{$ccinfo->[0]}++;
2865 } 2865 }
2866 } 2866 }
2867 return $start; 2867 return $start;
2868 } 2868 }
2869 2869
2870 sub cc_obj { 2870 sub cc_obj {
2871 my ( $name, $cvref ) = @_; 2871 my ( $name, $cvref ) = @_;
2872 my $cv = svref_2object($cvref); 2872 my $cv = svref_2object($cvref);
2873 my @padlist = $cv->PADLIST->ARRAY; 2873 my @padlist = $cv->PADLIST->ARRAY;
2874 my $curpad_sym = $padlist[1]->save; 2874 my $curpad_sym = $padlist[1]->save;
2875 cc_recurse( $name, $cv->ROOT, $cv->START, @padlist ); 2875 cc_recurse( $name, $cv->ROOT, $cv->START, @padlist );
2876 } 2876 }
2877 2877
2878 sub cc_main { 2878 sub cc_main {
2879 my @comppadlist = comppadlist->ARRAY; 2879 my @comppadlist = comppadlist->ARRAY;
2880 my $curpad_nam = $comppadlist[0]->save; 2880 my $curpad_nam = $comppadlist[0]->save;
2881 my $curpad_sym = $comppadlist[1]->save; 2881 my $curpad_sym = $comppadlist[1]->save;
2882 my $init_av = init_av->save; 2882 my $init_av = init_av->save;
2883 my $start = cc_recurse( "pp_main", main_root, main_start, @comppadlist ); 2883 my $start = cc_recurse( "pp_main", main_root, main_start, @comppadlist );
2884 2884
2885 # Do save_unused_subs before saving inc_hv 2885 # Do save_unused_subs before saving inc_hv
2886 B::C::module($module) if $module; 2886 B::C::module($module) if $module;
2887 save_unused_subs(); 2887 save_unused_subs();
2888 2888
2889 my $warner = $SIG{__WARN__}; 2889 my $warner = $SIG{__WARN__};
2890 save_sig($warner); 2890 save_sig($warner);
2891 2891
2892 my($inc_hv, $inc_av, $end_av); 2892 my($inc_hv, $inc_av, $end_av);
2893 if ( !defined($module) ) { 2893 if ( !defined($module) ) {
2894 # forbid run-time extends of curpad syms, names and INC 2894 # forbid run-time extends of curpad syms, names and INC
2895 warn "save context:\n" if $verbose; 2895 warn "save context:\n" if $verbose;
2896 $init->add("/* save context */"); 2896 $init->add("/* save context */");
2897 $init->add('/* %INC */'); 2897 $init->add('/* %INC */');
2898 inc_cleanup(); 2898 inc_cleanup();
2899 my $inc_gv = svref_2object( \*main::INC ); 2899 my $inc_gv = svref_2object( \*main::INC );
2900 $inc_hv = $inc_gv->HV->save('main::INC'); 2900 $inc_hv = $inc_gv->HV->save('main::INC');
2901 $init->add( sprintf( "GvHV(%s) = s\\_%x;", 2901 $init->add( sprintf( "GvHV(%s) = s\\_%x;",
2902 $inc_gv->save('main::INC'), $inc_gv->HV ) ); 2902 $inc_gv->save('main::INC'), $inc_gv->HV ) );
2903 local ($B::C::pv_copy_on_grow, $B::C::const_strings); 2903 local ($B::C::pv_copy_on_grow, $B::C::const_strings);
2904 $B::C::pv_copy_on_grow = $B::C::const_strings = 1 if $B::C::ro_inc; 2904 $B::C::pv_copy_on_grow = $B::C::const_strings = 1 if $B::C::ro_inc;
2905 $inc_hv = $inc_gv->HV->save('main::INC'); 2905 $inc_hv = $inc_gv->HV->save('main::INC');
2906 $inc_av = $inc_gv->AV->save('main::INC'); 2906 $inc_av = $inc_gv->AV->save('main::INC');
2907 } 2907 }
2908 { 2908 {
2909 # >=5.10 needs to defer nullifying of all vars in END, not only new ones. 2909 # >=5.10 needs to defer nullifying of all vars in END, not only new ones.
2910 local ($B::C::pv_copy_on_grow, $B::C::const_strings); 2910 local ($B::C::pv_copy_on_grow, $B::C::const_strings);
2911 $B::C::in_endav = 1; 2911 $B::C::in_endav = 1;
2912 $end_av = end_av->save; 2912 $end_av = end_av->save;
2913 } 2913 }
2914 cc_recurse(); 2914 cc_recurse();
2915 return if $errors or $check; 2915 return if $errors or $check;
2916 2916
2917 if ( !defined($module) ) { 2917 if ( !defined($module) ) {
2918 # XXX TODO push BEGIN/END blocks to modules code. 2918 # XXX TODO push BEGIN/END blocks to modules code.
2919 $init->add( 2919 $init->add(
2920 sprintf( "PL_main_root = s\\_%x;", ${ main_root() } ), 2920 sprintf( "PL_main_root = s\\_%x;", ${ main_root() } ),
2921 "PL_main_start = $start;", 2921 "PL_main_start = $start;",
2922 "PL_curpad = AvARRAY($curpad_sym);", 2922 "PL_curpad = AvARRAY($curpad_sym);",
2923 "PL_comppad = $curpad_sym;", 2923 "PL_comppad = $curpad_sym;",
2924 "av_store(CvPADLIST(PL_main_cv), 0, SvREFCNT_inc($curpad_nam));", 2924 "av_store(CvPADLIST(PL_main_cv), 0, SvREFCNT_inc($curpad_nam));",
2925 "av_store(CvPADLIST(PL_main_cv), 1, SvREFCNT_inc($curpad_sym));", 2925 "av_store(CvPADLIST(PL_main_cv), 1, SvREFCNT_inc($curpad_sym));",
2926 "GvHV(PL_incgv) = $inc_hv;", 2926 "GvHV(PL_incgv) = $inc_hv;",
2927 "GvAV(PL_incgv) = $inc_av;", 2927 "GvAV(PL_incgv) = $inc_av;",
2928 "PL_initav = (AV*)$init_av;", 2928 "PL_initav = (AV*)$init_av;",
2929 "PL_endav = (AV*)$end_av;" 2929 "PL_endav = (AV*)$end_av;"
2930 ); 2930 );
2931 if ($] < 5.017) { 2931 if ($] < 5.017) {
2932 my $amagic_generate = B::amagic_generation; 2932 my $amagic_generate = B::amagic_generation;
2933 $init->add("PL_amagic_generation = $amagic_generate;"); 2933 $init->add("PL_amagic_generation = $amagic_generate;");
2934 }; 2934 };
2935 } 2935 }
2936 2936
2937 seek( STDOUT, 0, 0 ); #prevent print statements from BEGIN{} into the output 2937 seek( STDOUT, 0, 0 ); #prevent print statements from BEGIN{} into the output
2938 fixup_ppaddr(); 2938 fixup_ppaddr();
2939 output_boilerplate(); 2939 output_boilerplate();
2940 print "\n"; 2940 print "\n";
2941 output_all("perl_init"); 2941 output_all("perl_init");
2942 output_runtime(); 2942 output_runtime();
2943 print "\n"; 2943 print "\n";
2944 output_main_rest(); 2944 output_main_rest();
2945 2945
2946 if ( defined($module) ) { 2946 if ( defined($module) ) {
2947 my $cmodule = $module ||= 'main'; 2947 my $cmodule = $module ||= 'main';
2948 $cmodule =~ s/::/__/g; 2948 $cmodule =~ s/::/__/g;
2949 print <<"EOT"; 2949 print <<"EOT";
2950 2950
2951 #include "XSUB.h" 2951 #include "XSUB.h"
2952 XS(boot_$cmodule) 2952 XS(boot_$cmodule)
2953 { 2953 {
2954 dXSARGS; 2954 dXSARGS;
2955 perl_init(); 2955 perl_init();
2956 ENTER; 2956 ENTER;
2957 SAVETMPS; 2957 SAVETMPS;
2958 SAVEVPTR(PL_curpad); 2958 SAVEVPTR(PL_curpad);
2959 SAVEVPTR(PL_op); 2959 SAVEVPTR(PL_op);
2960 PL_curpad = AvARRAY($curpad_sym); 2960 PL_curpad = AvARRAY($curpad_sym);
2961 PL_op = $start; 2961 PL_op = $start;
2962 pp_main(aTHX); 2962 pp_main(aTHX);
2963 FREETMPS; 2963 FREETMPS;
2964 LEAVE; 2964 LEAVE;
2965 ST(0) = &PL_sv_yes; 2965 ST(0) = &PL_sv_yes;
2966 XSRETURN(1); 2966 XSRETURN(1);
2967 } 2967 }
2968 EOT 2968 EOT
2969 } else { 2969 } else {
2970 output_main(); 2970 output_main();
2971 } 2971 }
2972 if ( $debug{timings} ) { 2972 if ( $debug{timings} ) {
2973 warn sprintf( "Done at %s\n", timing_info ); 2973 warn sprintf( "Done at %s\n", timing_info );
2974 } 2974 }
2975 } 2975 }
2976 2976
2977 sub compile_stats { 2977 sub compile_stats {
2978 return "Total number of OPs processed: $op_count\n"; 2978 return "Total number of OPs processed: $op_count\n";
2979 } 2979 }
2980 2980
2981 # Accessible via use B::CC '-ftype-attr'; in user code, or -MB::CC=-O2 on the cmdline 2981 # Accessible via use B::CC '-ftype-attr'; in user code, or -MB::CC=-O2 on the cmdline
2982 sub import { 2982 sub import {
2983 my @options = @_; 2983 my @options = @_;
2984 # Allow debugging in CHECK blocks without Od 2984 # Allow debugging in CHECK blocks without Od
2985 $DB::single = 1 if defined &DB::DB; 2985 $DB::single = 1 if defined &DB::DB;
2986 my ( $option, $opt, $arg ); 2986 my ( $option, $opt, $arg );
2987 # init with -O0 2987 # init with -O0
2988 foreach my $ref ( values %optimise ) { 2988 foreach my $ref ( values %optimise ) {
2989 $$ref = 0; 2989 $$ref = 0;
2990 } 2990 }
2991 $B::C::fold = 0 if $] >= 5.013009; # utf8::Cased tables 2991 $B::C::fold = 0 if $] >= 5.013009; # utf8::Cased tables
2992 $B::C::warnings = 0 if $] >= 5.013005; # Carp warnings categories and B 2992 $B::C::warnings = 0 if $] >= 5.013005; # Carp warnings categories and B
2993 OPTION: 2993 OPTION:
2994 while ( $option = shift @options ) { 2994 while ( $option = shift @options ) {
2995 if ( $option =~ /^-(.)(.*)/ ) { 2995 if ( $option =~ /^-(.)(.*)/ ) {
2996 $opt = $1; 2996 $opt = $1;
2997 $arg = $2; 2997 $arg = $2;
2998 } 2998 }
2999 else { 2999 else {
3000 unshift @options, $option; 3000 unshift @options, $option;
3001 last OPTION; 3001 last OPTION;
3002 } 3002 }
3003 if ( $opt eq "-" && $arg eq "-" ) { 3003 if ( $opt eq "-" && $arg eq "-" ) {
3004 shift @options; 3004 shift @options;
3005 last OPTION; 3005 last OPTION;
3006 } 3006 }
3007 elsif ( $opt eq "o" ) { 3007 elsif ( $opt eq "o" ) {
3008 $arg ||= shift @options; 3008 $arg ||= shift @options;
3009 open( STDOUT, ">$arg" ) or return "open '>$arg': $!\n"; 3009 open( STDOUT, ">$arg" ) or return "open '>$arg': $!\n";
3010 } 3010 }
3011 elsif ( $opt eq "c" ) { 3011 elsif ( $opt eq "c" ) {
3012 $check = 1; 3012 $check = 1;
3013 $B::C::check = 1; 3013 $B::C::check = 1;
3014 } 3014 }
3015 elsif ( $opt eq "v" ) { 3015 elsif ( $opt eq "v" ) {
3016 $verbose = 1; 3016 $verbose = 1;
3017 B::C::verbose(1); # crashed in C _save_common_middle(B::FAKEOP) 3017 B::C::verbose(1); # crashed in C _save_common_middle(B::FAKEOP)
3018 } 3018 }
3019 elsif ( $opt eq "u" ) { 3019 elsif ( $opt eq "u" ) {
3020 $arg ||= shift @options; 3020 $arg ||= shift @options;
3021 eval "require $arg;"; 3021 eval "require $arg;";
3022 mark_unused( $arg, 1 ); 3022 mark_unused( $arg, 1 );
3023 } 3023 }
3024 elsif ( $opt eq "U" ) { 3024 elsif ( $opt eq "U" ) {
3025 $arg ||= shift @options; 3025 $arg ||= shift @options;
3026 mark_skip( $arg ); 3026 mark_skip( $arg );
3027 } 3027 }
3028 elsif ( $opt eq "strict" ) { 3028 elsif ( $opt eq "strict" ) {
3029 $arg ||= shift @options; 3029 $arg ||= shift @options;
3030 $strict++; 3030 $strict++;
3031 } 3031 }
3032 elsif ( $opt eq "f" ) { 3032 elsif ( $opt eq "f" ) {
3033 $arg ||= shift @options; 3033 $arg ||= shift @options;
3034 my $value = $arg !~ s/^no-//; 3034 my $value = $arg !~ s/^no-//;
3035 $arg =~ s/-/_/g; 3035 $arg =~ s/-/_/g;
3036 my $ref = $optimise{$arg}; 3036 my $ref = $optimise{$arg};
3037 if ( defined($ref) ) { 3037 if ( defined($ref) ) {
3038 $$ref = $value; 3038 $$ref = $value;
3039 } 3039 }
3040 else { 3040 else {
3041 # Pass down to B::C 3041 # Pass down to B::C
3042 my $ref = $B::C::option_map{$arg}; 3042 my $ref = $B::C::option_map{$arg};
3043 if ( defined($ref) ) { 3043 if ( defined($ref) ) {
3044 $$ref = $value; 3044 $$ref = $value;
3045 $c_optimise{$ref}++; 3045 $c_optimise{$ref}++;
3046 } 3046 }
3047 else { 3047 else {
3048 warn qq(ignoring unknown optimisation option "$arg"\n); 3048 warn qq(ignoring unknown optimisation option "$arg"\n);
3049 } 3049 }
3050 } 3050 }
3051 } 3051 }
3052 elsif ( $opt eq "O" ) { 3052 elsif ( $opt eq "O" ) {
3053 $arg = 1 if $arg eq ""; 3053 $arg = 1 if $arg eq "";
3054 foreach my $ref ( values %optimise ) { 3054 foreach my $ref ( values %optimise ) {
3055 $$ref = 0; 3055 $$ref = 0;
3056 } 3056 }
3057 if ($arg >= 2) { 3057 if ($arg >= 2) {
3058 $freetmps_each_loop = 1; 3058 $freetmps_each_loop = 1;
3059 $B::C::destruct = 0 unless $] < 5.008; # fast_destruct 3059 $B::C::destruct = 0 unless $] < 5.008; # fast_destruct
3060 } 3060 }
3061 if ( $arg >= 1 ) { 3061 if ( $arg >= 1 ) {
3062 $type_attr = 1; 3062 $type_attr = 1;
3063 $freetmps_each_bblock = 1 unless $freetmps_each_loop; 3063 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
3064 } 3064 }
3065 } 3065 }
3066 elsif ( $opt eq "n" ) { 3066 elsif ( $opt eq "n" ) {
3067 $arg ||= shift @options; 3067 $arg ||= shift @options;
3068 $init_name = $arg; 3068 $init_name = $arg;
3069 } 3069 }
3070 elsif ( $opt eq "m" ) { 3070 elsif ( $opt eq "m" ) {
3071 $module = $arg; 3071 $module = $arg;
3072 mark_unused( $arg, undef ); 3072 mark_unused( $arg, undef );
3073 } 3073 }
3074 elsif ( $opt eq "p" ) { 3074 elsif ( $opt eq "p" ) {
3075 $arg ||= shift @options; 3075 $arg ||= shift @options;
3076 $patchlevel = $arg; 3076 $patchlevel = $arg;
3077 } 3077 }
3078 elsif ( $opt eq "D" ) { 3078 elsif ( $opt eq "D" ) {
3079 $arg ||= shift @options; 3079 $arg ||= shift @options;
3080 $verbose++; 3080 $verbose++;
3081 $arg = 'oOscprSqlt' if $arg eq 'full'; 3081 $arg = 'oOscprSqlt' if $arg eq 'full';
3082 foreach $arg ( split( //, $arg ) ) { 3082 foreach $arg ( split( //, $arg ) ) {
3083 if ( $arg eq "o" ) { 3083 if ( $arg eq "o" ) {
3084 B->debug(1); 3084 B->debug(1);
3085 } 3085 }
3086 elsif ( $arg eq "O" ) { 3086 elsif ( $arg eq "O" ) {
3087 $debug{op}++; 3087 $debug{op}++;
3088 } 3088 }
3089 elsif ( $arg eq "s" ) { 3089 elsif ( $arg eq "s" ) {
3090 $debug{stack}++; 3090 $debug{stack}++;
3091 } 3091 }
3092 elsif ( $arg eq "c" ) { 3092 elsif ( $arg eq "c" ) {
3093 $debug{cxstack}++; 3093 $debug{cxstack}++;
3094 } 3094 }
3095 elsif ( $arg eq "p" ) { 3095 elsif ( $arg eq "p" ) {
3096 $debug{pad}++; 3096 $debug{pad}++;
3097 } 3097 }
3098 elsif ( $arg eq "r" ) { 3098 elsif ( $arg eq "r" ) {
3099 $debug{runtime}++; 3099 $debug{runtime}++;
3100 } 3100 }
3101 elsif ( $arg eq "S" ) { 3101 elsif ( $arg eq "S" ) {
3102 $debug{shadow}++; 3102 $debug{shadow}++;
3103 } 3103 }
3104 elsif ( $arg eq "q" ) { 3104 elsif ( $arg eq "q" ) {
3105 $debug{queue}++; 3105 $debug{queue}++;
3106 } 3106 }
3107 elsif ( $arg eq "l" ) { 3107 elsif ( $arg eq "l" ) {
3108 $debug{lineno}++; 3108 $debug{lineno}++;
3109 } 3109 }
3110 elsif ( $arg eq "t" ) { 3110 elsif ( $arg eq "t" ) {
3111 $debug{timings}++; 3111 $debug{timings}++;
3112 } 3112 }
3113 elsif ( $arg eq "F" and eval "require B::Flags;" ) { 3113 elsif ( $arg eq "F" and eval "require B::Flags;" ) {
3114 $debug{flags}++; 3114 $debug{flags}++;
3115 $B::C::debug{flags}++; 3115 $B::C::debug{flags}++;
3116 } 3116 }
3117 elsif ( exists $B::C::debug_map{$arg} ) { 3117 elsif ( exists $B::C::debug_map{$arg} ) {
3118 $B::C::debug{ $B::C::debug_map{$arg} }++; 3118 $B::C::debug{ $B::C::debug_map{$arg} }++;
3119 } 3119 }
3120 else { 3120 else {
3121 warn qq(ignoring unknown -D option "$arg"\n); 3121 warn qq(ignoring unknown -D option "$arg"\n);
3122 } 3122 }
3123 } 3123 }
3124 } 3124 }
3125 } 3125 }
3126 $strict++ if !$strict and $Config{ccflags} !~ m/-DDEBUGGING/; 3126 $strict++ if !$strict and $Config{ccflags} !~ m/-DDEBUGGING/;
3127 3127
3128 # rgs didn't want opcodes to be added to Opcode. So I had to add it to a 3128 # rgs didn't want opcodes to be added to Opcode. So I had to add it to a
3129 # seperate Opcodes package. 3129 # seperate Opcodes package.
3130 eval { require Opcodes; }; 3130 eval { require Opcodes; };
3131 if (!$@ and $Opcodes::VERSION) { 3131 if (!$@ and $Opcodes::VERSION) {
3132 my $MAXO = Opcodes::opcodes(); 3132 my $MAXO = Opcodes::opcodes();
3133 for (0..$MAXO-1) { 3133 for (0..$MAXO-1) {
3134 no strict 'refs'; 3134 no strict 'refs';
3135 my $ppname = "pp_".Opcodes::opname($_); 3135 my $ppname = "pp_".Opcodes::opname($_);
3136 # opflags n: no args, no return values. don't need save/restore stack 3136 # opflags n: no args, no return values. don't need save/restore stack
3137 # But pp_enter, pp_leave use/change global stack. 3137 # But pp_enter, pp_leave use/change global stack.
3138 next if $ppname eq 'pp_enter' || $ppname eq 'pp_leave'; 3138 next if $ppname eq 'pp_enter' || $ppname eq 'pp_leave';
3139 $no_stack{$ppname} = 1 3139 $no_stack{$ppname} = 1
3140 if Opcodes::opflags($_) & 512; 3140 if Opcodes::opflags($_) & 512;
3141 # XXX More Opcodes options to be added later 3141 # XXX More Opcodes options to be added later
3142 } 3142 }
3143 } 3143 }
3144 #if ($debug{op}) { 3144 #if ($debug{op}) {
3145 # warn "no_stack: ",join(" ",sort keys %no_stack),"\n"; 3145 # warn "no_stack: ",join(" ",sort keys %no_stack),"\n";
3146 #} 3146 #}
3147 3147
3148 mark_skip('B::C', 'B::C::Flags', 'B::CC', 'B::Asmdata', 'B::FAKEOP', 3148 mark_skip('B::C', 'B::C::Flags', 'B::CC', 'B::Asmdata', 'B::FAKEOP',
3149 'B::Section', 'B::Pseudoreg', 'B::Shadow', 'O', 'Opcodes', 3149 'B::Section', 'B::Pseudoreg', 'B::Shadow', 'O', 'Opcodes',
3150 'B::Stackobj', 'B::Stackobj::Bool', 'B::Stackobj::Padsv', 'B::Stackobj::Const', 3150 'B::Stackobj', 'B::Stackobj::Bool', 'B::Stackobj::Padsv', 'B::Stackobj::Const',
3151 'B::Bblock'); 3151 'B::Bblock');
3152 mark_skip('DB', 'Term::ReadLine') if defined &DB::DB; 3152 mark_skip('DB', 'Term::ReadLine') if defined &DB::DB;
3153 3153
3154 # Set some B::C optimizations. 3154 # Set some B::C optimizations.
3155 # optimize_ppaddr is not needed with B::CC as CC does it even better. 3155 # optimize_ppaddr is not needed with B::CC as CC does it even better.
3156 for (qw(optimize_warn_sv save_data_fh av_init save_sig destruct), 3156 for (qw(optimize_warn_sv save_data_fh av_init save_sig destruct),
3157 $PERL510 ? () : "pv_copy_on_grow") 3157 $PERL510 ? () : "pv_copy_on_grow")
3158 { 3158 {
3159 no strict 'refs'; 3159 no strict 'refs';
3160 ${"B::C::$_"} = 1 unless $c_optimise{$_}; 3160 ${"B::C::$_"} = 1 unless $c_optimise{$_};
3161 } 3161 }
3162 $B::C::stash = 0 unless $c_optimise{stash}; 3162 $B::C::stash = 0 unless $c_optimise{stash};
3163 if (!$B::C::Flags::have_independent_comalloc) { 3163 if (!$B::C::Flags::have_independent_comalloc) {
3164 $B::C::av_init = 1 unless $c_optimise{av_init}; 3164 $B::C::av_init = 1 unless $c_optimise{av_init};
3165 $B::C::av_init2 = 0 unless $c_optimise{av_init2}; 3165 $B::C::av_init2 = 0 unless $c_optimise{av_init2};
3166 } else { 3166 } else {
3167 $B::C::av_init = 0 unless $c_optimise{av_init}; 3167 $B::C::av_init = 0 unless $c_optimise{av_init};
3168 $B::C::av_init2 = 1 unless $c_optimise{av_init2}; 3168 $B::C::av_init2 = 1 unless $c_optimise{av_init2};
3169 } 3169 }
3170 init_type_attrs() if $type_attr; # but too late for -MB::CC=-O2 on import. attrs are checked before 3170 init_type_attrs() if $type_attr; # but too late for -MB::CC=-O2 on import. attrs are checked before
3171 @options; 3171 @options;
3172 } 3172 }
3173 3173
3174 # -MO=CC entry point 3174 # -MO=CC entry point
3175 sub compile { 3175 sub compile {
3176 my @options = @_; 3176 my @options = @_;
3177 @options = import(@options); 3177 @options = import(@options);
3178 3178
3179 init_sections(); 3179 init_sections();
3180 $init = B::Section->get("init"); 3180 $init = B::Section->get("init");
3181 $decl = B::Section->get("decl"); 3181 $decl = B::Section->get("decl");
3182 3182
3183 # just some subs or main? 3183 # just some subs or main?
3184 if (@options) { 3184 if (@options) {
3185 return sub { 3185 return sub {
3186 my ( $objname, $ppname ); 3186 my ( $objname, $ppname );
3187 foreach $objname (@options) { 3187 foreach $objname (@options) {
3188 $objname = "main::$objname" unless $objname =~ /::/; 3188 $objname = "main::$objname" unless $objname =~ /::/;
3189 ( $ppname = $objname ) =~ s/^.*?:://; 3189 ( $ppname = $objname ) =~ s/^.*?:://;
3190 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)"; 3190 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
3191 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@; 3191 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
3192 return if $errors; 3192 return if $errors;
3193 } 3193 }
3194 my $warner = $SIG{__WARN__}; 3194 my $warner = $SIG{__WARN__};
3195 save_sig($warner); 3195 save_sig($warner);
3196 fixup_ppaddr(); 3196 fixup_ppaddr();
3197 return if $check; 3197 return if $check;
3198 output_boilerplate(); 3198 output_boilerplate();
3199 print "\n"; 3199 print "\n";
3200 output_all( $init_name || "init_module" ); 3200 output_all( $init_name || "init_module" );
3201 output_runtime(); 3201 output_runtime();
3202 # output_main_rest(); 3202 # output_main_rest();
3203 } 3203 }
3204 } 3204 }
3205 else { 3205 else {
3206 return sub { cc_main() }; 3206 return sub { cc_main() };
3207 } 3207 }
3208 } 3208 }
3209 3209
3210 1; 3210 1;
3211 3211
3212 __END__ 3212 __END__
3213 3213
3214 =head1 EXAMPLES 3214 =head1 EXAMPLES
3215 3215
3216 perl -MO=CC,-O2,-ofoo.c foo.pl 3216 perl -MO=CC,-O2,-ofoo.c foo.pl
3217 perl cc_harness -o foo foo.c 3217 perl cc_harness -o foo foo.c
3218 3218
3219 Note that C<cc_harness> lives in the C<B> subdirectory of your perl 3219 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
3220 library directory. The utility called C<perlcc> may also be used to 3220 library directory. The utility called C<perlcc> may also be used to
3221 help make use of this compiler. 3221 help make use of this compiler.
3222 3222
3223 # create a shared XS module 3223 # create a shared XS module
3224 perl -MO=CC,-mFoo,-oFoo.c Foo.pm 3224 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
3225 perl cc_harness -shared -c -o Foo.so Foo.c 3225 perl cc_harness -shared -c -o Foo.so Foo.c
3226 3226
3227 # side-effects just for the types and attributes 3227 # side-effects just for the types and attributes
3228 perl -MB::CC -e'my int $i:unsigned; ...' 3228 perl -MB::CC -e'my int $i:unsigned; ...'
3229 3229
3230 =head1 TYPES 3230 =head1 TYPES
3231 3231
3232 Implemented type classes are B<int> and B<double>. 3232 Implemented type classes are B<int> and B<double>.
3233 Planned is B<string> also. 3233 Planned is B<string> also.
3234 Implemented are only SCALAR types yet. 3234 Implemented are only SCALAR types yet.
3235 Typed arrays and hashes and perfect hashes need CORE and L<types> support first. 3235 Typed arrays and hashes and perfect hashes need CORE and L<types> support first.
3236 3236
3237 Deprecated are inferred types via the names of locals, with '_i', '_d' suffix 3237 Deprecated are inferred types via the names of locals, with '_i', '_d' suffix
3238 and an optional 'r' suffix for register allocation. 3238 and an optional 'r' suffix for register allocation.
3239 3239
3240 C<my ($i_i, $j_ir, $num_d);> 3240 C<my ($i_i, $j_ir, $num_d);>
3241 3241
3242 Planned type attributes are B<int>, B<double>, B<string>, 3242 Planned type attributes are B<int>, B<double>, B<string>,
3243 B<unsigned>, B<ro> / B<const>. 3243 B<unsigned>, B<ro> / B<const>.
3244 3244
3245 The attributes are perl attributes, and int|double|string are either 3245 The attributes are perl attributes, and int|double|string are either
3246 compiler classes or hints for more allowed types. 3246 compiler classes or hints for more allowed types.
3247 3247
3248 C<my int $i :double;> declares a NV with SVf_IOK. Same as C<my $i:int:double;> 3248 C<my int $i :double;> declares a NV with SVf_IOK. Same as C<my $i:int:double;>
3249 C<my int $i;> declares an IV. Same as C<my $i:int;> 3249 C<my int $i;> declares an IV. Same as C<my $i:int;>
3250 C<my int $i :string;> declares a PVIV. Same as C<my $i:int:string;> 3250 C<my int $i :string;> declares a PVIV. Same as C<my $i:int:string;>
3251 3251
3252 C<my int @array :unsigned = (0..4);> will be used as c var in faster arithmetic and cmp. 3252 C<my int @array :unsigned = (0..4);> will be used as c var in faster arithmetic and cmp.
3253 With :const or :ro even more. 3253 With :const or :ro even more.
3254 C<my string %hash :const 3254 C<my string %hash :const
3255 = (foo => 'foo', bar => 'bar');> declare string values, 3255 = (foo => 'foo', bar => 'bar');> declare string values,
3256 generate as read-only perfect hash. 3256 generate as read-only perfect hash.
3257 3257
3258 B<:unsigned> is valid for int only and declares an UV. 3258 B<:unsigned> is valid for int only and declares an UV.
3259 3259
3260 B<:register> denotes optionally a short and hot life-time. 3260 B<:register> denotes optionally a short and hot life-time.
3261 3261
3262 B<:temporary> are usually generated internally, nameless lexicals. 3262 B<:temporary> are usually generated internally, nameless lexicals.
3263 They are more aggressivly destroyed and ignored. 3263 They are more aggressivly destroyed and ignored.
3264 3264
3265 B<:ro> or B<:const> throw a compile-time error on write access and may optimize 3265 B<:ro> or B<:const> throw a compile-time error on write access and may optimize
3266 the internal structure of the variable. We don't need to write back the variable 3266 the internal structure of the variable. We don't need to write back the variable
3267 to perl (lexical write_back). 3267 to perl (lexical write_back).
3268 3268
3269 STATUS 3269 STATUS
3270 3270
3271 OK (classes only): 3271 OK (classes only):
3272 3272
3273 my int $i; 3273 my int $i;
3274 my double $d; 3274 my double $d;
3275 3275
3276 NOT YET OK (attributes): 3276 NOT YET OK (attributes):
3277 3277
3278 my int $i :register; 3278 my int $i :register;
3279 my $i :int; 3279 my $i :int;
3280 my $const :int:const; 3280 my $const :int:const;
3281 my $uv :int:unsigned; 3281 my $uv :int:unsigned;
3282 3282
3283 ISSUES 3283 ISSUES
3284 3284
3285 This does not work with pure perl, unless you C<use B::CC> or C<use types> or 3285 This does not work with pure perl, unless you C<use B::CC> or C<use types> or
3286 implement the classes and attribute type stubs in your code, 3286 implement the classes and attribute type stubs in your code,
3287 C<sub Mypkg::MODIFY_SCALAR_ATTRIBUTES {}> and C<sub Mypkg::FETCH_SCALAR_ATTRIBUTES {}>. 3287 C<sub Mypkg::MODIFY_SCALAR_ATTRIBUTES {}> and C<sub Mypkg::FETCH_SCALAR_ATTRIBUTES {}>.
3288 (TODO: empty should be enough to be detected by the compiler.) 3288 (TODO: empty should be enough to be detected by the compiler.)
3289 3289
3290 Compiled code pulls in the magic MODIFY_SCALAR_ATTRIBUTES and FETCH_SCALAR_ATTRIBUTES 3290 Compiled code pulls in the magic MODIFY_SCALAR_ATTRIBUTES and FETCH_SCALAR_ATTRIBUTES
3291 functions, even if they are used at compile time only. 3291 functions, even if they are used at compile time only.
3292 3292
3293 Using attributes adds an import block to your code. 3293 Using attributes adds an import block to your code.
3294 3294
3295 Only B<our> variable attributes are checked at compile-time, 3295 Only B<our> variable attributes are checked at compile-time,
3296 B<my> variables attributes at run-time only, which is too late for the compiler. 3296 B<my> variables attributes at run-time only, which is too late for the compiler.
3297 But only my variables can be typed, our not as they are typed automatically with 3297 But only my variables can be typed, our not as they are typed automatically with
3298 the defined package. 3298 the defined package.
3299 Perl attributes need to be fixed for types hints. 3299 Perl attributes need to be fixed for types hints.
3300 3300
3301 FUTURE 3301 FUTURE
3302 3302
3303 We should be able to support types on ARRAY and HASH. 3303 We should be able to support types on ARRAY and HASH.
3304 3304
3305 my int @array; # array of ints, faster magic-less access esp. in inlined arithmetic and cmp. 3305 my int @array; # array of ints, faster magic-less access esp. in inlined arithmetic and cmp.
3306 my string @array : readonly = qw(foo bar); # compile-time error on write. no lexical write_back 3306 my string @array : readonly = qw(foo bar); # compile-time error on write. no lexical write_back
3307 3307
3308 my int $hash = {"1" => 1, "2" => 2}; # int values, type-checked on write my 3308 my int $hash = {"1" => 1, "2" => 2}; # int values, type-checked on write my
3309 string %hash1 : readonly = (foo => 'bar');# string keys only => maybe gperf 3309 string %hash1 : readonly = (foo => 'bar');# string keys only => maybe gperf
3310 # compile-time error on write 3310 # compile-time error on write
3311 3311
3312 Typed hash keys are always strings, values are typed. 3312 Typed hash keys are always strings, values are typed.
3313 3313
3314 We should be also able to add type attributes for functions and methods, 3314 We should be also able to add type attributes for functions and methods,
3315 i.e. for argument and return types. See L<types> and 3315 i.e. for argument and return types. See L<types> and
3316 L<http://blogs.perl.org/users/rurban/2011/02/use-types.html> 3316 L<http://blogs.perl.org/users/rurban/2011/02/use-types.html>
3317 3317
3318 =head1 BUGS 3318 =head1 BUGS
3319 3319
3320 Plenty. Current status: experimental. 3320 Plenty. Current status: experimental.
3321 3321
3322 =head1 DIFFERENCES 3322 =head1 DIFFERENCES
3323 3323
3324 These aren't really bugs but they are constructs which are heavily 3324 These aren't really bugs but they are constructs which are heavily
3325 tied to perl's compile-and-go implementation and with which this 3325 tied to perl's compile-and-go implementation and with which this
3326 compiler backend cannot cope. 3326 compiler backend cannot cope.
3327 3327
3328 =head2 Loops 3328 =head2 Loops
3329 3329
3330 Standard perl calculates the target of "next", "last", and "redo" 3330 Standard perl calculates the target of "next", "last", and "redo"
3331 at run-time. The compiler calculates the targets at compile-time. 3331 at run-time. The compiler calculates the targets at compile-time.
3332 For example, the program 3332 For example, the program
3333 3333
3334 sub skip_on_odd { next NUMBER if $_[0] % 2 } 3334 sub skip_on_odd { next NUMBER if $_[0] % 2 }
3335 NUMBER: for ($i = 0; $i < 5; $i++) { 3335 NUMBER: for ($i = 0; $i < 5; $i++) {
3336 skip_on_odd($i); 3336 skip_on_odd($i);
3337 print $i; 3337 print $i;
3338 } 3338 }
3339 3339
3340 produces the output 3340 produces the output
3341 3341
3342 024 3342 024
3343 3343
3344 with standard perl but calculates with the compiler the 3344 with standard perl but calculates with the compiler the
3345 goto label_NUMBER wrong, producing 01234. 3345 goto label_NUMBER wrong, producing 01234.
3346 3346
3347 =head2 Context of ".." 3347 =head2 Context of ".."
3348 3348
3349 The context (scalar or array) of the ".." operator determines whether 3349 The context (scalar or array) of the ".." operator determines whether
3350 it behaves as a range or a flip/flop. Standard perl delays until 3350 it behaves as a range or a flip/flop. Standard perl delays until
3351 runtime the decision of which context it is in but the compiler needs 3351 runtime the decision of which context it is in but the compiler needs
3352 to know the context at compile-time. For example, 3352 to know the context at compile-time. For example,
3353 3353
3354 @a = (4,6,1,0,0,1); 3354 @a = (4,6,1,0,0,1);
3355 sub range { (shift @a)..(shift @a) } 3355 sub range { (shift @a)..(shift @a) }
3356 print range(); 3356 print range();
3357 while (@a) { print scalar(range()) } 3357 while (@a) { print scalar(range()) }
3358 3358
3359 generates the output 3359 generates the output
3360 3360
3361 456123E0 3361 456123E0
3362 3362
3363 with standard Perl but gives a run-time warning with compiled Perl. 3363 with standard Perl but gives a run-time warning with compiled Perl.
3364 3364
3365 If the option B<-strict> is used it gives a compile-time error. 3365 If the option B<-strict> is used it gives a compile-time error.
3366 3366
3367 =head2 Arithmetic 3367 =head2 Arithmetic
3368 3368
3369 Compiled Perl programs use native C arithmetic much more frequently 3369 Compiled Perl programs use native C arithmetic much more frequently
3370 than standard perl. Operations on large numbers or on boundary 3370 than standard perl. Operations on large numbers or on boundary
3371 cases may produce different behaviour. 3371 cases may produce different behaviour.
3372 In doubt B::CC code behaves more like with C<use integer>. 3372 In doubt B::CC code behaves more like with C<use integer>.
3373 3373
3374 =head2 Deprecated features 3374 =head2 Deprecated features
3375 3375
3376 Features of standard perl such as C<$[> which have been deprecated 3376 Features of standard perl such as C<$[> which have been deprecated
3377 in standard perl since Perl5 was released have not been implemented 3377 in standard perl since Perl5 was released have not been implemented
3378 in the compiler. 3378 in the compiler.
3379 3379
3380 =head1 AUTHORS 3380 =head1 AUTHORS
3381 3381
3382 Malcolm Beattie C<MICB at cpan.org> I<(1996-1998, retired)>, 3382 Malcolm Beattie C<MICB at cpan.org> I<(1996-1998, retired)>,
3383 Vishal Bhatia <vishal at deja.com> I(1999), 3383 Vishal Bhatia <vishal at deja.com> I(1999),
3384 Gurusamy Sarathy <gsar@cpan.org> I(1998-2001), 3384 Gurusamy Sarathy <gsar@cpan.org> I(1998-2001),
3385 Reini Urban C<perl-compiler@googlegroups.com> I(2008-), 3385 Reini Urban C<perl-compiler@googlegroups.com> I(2008-),
3386 Heinz Knutzen C<heinz.knutzen at gmx.de> I(2010) 3386 Heinz Knutzen C<heinz.knutzen at gmx.de> I(2010)
3387 3387
3388 =cut 3388 =cut
3389 3389
3390 # Local Variables: 3390 # Local Variables:
3391 # mode: cperl 3391 # mode: cperl
3392 # cperl-indent-level: 2 3392 # cperl-indent-level: 2
3393 # fill-column: 78 3393 # fill-column: 78
3394 # End: 3394 # End:
3395 # vim: expandtab shiftwidth=2: 3395 # vim: expandtab shiftwidth=2:
Powered by Google Project Hosting