My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
Changes to /lib/B/CC.pm
65bcba36d348 vs. 12359ce68210 Compare: vs.  Format:
Revision 12359ce68210
Go to: 
Project members, sign in to write a code review
/lib/B/CC.pm   65bcba36d348 /lib/B/CC.pm   12359ce68210
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"
708 if $debug{shadow};
707 return unless @stack; 709 return unless @stack;
708 runtime( sprintf( "EXTEND(sp, %d);", scalar(@stack) ) ); 710 runtime( sprintf( "EXTEND(sp, %d);", scalar(@stack) ) );
709 # return unless @stack;
710 foreach my $obj (@stack) { 711 foreach my $obj (@stack) {
711 runtime( sprintf( "PUSHs((SV*)%s);", $obj->as_sv ) ); 712 runtime( sprintf( "PUSHs((SV*)%s);", $obj->as_sv ) );
712 } 713 }
713 @stack = (); 714 @stack = ();
714 } 715 }
715 716
716 sub invalidate_lexicals { 717 sub invalidate_lexicals {
717 my $avoid = shift || 0; 718 my $avoid = shift || 0;
718 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" 719 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
719 if $debug{shadow}; 720 if $debug{shadow};
720 my $lex; 721 my $lex;
721 foreach $lex (@pad) { 722 foreach $lex (@pad) {
722 next unless ref($lex); 723 next unless ref($lex);
723 $lex->invalidate unless $lex->{flags} & $avoid; 724 $lex->invalidate unless $lex->{flags} & $avoid;
724 } 725 }
725 } 726 }
726 727
727 sub reload_lexicals { 728 sub reload_lexicals {
728 my $lex; 729 my $lex;
729 foreach $lex (@pad) { 730 foreach $lex (@pad) {
730 next unless ref($lex); 731 next unless ref($lex);
731 my $type = $lex->{type}; 732 my $type = $lex->{type};
732 if ( $type == T_INT ) { 733 if ( $type == T_INT ) {
733 $lex->as_int; 734 $lex->as_int;
734 } 735 }
735 elsif ( $type == T_DOUBLE ) { 736 elsif ( $type == T_DOUBLE ) {
736 $lex->as_double; 737 $lex->as_double;
737 } 738 }
738 else { 739 else {
739 $lex->as_sv; 740 $lex->as_sv;
740 } 741 }
741 } 742 }
742 } 743 }
743 744
744 { 745 {
745 746
746 package B::Pseudoreg; 747 package B::Pseudoreg;
747 748
748 # 749 #
749 # This class allocates pseudo-registers (OK, so they're C variables). 750 # This class allocates pseudo-registers (OK, so they're C variables).
750 # 751 #
751 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
752 # variable has been declared. A value of 2 means 753 # variable has been declared. A value of 2 means
753 # it's in use. 754 # it's in use.
754 755
755 sub new_scope { %alloc = () } 756 sub new_scope { %alloc = () }
756 757
757 sub new ($$$) { 758 sub new ($$$) {
758 my ( $class, $type, $prefix ) = @_; 759 my ( $class, $type, $prefix ) = @_;
759 my ( $ptr, $i, $varname, $status, $obj ); 760 my ( $ptr, $i, $varname, $status, $obj );
760 $prefix =~ s/^(\**)//; 761 $prefix =~ s/^(\**)//;
761 $ptr = $1; 762 $ptr = $1;
762 $i = 0; 763 $i = 0;
763 do { 764 do {
764 $varname = "$prefix$i"; 765 $varname = "$prefix$i";
765 $status = $alloc{$varname}; 766 $status = $alloc{$varname};
766 } while $status == 2; 767 } while $status == 2;
767 if ( $status != 1 ) { 768 if ( $status != 1 ) {
768 769
769 # Not declared yet 770 # Not declared yet
770 B::CC::declare( $type, "$ptr$varname" ); 771 B::CC::declare( $type, "$ptr$varname" );
771 $alloc{$varname} = 2; # declared and in use 772 $alloc{$varname} = 2; # declared and in use
772 } 773 }
773 $obj = bless \$varname, $class; 774 $obj = bless \$varname, $class;
774 return $obj; 775 return $obj;
775 } 776 }
776 777
777 sub DESTROY { 778 sub DESTROY {
778 my $obj = shift; 779 my $obj = shift;
779 $alloc{$$obj} = 1; # no longer in use but still declared 780 $alloc{$$obj} = 1; # no longer in use but still declared
780 } 781 }
781 } 782 }
782 { 783 {
783 784
784 package B::Shadow; 785 package B::Shadow;
785 786
786 # 787 #
787 # 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
788 # C variable and only generate reloads/write-backs when necessary. 789 # C variable and only generate reloads/write-backs when necessary.
789 # 790 #
790 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). 791 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
791 # 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.
792 # Use $obj->invalidate whenever an unknown function may have 793 # Use $obj->invalidate whenever an unknown function may have
793 # set shadow itself. 794 # set shadow itself.
794 795
795 sub new { 796 sub new {
796 my ( $class, $write_back ) = @_; 797 my ( $class, $write_back ) = @_;
797 798
798 # Object fields are perl shadow variable, validity flag 799 # Object fields are perl shadow variable, validity flag
799 # (for *C* variable) and callback sub for write_back 800 # (for *C* variable) and callback sub for write_back
800 # (passed perl shadow variable as argument). 801 # (passed perl shadow variable as argument).
801 bless [ undef, 1, $write_back ], $class; 802 bless [ undef, 1, $write_back ], $class;
802 } 803 }
803 804
804 sub load { 805 sub load {
805 my ( $obj, $newval ) = @_; 806 my ( $obj, $newval ) = @_;
806 $obj->[1] = 0; # C variable no longer valid 807 $obj->[1] = 0; # C variable no longer valid
807 $obj->[0] = $newval; 808 $obj->[0] = $newval;
808 } 809 }
809 810
810 sub write_back { 811 sub write_back {
811 my $obj = shift; 812 my $obj = shift;
812 if ( !( $obj->[1] ) ) { 813 if ( !( $obj->[1] ) ) {
813 $obj->[1] = 1; # C variable will now be valid 814 $obj->[1] = 1; # C variable will now be valid
814 &{ $obj->[2] }( $obj->[0] ); 815 &{ $obj->[2] }( $obj->[0] );
815 } 816 }
816 } 817 }
817 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid 818 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
818 } 819 }
819 820
820 my $curcop = B::Shadow->new( 821 my $curcop = B::Shadow->new(
821 sub { 822 sub {
822 my $opsym = shift->save; 823 my $opsym = shift->save;
823 runtime("PL_curcop = (COP*)$opsym;"); 824 runtime("PL_curcop = (COP*)$opsym;");
824 } 825 }
825 ); 826 );
826 827
827 # 828 #
828 # 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.
829 # 830 #
830 sub dopoptoloop { 831 sub dopoptoloop {
831 my $cxix = $#cxstack; 832 my $cxix = $#cxstack;
832 while ( $cxix >= 0 && CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 833 while ( $cxix >= 0 && CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
833 $cxix--; 834 $cxix--;
834 } 835 }
835 debug "dopoptoloop: returning $cxix" if $debug{cxstack}; 836 debug "dopoptoloop: returning $cxix" if $debug{cxstack};
836 return $cxix; 837 return $cxix;
837 } 838 }
838 839
839 sub dopoptolabel { 840 sub dopoptolabel {
840 my $label = shift; 841 my $label = shift;
841 my $cxix = $#cxstack; 842 my $cxix = $#cxstack;
842 while ( 843 while (
843 $cxix >= 0 844 $cxix >= 0
844 && ( CxTYPE_no_LOOP( $cxstack[$cxix] ) 845 && ( CxTYPE_no_LOOP( $cxstack[$cxix] )
845 || $cxstack[$cxix]->{label} ne $label ) 846 || $cxstack[$cxix]->{label} ne $label )
846 ) 847 )
847 { 848 {
848 $cxix--; 849 $cxix--;
849 } 850 }
850 debug "dopoptolabel: returning $cxix\n" if $debug{cxstack}; 851 debug "dopoptolabel: returning $cxix\n" if $debug{cxstack};
851 if ($cxix < 0 and $debug{cxstack}) { 852 if ($cxix < 0 and $debug{cxstack}) {
852 for my $cx (0 .. $#cxstack) { 853 for my $cx (0 .. $#cxstack) {
853 debug "$cx: ",$cxstack[$cx]->{label},"\n"; 854 debug "$cx: ",$cxstack[$cx]->{label},"\n";
854 } 855 }
855 for my $op (keys %{$labels->{label}}) { 856 for my $op (keys %{$labels->{label}}) {
856 debug $labels->{label}->{$op},"\n"; 857 debug $labels->{label}->{$op},"\n";
857 } 858 }
858 } 859 }
859 return $cxix; 860 return $cxix;
860 } 861 }
861 862
862 sub push_label { 863 sub push_label {
863 my $op = shift; 864 my $op = shift;
864 my $type = shift; 865 my $type = shift;
865 push @{$labels->{$type}}, ( $op ); 866 push @{$labels->{$type}}, ( $op );
866 } 867 }
867 868
868 sub pop_label { 869 sub pop_label {
869 my $type = shift; 870 my $type = shift;
870 my $op = pop @{$labels->{$type}}; 871 my $op = pop @{$labels->{$type}};
871 write_label ($op); # avoids duplicate labels 872 write_label ($op); # avoids duplicate labels
872 } 873 }
873 874
874 sub error { 875 sub error {
875 my $format = shift; 876 my $format = shift;
876 my $file = $curcop->[0]->file; 877 my $file = $curcop->[0]->file;
877 my $line = $curcop->[0]->line; 878 my $line = $curcop->[0]->line;
878 $errors++; 879 $errors++;
879 if (@_) { 880 if (@_) {
880 warn sprintf( "ERROR at %s:%d: $format\n", $file, $line, @_ ); 881 warn sprintf( "ERROR at %s:%d: $format\n", $file, $line, @_ );
881 } 882 }
882 else { 883 else {
883 warn sprintf( "ERROR at %s:%d: %s\n", $file, $line, $format ); 884 warn sprintf( "ERROR at %s:%d: %s\n", $file, $line, $format );
884 } 885 }
885 } 886 }
886 887
887 # 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.
888 # 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.
889 # 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.
890 sub init_type_attrs { 891 sub init_type_attrs {
891 eval q[ 892 eval q[
892 893
893 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)$';
894 sub MODIFY_SCALAR_ATTRIBUTES { 895 sub MODIFY_SCALAR_ATTRIBUTES {
895 my $pkg = shift; 896 my $pkg = shift;
896 my $v = shift; 897 my $v = shift;
897 my $attr = $B::CC::valid_attr; 898 my $attr = $B::CC::valid_attr;
898 $attr =~ s/\b$pkg\b//; 899 $attr =~ s/\b$pkg\b//;
899 if (my @bad = grep !/$attr/, @_) { 900 if (my @bad = grep !/$attr/, @_) {
900 return @bad; 901 return @bad;
901 } else { 902 } else {
902 no strict 'refs'; 903 no strict 'refs';
903 push @{"$pkg\::$v\::attributes"}, @_; # create a magic glob 904 push @{"$pkg\::$v\::attributes"}, @_; # create a magic glob
904 return (); 905 return ();
905 } 906 }
906 } 907 }
907 sub FETCH_SCALAR_ATTRIBUTES { 908 sub FETCH_SCALAR_ATTRIBUTES {
908 my ($pkg, $v) = @_; 909 my ($pkg, $v) = @_;
909 no strict 'refs'; 910 no strict 'refs';
910 return @{"$pkg\::$v\::attributes"}; 911 return @{"$pkg\::$v\::attributes"};
911 } 912 }
912 913
913 # 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
914 *main::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 915 *main::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
915 *main::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 916 *main::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
916 917
917 # my int $i : register : ro; 918 # my int $i : register : ro;
918 *int::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 919 *int::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
919 *int::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 920 *int::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
920 921
921 # my double $d : ro; 922 # my double $d : ro;
922 *double::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 923 *double::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
923 *double::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 924 *double::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
924 925
925 *string::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES; 926 *string::MODIFY_SCALAR_ATTRIBUTES = \&B::CC::MODIFY_SCALAR_ATTRIBUTES;
926 *string::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES; 927 *string::FETCH_SCALAR_ATTRIBUTES = \&B::CC::FETCH_SCALAR_ATTRIBUTES;
927 ]; 928 ];
928 929
929 } 930 }
930 931
931 =head2 load_pad 932 =head2 load_pad
932 933
933 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
934 with Stackobj-derived objects which represent those lexicals. 935 with Stackobj-derived objects which represent those lexicals.
935 936
936 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
937 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>
938 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.
939 940
940 =cut 941 =cut
941 942
942 sub load_pad { 943 sub load_pad {
943 my ( $namelistav, $valuelistav ) = @_; 944 my ( $namelistav, $valuelistav ) = @_;
944 @padlist = @_; 945 @padlist = @_;
945 my @namelist = $namelistav->ARRAY; 946 my @namelist = $namelistav->ARRAY;
946 my @valuelist = $valuelistav->ARRAY; 947 my @valuelist = $valuelistav->ARRAY;
947 my $ix; 948 my $ix;
948 @pad = (); 949 @pad = ();
949 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug{pad}; 950 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug{pad};
950 951
951 # 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
952 # 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
953 # @valuelist but index into @namelist for the name. Any temporaries which 954 # @valuelist but index into @namelist for the name. Any temporaries which
954 # 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
955 # 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.
956 # [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.]
957 for ( $ix = 1 ; $ix < @valuelist ; $ix++ ) { 958 for ( $ix = 1 ; $ix < @valuelist ; $ix++ ) {
958 my $namesv = $namelist[$ix]; 959 my $namesv = $namelist[$ix];
959 my $type = T_UNKNOWN; 960 my $type = T_UNKNOWN;
960 my $flags = 0; 961 my $flags = 0;
961 my $name = "tmp"; 962 my $name = "tmp";
962 my $class = class($namesv); 963 my $class = class($namesv);
963 if ( !defined($namesv) || $class eq "SPECIAL" ) { 964 if ( !defined($namesv) || $class eq "SPECIAL" ) {
964 # 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
965 $flags = VALID_SV | TEMPORARY | REGISTER; 966 $flags = VALID_SV | TEMPORARY | REGISTER;
966 } 967 }
967 else { 968 else {
968 my ($nametry) = $namesv->PV =~ /^\$(.+)$/ if $namesv->PV; 969 my ($nametry) = $namesv->PV =~ /^\$(.+)$/ if $namesv->PV;
969 $name = $nametry if $nametry; 970 $name = $nametry if $nametry;
970 971
971 # 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.
972 # 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
973 # compiled in Perl also. 974 # compiled in Perl also.
974 # 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.
975 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
976 $class = $namesv->SvSTASH->NAME; 977 $class = $namesv->SvSTASH->NAME;
977 if ($class eq 'int') { 978 if ($class eq 'int') {
978 $type = T_INT; 979 $type = T_INT;
979 $flags = VALID_SV | VALID_INT; 980 $flags = VALID_SV | VALID_INT;
980 } 981 }
981 elsif ($class eq 'double') { # my double 982 elsif ($class eq 'double') { # my double
982 $type = T_DOUBLE; 983 $type = T_DOUBLE;
983 $flags = VALID_SV | VALID_DOUBLE; 984 $flags = VALID_SV | VALID_DOUBLE;
984 } 985 }
985 #elsif ($class eq 'c_int') { # use Ctypes; 986 #elsif ($class eq 'c_int') { # use Ctypes;
986 # $type = T_INT; 987 # $type = T_INT;
987 # $flags = VALID_SV | VALID_INT; 988 # $flags = VALID_SV | VALID_INT;
988 #} 989 #}
989 #elsif ($class eq 'c_double') { 990 #elsif ($class eq 'c_double') {
990 # $type = T_DOUBLE; 991 # $type = T_DOUBLE;
991 # $flags = VALID_SV | VALID_DOUBLE; 992 # $flags = VALID_SV | VALID_DOUBLE;
992 #} 993 #}
993 # TODO: MooseX::Types 994 # TODO: MooseX::Types
994 } 995 }
995 996
996 # Valid scalar type attributes: 997 # Valid scalar type attributes:
997 # int double string ro readonly const unsigned 998 # int double string ro readonly const unsigned
998 # Note: PVMG from above also. 999 # Note: PVMG from above also.
999 # Typed arrays and hashes later. 1000 # Typed arrays and hashes later.
1000 if (0 and $class =~ /^(I|P|S|N)V/ 1001 if (0 and $class =~ /^(I|P|S|N)V/
1001 and $type_attr 1002 and $type_attr
1002 and UNIVERSAL::can($class,"CHECK_SCALAR_ATTRIBUTES")) # with 5.18 1003 and UNIVERSAL::can($class,"CHECK_SCALAR_ATTRIBUTES")) # with 5.18
1003 { 1004 {
1004 require attributes; 1005 require attributes;
1005 #my $svtype = uc reftype ($namesv); 1006 #my $svtype = uc reftype ($namesv);
1006 # test 105 1007 # test 105
1007 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
1008 warn "\$$name attrs: ".@attr if $verbose or $debug{pad}; 1009 warn "\$$name attrs: ".@attr if $verbose or $debug{pad};
1009 #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.
1010 } 1011 }
1011 1012
1012 # XXX We should try Devel::TypeCheck for type inference also 1013 # XXX We should try Devel::TypeCheck for type inference also
1013 1014
1014 # 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
1015 if ( $type == T_UNKNOWN and $name_magic and $name =~ /^(.*)_([di])(r?)$/ ) { 1016 if ( $type == T_UNKNOWN and $name_magic and $name =~ /^(.*)_([di])(r?)$/ ) {
1016 $name = $1; 1017 $name = $1;
1017 if ( $2 eq "i" ) { 1018 if ( $2 eq "i" ) {
1018 $type = T_INT; 1019 $type = T_INT;
1019 $flags = VALID_SV | VALID_INT; 1020 $flags = VALID_SV | VALID_INT;
1020 } 1021 }
1021 elsif ( $2 eq "d" ) { 1022 elsif ( $2 eq "d" ) {
1022 $type = T_DOUBLE; 1023 $type = T_DOUBLE;
1023 $flags = VALID_SV | VALID_DOUBLE; 1024 $flags = VALID_SV | VALID_DOUBLE;
1024 } 1025 }
1025 $flags |= REGISTER if $3; 1026 $flags |= REGISTER if $3;
1026 } 1027 }
1027 } 1028 }
1028 $name = "${ix}_$name"; 1029 $name = "${ix}_$name";
1029 $pad[$ix] = 1030 $pad[$ix] =
1030 B::Stackobj::Padsv->new( $type, $flags, $ix, "i$name", "d$name" ); 1031 B::Stackobj::Padsv->new( $type, $flags, $ix, "i$name", "d$name" );
1031 1032
1032 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};
1033 } 1034 }
1034 } 1035 }
1035 1036
1036 sub declare_pad { 1037 sub declare_pad {
1037 my $ix; 1038 my $ix;
1038 for ( $ix = 1 ; $ix <= $#pad ; $ix++ ) { 1039 for ( $ix = 1 ; $ix <= $#pad ; $ix++ ) {
1039 my $type = $pad[$ix]->{type}; 1040 my $type = $pad[$ix]->{type};
1040 declare( "IV", 1041 declare( "IV",
1041 $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} )
1042 if $pad[$ix]->save_int; 1043 if $pad[$ix]->save_int;
1043 declare( "double", 1044 declare( "double",
1044 $type == T_DOUBLE 1045 $type == T_DOUBLE
1045 ? sprintf( "%s = 0", $pad[$ix]->{nv} ) 1046 ? sprintf( "%s = 0", $pad[$ix]->{nv} )
1046 : $pad[$ix]->{nv} ) 1047 : $pad[$ix]->{nv} )
1047 if $pad[$ix]->save_double; 1048 if $pad[$ix]->save_double;
1048 1049
1049 } 1050 }
1050 } 1051 }
1051 1052
1052 # 1053 #
1053 # Debugging stuff 1054 # Debugging stuff
1054 # 1055 #
1055 sub peek_stack { 1056 sub peek_stack {
1056 sprintf "stack = %s\n", join( " ", map( $_->minipeek, @stack ) ); 1057 sprintf "stack = %s\n", join( " ", map( $_->minipeek, @stack ) );
1057 } 1058 }
1058 1059
1059 # 1060 #
1060 # OP stuff 1061 # OP stuff
1061 # 1062 #
1062 1063
1063 =head2 label 1064 =head2 label
1064 1065
1065 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_".
1066 1067
1067 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
1068 (forward jumps) for compile-time generated branch points, with the "lab_" 1069 (forward jumps) for compile-time generated branch points, with the "lab_"
1069 prefix. 1070 prefix.
1070 1071
1071 =cut 1072 =cut
1072 1073
1073 sub label { 1074 sub label {
1074 my $op = shift; 1075 my $op = shift;
1075 # Preserve original label name for "real" labels 1076 # Preserve original label name for "real" labels
1076 if ($op->can("label") and $op->label) { 1077 if ($op->can("label") and $op->label) {
1077 # cc should error on duplicate named labels 1078 # cc should error on duplicate named labels
1078 return sprintf( "label_%s_%x", $op->label, $$op); 1079 return sprintf( "label_%s_%x", $op->label, $$op);
1079 } else { 1080 } else {
1080 return sprintf( "lab_%x", $$op ); 1081 return sprintf( "lab_%x", $$op );
1081 } 1082 }
1082 } 1083 }
1083 1084
1084 sub write_label { 1085 sub write_label {
1085 my $op = shift; 1086 my $op = shift;
1086 # debug sprintf("lab_%x:?\n", $$op) if $debug{cxstack}; 1087 # debug sprintf("lab_%x:?\n", $$op) if $debug{cxstack};
1087 unless ($labels->{label}->{$$op}) { 1088 unless ($labels->{label}->{$$op}) {
1088 my $l = label($op); 1089 my $l = label($op);
1089 # named label but op not yet known? 1090 # named label but op not yet known?
1090 if ( $op->can("label") and $op->label ) { 1091 if ( $op->can("label") and $op->label ) {
1091 $l = "label_".$op->label; 1092 $l = "label_".$op->label;
1092 # only print first such label. test 21 1093 # only print first such label. test 21
1093 push_runtime(sprintf( " %s:", $l)) 1094 push_runtime(sprintf( " %s:", $l))
1094 unless $labels->{label}->{$l}; 1095 unless $labels->{label}->{$l};
1095 $labels->{label}->{$l} = $$op; 1096 $labels->{label}->{$l} = $$op;
1096 } 1097 }
1097 if ($verbose) { 1098 if ($verbose) {
1098 push_runtime(sprintf( " %s:\t/* %s */", label($op), $op->name )); 1099 push_runtime(sprintf( " %s:\t/* %s */", label($op), $op->name ));
1099 } else { 1100 } else {
1100 push_runtime(sprintf( " %s:", label($op) )); 1101 push_runtime(sprintf( " %s:", label($op) ));
1101 } 1102 }
1102 # avoid printing duplicate jump labels 1103 # avoid printing duplicate jump labels
1103 $labels->{label}->{$$op} = $l; 1104 $labels->{label}->{$$op} = $l;
1104 if ($op->can("label") and $op->label ) { 1105 if ($op->can("label") and $op->label ) {
1105 push(@cxstack, { 1106 push(@cxstack, {
1106 type => 0, 1107 type => 0,
1107 op => $op, 1108 op => $op,
1108 nextop => ((ref($op) eq 'B::LOOP') && $op->nextop) ? $op->nextop : $op, 1109 nextop => ((ref($op) eq 'B::LOOP') && $op->nextop) ? $op->nextop : $op,
1109 redoop => ((ref($op) eq 'B::LOOP') && $op->redoop) ? $op->redoop : $op, 1110 redoop => ((ref($op) eq 'B::LOOP') && $op->redoop) ? $op->redoop : $op,
1110 lastop => ((ref($op) eq 'B::LOOP') && $op->lastop) ? $op->lastop : $op, 1111 lastop => ((ref($op) eq 'B::LOOP') && $op->lastop) ? $op->lastop : $op,
1111 'label' => $op->can("label") && $op->label ? $op->label : $l 1112 'label' => $op->can("label") && $op->label ? $op->label : $l
1112 }); 1113 });
1113 } 1114 }
1114 } 1115 }
1115 } 1116 }
1116 1117
1117 sub loadop { 1118 sub loadop {
1118 my $op = shift; 1119 my $op = shift;
1119 my $opsym = $op->save; 1120 my $opsym = $op->save;
1120 $op_count++; # for statistics 1121 $op_count++; # for statistics
1121 runtime("PL_op = $opsym;") unless $know_op; 1122 runtime("PL_op = $opsym;") unless $know_op;
1122 return $opsym; 1123 return $opsym;
1123 } 1124 }
1124 1125
1125 sub doop { 1126 sub doop {
1126 my $op = shift; 1127 my $op = shift;
1127 my $ppaddr = $op->ppaddr; 1128 my $ppaddr = $op->ppaddr;
1128 my $sym = loadop($op); 1129 my $sym = loadop($op);
1129 my $ppname = "pp_" . $op->name; 1130 my $ppname = "pp_" . $op->name;
1130 if ($inline_ops) { 1131 if ($inline_ops) {
1131 # inlining direct calls is safe, just CALLRUNOPS for macros not 1132 # inlining direct calls is safe, just CALLRUNOPS for macros not
1132 $ppaddr = "Perl_".$ppname; 1133 $ppaddr = "Perl_".$ppname;
1133 $no_stack{$ppname} 1134 $no_stack{$ppname}
1134 ? runtime("PL_op = $ppaddr(aTHX);") 1135 ? runtime("PL_op = $ppaddr(aTHX);")
1135 : runtime("PUTBACK; PL_op = $ppaddr(aTHX); SPAGAIN;"); 1136 : runtime("PUTBACK; PL_op = $ppaddr(aTHX); SPAGAIN;");
1136 } else { 1137 } else {
1137 $no_stack{$ppname} 1138 $no_stack{$ppname}
1138 ? runtime("PL_op = $ppaddr(aTHX);") 1139 ? runtime("PL_op = $ppaddr(aTHX);")
1139 : runtime("DOOP($ppaddr);"); 1140 : runtime("DOOP($ppaddr);");
1140 } 1141 }
1141 $know_op = 1; 1142 $know_op = 1;
1142 return $sym; 1143 return $sym;
1143 } 1144 }
1144 1145
1145 sub gimme { 1146 sub gimme {
1146 my $op = shift; 1147 my $op = shift;
1147 my $want = $op->flags & OPf_WANT; 1148 my $want = $op->flags & OPf_WANT;
1148 return ( $want == OPf_WANT_VOID ? G_VOID : 1149 return ( $want == OPf_WANT_VOID ? G_VOID :
1149 $want == OPf_WANT_SCALAR ? G_SCALAR : 1150 $want == OPf_WANT_SCALAR ? G_SCALAR :
1150 $want == OPf_WANT_LIST ? G_ARRAY : 1151 $want == OPf_WANT_LIST ? G_ARRAY :
1151 undef ); 1152 undef );
1152 } 1153 }
1153 1154
1154 # 1155 #
1155 # Code generation for PP code 1156 # Code generation for PP code
1156 # 1157 #
1157 1158
1158 # coverage: 18,19,25,... 1159 # coverage: 18,19,25,...
1159 sub pp_null { 1160 sub pp_null {
1160 my $op = shift; 1161 my $op = shift;
1161 $B::C::nullop_count++; 1162 $B::C::nullop_count++;
1162 return $op->next; 1163 return $op->next;
1163 } 1164 }
1164 1165
1165 # coverage: 102 1166 # coverage: 102
1166 sub pp_stub { 1167 sub pp_stub {
1167 my $op = shift; 1168 my $op = shift;
1168 my $gimme = gimme($op); 1169 my $gimme = gimme($op);
1169 if ( not defined $gimme ) { 1170 if ( not defined $gimme ) {
1170 write_back_stack(); 1171 write_back_stack();
1171 runtime("if (block_gimme() == G_SCALAR)", 1172 runtime("if (block_gimme() == G_SCALAR)",
1172 "\tXPUSHs(&PL_sv_undef);"); 1173 "\tXPUSHs(&PL_sv_undef);");
1173 } elsif ( $gimme == G_SCALAR ) { 1174 } elsif ( $gimme == G_SCALAR ) {
1174 my $obj = B::Stackobj::Const->new(sv_undef); 1175 my $obj = B::Stackobj::Const->new(sv_undef);
1175 push( @stack, $obj ); 1176 push( @stack, $obj );
1176 } 1177 }
1177 return $op->next; 1178 return $op->next;
1178 } 1179 }
1179 1180
1180 # coverage: 2,21,28,30 1181 # coverage: 2,21,28,30
1181 sub pp_unstack { 1182 sub pp_unstack {
1182 my $op = shift; 1183 my $op = shift;
1183 @stack = (); 1184 @stack = ();
1184 runtime("PP_UNSTACK;"); 1185 runtime("PP_UNSTACK;");
1185 return $op->next; 1186 return $op->next;
1186 } 1187 }
1187 1188
1188 # coverage: 2,21,27,28,30 1189 # coverage: 2,21,27,28,30
1189 sub pp_and { 1190 sub pp_and {
1190 my $op = shift; 1191 my $op = shift;
1191 my $next = $op->next; 1192 my $next = $op->next;
1192 reload_lexicals(); 1193 reload_lexicals();
1193 unshift( @bblock_todo, $next ); 1194 unshift( @bblock_todo, $next );
1194 if ( @stack >= 1 ) { 1195 if ( @stack >= 1 ) {
1195 my $obj = pop @stack; 1196 my $obj = pop @stack;
1196 my $bool = $obj->as_bool; 1197 my $bool = $obj->as_bool;
1197 write_back_stack(); 1198 write_back_stack();
1198 save_or_restore_lexical_state($$next); 1199 save_or_restore_lexical_state($$next);
1199 runtime( 1200 runtime(
1200 sprintf( 1201 sprintf(
1201 "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)
1202 ) 1203 )
1203 ); 1204 );
1204 } 1205 }
1205 else { 1206 else {
1206 save_or_restore_lexical_state($$next); 1207 save_or_restore_lexical_state($$next);
1207 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ), 1208 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ),
1208 "*sp--;" ); 1209 "*sp--;" );
1209 } 1210 }
1210 return $op->other; 1211 return $op->other;
1211 } 1212 }
1212 1213
1213 # Nearly identical to pp_and, but leaves stack unchanged. 1214 # Nearly identical to pp_and, but leaves stack unchanged.
1214 sub pp_andassign { 1215 sub pp_andassign {
1215 my $op = shift; 1216 my $op = shift;
1216 my $next = $op->next; 1217 my $next = $op->next;
1217 reload_lexicals(); 1218 reload_lexicals();
1218 unshift( @bblock_todo, $next ); 1219 unshift( @bblock_todo, $next );
1219 if ( @stack >= 1 ) { 1220 if ( @stack >= 1 ) {
1220 my $obj = pop @stack; 1221 my $obj = pop @stack;
1221 my $bool = $obj->as_bool; 1222 my $bool = $obj->as_bool;
1222 write_back_stack(); 1223 write_back_stack();
1223 save_or_restore_lexical_state($$next); 1224 save_or_restore_lexical_state($$next);
1224 runtime( 1225 runtime(
1225 sprintf( 1226 sprintf(
1226 "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)
1227 ) 1228 )
1228 ); 1229 );
1229 } 1230 }
1230 else { 1231 else {
1231 save_or_restore_lexical_state($$next); 1232 save_or_restore_lexical_state($$next);
1232 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ) ); 1233 runtime( sprintf( "if (!%s) goto %s;", top_bool(), label($next) ) );
1233 } 1234 }
1234 return $op->other; 1235 return $op->other;
1235 } 1236 }
1236 1237
1237 # coverage: 28 1238 # coverage: 28
1238 sub pp_or { 1239 sub pp_or {
1239 my $op = shift; 1240 my $op = shift;
1240 my $next = $op->next; 1241 my $next = $op->next;
1241 reload_lexicals(); 1242 reload_lexicals();
1242 unshift( @bblock_todo, $next ); 1243 unshift( @bblock_todo, $next );
1243 if ( @stack >= 1 ) { 1244 if ( @stack >= 1 ) {
1244 my $obj = pop @stack; 1245 my $obj = pop @stack;
1245 my $bool = $obj->as_bool; 1246 my $bool = $obj->as_bool;
1246 write_back_stack(); 1247 write_back_stack();
1247 save_or_restore_lexical_state($$next); 1248 save_or_restore_lexical_state($$next);
1248 runtime( 1249 runtime(
1249 sprintf( 1250 sprintf(
1250 "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)
1251 ) 1252 )
1252 ); 1253 );
1253 } 1254 }
1254 else { 1255 else {
1255 save_or_restore_lexical_state($$next); 1256 save_or_restore_lexical_state($$next);
1256 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ), 1257 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ),
1257 "*sp--;" ); 1258 "*sp--;" );
1258 } 1259 }
1259 return $op->other; 1260 return $op->other;
1260 } 1261 }
1261 1262
1262 # Nearly identical to pp_or, but leaves stack unchanged. 1263 # Nearly identical to pp_or, but leaves stack unchanged.
1263 sub pp_orassign { 1264 sub pp_orassign {
1264 my $op = shift; 1265 my $op = shift;
1265 my $next = $op->next; 1266 my $next = $op->next;
1266 reload_lexicals(); 1267 reload_lexicals();
1267 unshift( @bblock_todo, $next ); 1268 unshift( @bblock_todo, $next );
1268 if ( @stack >= 1 ) { 1269 if ( @stack >= 1 ) {
1269 my $obj = pop @stack; 1270 my $obj = pop @stack;
1270 my $bool = $obj->as_bool; 1271 my $bool = $obj->as_bool;
1271 write_back_stack(); 1272 write_back_stack();
1272 save_or_restore_lexical_state($$next); 1273 save_or_restore_lexical_state($$next);
1273 runtime( 1274 runtime(
1274 sprintf( 1275 sprintf(
1275 "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)
1276 ) 1277 )
1277 ); 1278 );
1278 } 1279 }
1279 else { 1280 else {
1280 save_or_restore_lexical_state($$next); 1281 save_or_restore_lexical_state($$next);
1281 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ) ); 1282 runtime( sprintf( "if (%s) goto %s;", top_bool(), label($next) ) );
1282 } 1283 }
1283 return $op->other; 1284 return $op->other;
1284 } 1285 }
1285 1286
1286 # coverage: issue 45 (1,2) 1287 # coverage: issue 45 (1,2)
1287 # in CORE aliased to pp_defined 1288 # in CORE aliased to pp_defined
1288 # default dor is okay issue 45 (3,4) 1289 # default dor is okay issue 45 (3,4)
1289 sub pp_dorassign { 1290 sub pp_dorassign {
1290 my $op = shift; 1291 my $op = shift;
1291 my $next = $op->next; 1292 my $next = $op->next;
1292 reload_lexicals(); 1293 reload_lexicals();
1293 unshift( @bblock_todo, $next ); 1294 unshift( @bblock_todo, $next );
1294 my $sv = pop @stack; 1295 my $sv = pop @stack;
1295 write_back_stack(); 1296 write_back_stack();
1296 save_or_restore_lexical_state($$next); 1297 save_or_restore_lexical_state($$next);
1297 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 */",
1298 $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;
1299 return $op->other; 1300 return $op->other;
1300 } 1301 }
1301 1302
1302 # coverage: 102 1303 # coverage: 102
1303 sub pp_cond_expr { 1304 sub pp_cond_expr {
1304 my $op = shift; 1305 my $op = shift;
1305 my $false = $op->next; 1306 my $false = $op->next;
1306 unshift( @bblock_todo, $false ); 1307 unshift( @bblock_todo, $false );
1307 reload_lexicals(); 1308 reload_lexicals();
1308 my $bool = pop_bool(); 1309 my $bool = pop_bool();
1309 write_back_stack(); 1310 write_back_stack();
1310 save_or_restore_lexical_state($$false); 1311 save_or_restore_lexical_state($$false);
1311 runtime( sprintf( "if (!$bool) goto %s;\t/* cond_expr */", label($false) ) ); 1312 runtime( sprintf( "if (!$bool) goto %s;\t/* cond_expr */", label($false) ) );
1312 return $op->other; 1313 return $op->other;
1313 } 1314 }
1314 1315
1315 # coverage: 9,10,12,17,18,22,28,32 1316 # coverage: 9,10,12,17,18,22,28,32
1316 sub pp_padsv { 1317 sub pp_padsv {
1317 my $op = shift; 1318 my $op = shift;
1318 my $ix = $op->targ; 1319 my $ix = $op->targ;
1319 push( @stack, $pad[$ix] ) if $pad[$ix]; 1320 push( @stack, $pad[$ix] ) if $pad[$ix];
1320 if ( $op->flags & OPf_MOD ) { 1321 if ( $op->flags & OPf_MOD ) {
1321 my $private = $op->private; 1322 my $private = $op->private;
1322 if ( $private & OPpLVAL_INTRO ) { 1323 if ( $private & OPpLVAL_INTRO ) {
1323 # 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
1324 runtime("SAVECLEARSV(PL_curpad[$ix]);"); 1325 runtime("SAVECLEARSV(PL_curpad[$ix]);");
1325 } 1326 }
1326 elsif ( $private & OPpDEREF ) { 1327 elsif ( $private & OPpDEREF ) {
1327 # coverage: 18 1328 # coverage: 18
1328 if ($] >= 5.015002) { 1329 if ($] >= 5.015002) {
1329 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);",
1330 $ix, $ix, $private & OPpDEREF )); 1331 $ix, $ix, $private & OPpDEREF ));
1331 } else { 1332 } else {
1332 runtime(sprintf( "Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);", 1333 runtime(sprintf( "Perl_vivify_ref(aTHX_ PL_curpad[%d], %d);",
1333 $ix, $private & OPpDEREF )); 1334 $ix, $private & OPpDEREF ));
1334 } 1335 }
1335 $vivify_ref_defined++; 1336 $vivify_ref_defined++;
1336 $pad[$ix]->invalidate; 1337 $pad[$ix]->invalidate;
1337 } 1338 }
1338 } 1339 }
1339 return $op->next; 1340 return $op->next;
1340 } 1341 }
1341 1342
1342 # coverage: 1-5,7-14,18-23,25,27-32 1343 # coverage: 1-5,7-14,18-23,25,27-32
1343 sub pp_const { 1344 sub pp_const {
1344 my $op = shift; 1345 my $op = shift;
1345 my $sv = $op->sv; 1346 my $sv = $op->sv;
1346 my $obj; 1347 my $obj;
1347 1348
1348 # constant could be in the pad (under useithreads) 1349 # constant could be in the pad (under useithreads)
1349 if ($$sv) { 1350 if ($$sv) {
1350 $obj = $constobj{$$sv}; 1351 $obj = $constobj{$$sv};
1351 if ( !defined($obj) ) { 1352 if ( !defined($obj) ) {
1352 $obj = $constobj{$$sv} = B::Stackobj::Const->new($sv); 1353 $obj = $constobj{$$sv} = B::Stackobj::Const->new($sv);
1353 } 1354 }
1354 } 1355 }
1355 else { 1356 else {
1356 $obj = $pad[ $op->targ ]; 1357 $obj = $pad[ $op->targ ];
1357 } 1358 }
1358 push( @stack, $obj ); 1359 push( @stack, $obj );
1359 return $op->next; 1360 return $op->next;
1360 } 1361 }
1361 1362
1362 # coverage: 1-39, fails in 33 1363 # coverage: 1-39, fails in 33
1363 sub pp_nextstate { 1364 sub pp_nextstate {
1364 my $op = shift; 1365 my $op = shift;
1365 if ($labels->{'nextstate'}->[-1] and $labels->{'nextstate'}->[-1] == $op) { 1366 if ($labels->{'nextstate'}->[-1] and $labels->{'nextstate'}->[-1] == $op) {
1366 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};
1367 pop_label 'nextstate'; 1368 pop_label 'nextstate';
1368 } else { 1369 } else {
1369 write_label($op); 1370 write_label($op);
1370 } 1371 }
1371 $curcop->load($op); 1372 $curcop->load($op);
1372 @stack = (); 1373 @stack = ();
1373 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};
1374 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};
1375 runtime("TAINT_NOT;") unless $omit_taint; 1376 runtime("TAINT_NOT;") unless $omit_taint;
1376 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); 1377 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
1377 if ( $freetmps_each_bblock || $freetmps_each_loop ) { 1378 if ( $freetmps_each_bblock || $freetmps_each_loop ) {
1378 $need_freetmps = 1; 1379 $need_freetmps = 1;
1379 } 1380 }
1380 else { 1381 else {
1381 runtime("FREETMPS;"); 1382 runtime("FREETMPS;");
1382 } 1383 }
1383 return $op->next; 1384 return $op->next;
1384 } 1385 }
1385 1386
1386 # Like pp_nextstate, but used instead when the debugger is active. 1387 # Like pp_nextstate, but used instead when the debugger is active.
1387 sub pp_dbstate { pp_nextstate(@_) } 1388 sub pp_dbstate { pp_nextstate(@_) }
1388 1389
1389 #default_pp will handle this: 1390 #default_pp will handle this:
1390 #sub pp_repeat { $curcop->write_back; default_pp(@_) } 1391 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
1391 # 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:
1392 # 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
1393 #sub pp_caller { $curcop->write_back; default_pp(@_) } 1394 #sub pp_caller { $curcop->write_back; default_pp(@_) }
1394 1395
1395 # coverage: ny 1396 # coverage: ny
1396 sub bad_pp_reset { 1397 sub bad_pp_reset {
1397 if ($inline_ops) { 1398 if ($inline_ops) {
1398 my $op = shift; 1399 my $op = shift;
1399 warn "inlining reset\n" if $debug{op}; 1400 warn "inlining reset\n" if $debug{op};
1400 $curcop->write_back if $curcop; 1401 $curcop->write_back if $curcop;
1401 runtime '{ /* pp_reset */'; 1402 runtime '{ /* pp_reset */';
1402 runtime ' const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;'; 1403 runtime ' const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;';
1403 runtime ' sv_reset(tmps, CopSTASH(PL_curcop));}'; 1404 runtime ' sv_reset(tmps, CopSTASH(PL_curcop));}';
1404 runtime 'PUSHs(&PL_sv_yes);'; 1405 runtime 'PUSHs(&PL_sv_yes);';
1405 return $op->next; 1406 return $op->next;
1406 } else { 1407 } else {
1407 default_pp(@_); 1408 default_pp(@_);
1408 } 1409 }
1409 } 1410 }
1410 1411
1411 # coverage: 20 1412 # coverage: 20
1412 sub pp_regcreset { 1413 sub pp_regcreset {
1413 if ($inline_ops) { 1414 if ($inline_ops) {
1414 my $op = shift; 1415 my $op = shift;
1415 warn "inlining regcreset\n" if $debug{op}; 1416 warn "inlining regcreset\n" if $debug{op};
1416 $curcop->write_back if $curcop; 1417 $curcop->write_back if $curcop;
1417 runtime 'PL_reginterp_cnt = 0; /* pp_regcreset */'; 1418 runtime 'PL_reginterp_cnt = 0; /* pp_regcreset */';
1418 runtime 'TAINT_NOT;'; 1419 runtime 'TAINT_NOT;';
1419 return $op->next; 1420 return $op->next;
1420 } else { 1421 } else {
1421 default_pp(@_); 1422 default_pp(@_);
1422 } 1423 }
1423 } 1424 }
1424 1425
1425 # coverage: 103 1426 # coverage: 103
1426 sub pp_stringify { 1427 sub pp_stringify {
1427 if ($inline_ops and $] >= 5.008) { 1428 if ($inline_ops and $] >= 5.008) {
1428 my $op = shift; 1429 my $op = shift;
1429 warn "inlining stringify\n" if $debug{op}; 1430 warn "inlining stringify\n" if $debug{op};
1430 my $sv = top_sv(); 1431 my $sv = top_sv();
1431 my $ix = $op->targ; 1432 my $ix = $op->targ;
1432 my $targ = $pad[$ix]; 1433 my $targ = $pad[$ix];
1433 runtime "sv_copypv(PL_curpad[$ix], $sv);\t/* pp_stringify */"; 1434 runtime "sv_copypv(PL_curpad[$ix], $sv);\t/* pp_stringify */";
1434 $stack[-1] = $targ if @stack; 1435 $stack[-1] = $targ if @stack;
1435 return $op->next; 1436 return $op->next;
1436 } else { 1437 } else {
1437 default_pp(@_); 1438 default_pp(@_);
1438 } 1439 }
1439 } 1440 }
1440 1441
1441 # coverage: 9,10,27 1442 # coverage: 9,10,27
1442 sub bad_pp_anoncode { 1443 sub bad_pp_anoncode {
1443 if ($inline_ops) { 1444 if ($inline_ops) {
1444 my $op = shift; 1445 my $op = shift;
1445 warn "inlining anoncode\n" if $debug{op}; 1446 warn "inlining anoncode\n" if $debug{op};
1446 my $ix = $op->targ; 1447 my $ix = $op->targ;
1447 my $ppname = "pp_" . $op->name; 1448 my $ppname = "pp_" . $op->name;
1448 write_back_lexicals() unless $skip_lexicals{$ppname}; 1449 write_back_lexicals() unless $skip_lexicals{$ppname};
1449 write_back_stack() unless $skip_stack{$ppname}; 1450 write_back_stack() unless $skip_stack{$ppname};
1450 # XXX finish me. this works only with >= 5.10 1451 # XXX finish me. this works only with >= 5.10
1451 runtime '{ /* pp_anoncode */', 1452 runtime '{ /* pp_anoncode */',
1452 ' CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));', 1453 ' CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));',
1453 ' if (CvCLONE(cv))', 1454 ' if (CvCLONE(cv))',
1454 ' 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))));',
1455 ' EXTEND(SP,1);', 1456 ' EXTEND(SP,1);',
1456 ' PUSHs(MUTABLE_SV(cv));', 1457 ' PUSHs(MUTABLE_SV(cv));',
1457 '}'; 1458 '}';
1458 invalidate_lexicals() unless $skip_invalidate{$ppname}; 1459 invalidate_lexicals() unless $skip_invalidate{$ppname};
1459 return $op->next; 1460 return $op->next;
1460 } else { 1461 } else {
1461 default_pp(@_); 1462 default_pp(@_);
1462 } 1463 }
1463 } 1464 }
1464 1465
1465 # coverage: 35 1466 # coverage: 35
1466 # XXX TODO store package_pv in entersub and bless 1467 # XXX TODO store package_pv in entersub and bless
1467 sub pp_method_named { 1468 sub pp_method_named {
1468 my ( $op ) = @_; 1469 my ( $op ) = @_;
1469 my $cv = B::C::method_named(B::C::svop_pv($op)); 1470 my $cv = B::C::method_named(B::C::svop_pv($op));
1470 $cv->save if $cv; 1471 $cv->save if $cv;
1471 default_pp(@_); 1472 default_pp(@_);
1472 } 1473 }
1473 1474
1474 # inconsequence: gvs are not passed around on the stack 1475 # inconsequence: gvs are not passed around on the stack
1475 # coverage: 26,103 1476 # coverage: 26,103
1476 sub bad_pp_srefgen { 1477 sub bad_pp_srefgen {
1477 if ($inline_ops) { 1478 if ($inline_ops) {
1478 my $op = shift; 1479 my $op = shift;
1479 warn "inlining srefgen\n" if $debug{op}; 1480 warn "inlining srefgen\n" if $debug{op};
1480 #my $ppname = "pp_" . $op->name; 1481 #my $ppname = "pp_" . $op->name;
1481 #$curcop->write_back; 1482 #$curcop->write_back;
1482 #write_back_lexicals() unless $skip_lexicals{$ppname}; 1483 #write_back_lexicals() unless $skip_lexicals{$ppname};
1483 #write_back_stack() unless $skip_stack{$ppname}; 1484 #write_back_stack() unless $skip_stack{$ppname};
1484 my $svobj = $stack[-1]->as_sv; 1485 my $svobj = $stack[-1]->as_sv;
1485 my $sv = pop_sv(); 1486 my $sv = pop_sv();
1486 # XXX fix me 1487 # XXX fix me
1487 runtime "{ /* pp_srefgen */ 1488 runtime "{ /* pp_srefgen */
1488 SV* rv; 1489 SV* rv;
1489 SV* sv = $sv;"; 1490 SV* sv = $sv;";
1490 # sv = POPs 1491 # sv = POPs
1491 #B::svref_2object(\$sv); 1492 #B::svref_2object(\$sv);
1492 if (($svobj->flags & 0xff) == $SVt_PVLV 1493 if (($svobj->flags & 0xff) == $SVt_PVLV
1493 and B::PVLV::LvTYPE($svobj) eq ord('y')) 1494 and B::PVLV::LvTYPE($svobj) eq ord('y'))
1494 { 1495 {
1495 runtime 'if (LvTARGLEN(sv)) 1496 runtime 'if (LvTARGLEN(sv))
1496 vivify_defelem(sv); 1497 vivify_defelem(sv);
1497 if (!(sv = LvTARG(sv))) 1498 if (!(sv = LvTARG(sv)))
1498 sv = &PL_sv_undef; 1499 sv = &PL_sv_undef;
1499 else 1500 else
1500 SvREFCNT_inc_void_NN(sv);'; 1501 SvREFCNT_inc_void_NN(sv);';
1501 } 1502 }
1502 elsif (($svobj->flags & 0xff) == $SVt_PVAV) { 1503 elsif (($svobj->flags & 0xff) == $SVt_PVAV) {
1503 runtime 'if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv)) 1504 runtime 'if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
1504 av_reify(MUTABLE_AV(sv)); 1505 av_reify(MUTABLE_AV(sv));
1505 SvTEMP_off(sv); 1506 SvTEMP_off(sv);
1506 SvREFCNT_inc_void_NN(sv);'; 1507 SvREFCNT_inc_void_NN(sv);';
1507 } 1508 }
1508 #elsif ($sv->SvPADTMP && !IS_PADGV(sv)) { 1509 #elsif ($sv->SvPADTMP && !IS_PADGV(sv)) {
1509 # runtime 'sv = newSVsv(sv);'; 1510 # runtime 'sv = newSVsv(sv);';
1510 #} 1511 #}
1511 else { 1512 else {
1512 runtime 'SvTEMP_off(sv); 1513 runtime 'SvTEMP_off(sv);
1513 SvREFCNT_inc_void_NN(sv);'; 1514 SvREFCNT_inc_void_NN(sv);';
1514 } 1515 }
1515 runtime 'rv = sv_newmortal(); 1516 runtime 'rv = sv_newmortal();
1516 sv_upgrade(rv, SVt_IV); 1517 sv_upgrade(rv, SVt_IV);
1517 SvRV_set(rv, sv); 1518 SvRV_set(rv, sv);
1518 SvROK_on(rv); 1519 SvROK_on(rv);
1519 PUSHBACK; 1520 PUSHBACK;
1520 }'; 1521 }';
1521 return $op->next; 1522 return $op->next;
1522 } else { 1523 } else {
1523 default_pp(@_); 1524 default_pp(@_);
1524 } 1525 }
1525 } 1526 }
1526 1527
1527 # coverage: 9,10,27 1528 # coverage: 9,10,27
1528 #sub pp_refgen 1529 #sub pp_refgen
1529 1530
1530 # coverage: 28, 14 1531 # coverage: 28, 14
1531 sub pp_rv2gv { 1532 sub pp_rv2gv {
1532 my $op = shift; 1533 my $op = shift;
1533 $curcop->write_back if $curcop; 1534 $curcop->write_back if $curcop;
1534 my $ppname = "pp_" . $op->name; 1535 my $ppname = "pp_" . $op->name;
1535 write_back_lexicals() unless $skip_lexicals{$ppname}; 1536 write_back_lexicals() unless $skip_lexicals{$ppname};
1536 write_back_stack() unless $skip_stack{$ppname}; 1537 write_back_stack() unless $skip_stack{$ppname};
1537 my $sym = doop($op); 1538 my $sym = doop($op);
1538 if ( $op->private & OPpDEREF ) { 1539 if ( $op->private & OPpDEREF ) {
1539 $init->add( sprintf("((UNOP *)$sym)->op_first = $sym;") ); 1540 $init->add( sprintf("((UNOP *)$sym)->op_first = $sym;") );
1540 $init->add( sprintf( "((UNOP *)$sym)->op_type = %d;", $op->first->type ) ); 1541 $init->add( sprintf( "((UNOP *)$sym)->op_type = %d;", $op->first->type ) );
1541 } 1542 }
1542 return $op->next; 1543 return $op->next;
1543 } 1544 }
1544 1545
1545 # coverage: 18,19,25 1546 # coverage: 18,19,25
1546 sub pp_sort { 1547 sub pp_sort {
1547 my $op = shift; 1548 my $op = shift;
1548 #my $ppname = $op->ppaddr; 1549 #my $ppname = $op->ppaddr;
1549 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED ) { 1550 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED ) {
1550 # 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
1551 # Ugly surgery required. sort expects as block: pushmark rv2gv leave => enter 1552 # Ugly surgery required. sort expects as block: pushmark rv2gv leave => enter
1552 # 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 */
1553 # kid = cUNOPx(kid)->op_first; /* pass rv2gv (null'ed) */ 1554 # kid = cUNOPx(kid)->op_first; /* pass rv2gv (null'ed) */
1554 # kid = cUNOPx(kid)->op_first; /* pass leave */ 1555 # kid = cUNOPx(kid)->op_first; /* pass leave */
1555 # 1556 #
1556 #3 <0> pushmark s ->4 1557 #3 <0> pushmark s ->4
1557 #8 <@> sort lKS* ->9 1558 #8 <@> sort lKS* ->9
1558 #4 <0> pushmark s ->5 1559 #4 <0> pushmark s ->5
1559 #- <1> null sK/1 ->5 1560 #- <1> null sK/1 ->5
1560 #- <1> ex-leave sKP ->- 1561 #- <1> ex-leave sKP ->-
1561 #- <0> enter s ->- 1562 #- <0> enter s ->-
1562 # some code doing cmp or ncmp 1563 # some code doing cmp or ncmp
1563 # 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
1564 #5 <$> const[IV 1] s ->6 1565 #5 <$> const[IV 1] s ->6
1565 #6 <$> const[IV 4] s ->7 1566 #6 <$> const[IV 4] s ->7
1566 #7 <$> const[IV 3] s ->8 => sort 1567 #7 <$> const[IV 3] s ->8 => sort
1567 # 1568 #
1568 my $root = $op->first->sibling->first; #leave or null 1569 my $root = $op->first->sibling->first; #leave or null
1569 my $start = $root->first; #enter 1570 my $start = $root->first; #enter
1570 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};
1571 my $pushmark = $op->first->save; #pushmark sibling to null 1572 my $pushmark = $op->first->save; #pushmark sibling to null
1572 $op->first->sibling->save; #null->first to leave 1573 $op->first->sibling->save; #null->first to leave
1573 $root->save; #ex-leave 1574 $root->save; #ex-leave
1574 my $sym = $start->save; #enter 1575 my $sym = $start->save; #enter
1575 my $fakeop = cc_queue( "pp_sort" . $$op, $root, $start ); 1576 my $fakeop = cc_queue( "pp_sort" . $$op, $root, $start );
1576 $init->add( sprintf( "(%s)->op_next = %s;", $sym, $fakeop ) ); 1577 $init->add( sprintf( "(%s)->op_next = %s;", $sym, $fakeop ) );
1577 } 1578 }
1578 $curcop->write_back; 1579 $curcop->write_back;
1579 write_back_lexicals(); 1580 write_back_lexicals();
1580 write_back_stack(); 1581 write_back_stack();
1581 doop($op); 1582 doop($op);
1582 return $op->next; 1583 return $op->next;
1583 } 1584 }
1584 1585
1585 # 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
1586 sub pp_gv { 1587 sub pp_gv {
1587 my $op = shift; 1588 my $op = shift;
1588 my $gvsym; 1589 my $gvsym;
1589 if ($ITHREADS) { 1590 if ($ITHREADS) {
1590 $gvsym = $pad[ $op->padix ]->as_sv; 1591 $gvsym = $pad[ $op->padix ]->as_sv;
1591 #push @stack, ($pad[$op->padix]); 1592 #push @stack, ($pad[$op->padix]);
1592 } 1593 }
1593 else { 1594 else {
1594 $gvsym = $op->gv->save; 1595 $gvsym = $op->gv->save;
1595 # XXX 1596 # XXX
1596 #my $obj = new B::Stackobj::Const($op->gv); 1597 #my $obj = new B::Stackobj::Const($op->gv);
1597 #push( @stack, $obj ); 1598 #push( @stack, $obj );
1598 } 1599 }
1599 write_back_stack(); 1600 write_back_stack();
1600 runtime("XPUSHs((SV*)$gvsym);"); 1601 runtime("XPUSHs((SV*)$gvsym);");
1601 return $op->next; 1602 return $op->next;
1602 } 1603 }
1603 1604
1604 # coverage: 2,3,4,9,11,14,20,21,23,28 1605 # coverage: 2,3,4,9,11,14,20,21,23,28
1605 sub pp_gvsv { 1606 sub pp_gvsv {
1606 my $op = shift; 1607 my $op = shift;
1607 my $gvsym; 1608 my $gvsym;
1608 if ($ITHREADS) { 1609 if ($ITHREADS) {
1609 #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};
1610 debug( sprintf( "GVSV->padix = %d\n", $op->padix ) ) if $debug{pad}; 1611 debug( sprintf( "GVSV->padix = %d\n", $op->padix ) ) if $debug{pad};
1611 $gvsym = $pad[ $op->padix ]->as_sv; 1612 $gvsym = $pad[ $op->padix ]->as_sv;
1612 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};
1613 } 1614 }
1614 else { 1615 else {
1615 $gvsym = $op->gv->save; 1616 $gvsym = $op->gv->save;
1616 } 1617 }
1617 # Expects GV*, not SV* PL_curpad 1618 # Expects GV*, not SV* PL_curpad
1618 $gvsym = "(GV*)$gvsym" if $gvsym =~ /PL_curpad/; 1619 $gvsym = "(GV*)$gvsym" if $gvsym =~ /PL_curpad/;
1619 write_back_stack(); 1620 write_back_stack();
1620 if ( $op->private & OPpLVAL_INTRO ) { 1621 if ( $op->private & OPpLVAL_INTRO ) {
1621 runtime("XPUSHs(save_scalar($gvsym));"); 1622 runtime("XPUSHs(save_scalar($gvsym));");
1622 #my $obj = new B::Stackobj::Const($op->gv); 1623 #my $obj = new B::Stackobj::Const($op->gv);
1623 #push( @stack, $obj ); 1624 #push( @stack, $obj );
1624 } 1625 }
1625 else { 1626 else {
1626 $PERL510 1627 $PERL510
1627 ? runtime("XPUSHs(GvSVn($gvsym));") 1628 ? runtime("XPUSHs(GvSVn($gvsym));")
1628 : runtime("XPUSHs(GvSV($gvsym));"); 1629 : runtime("XPUSHs(GvSV($gvsym));");
1629 } 1630 }
1630 return $op->next; 1631 return $op->next;
1631 } 1632 }
1632 1633
1633 # coverage: 16, issue44 1634 # coverage: 16, issue44
1634 sub pp_aelemfast { 1635 sub pp_aelemfast {
1635 my $op = shift; 1636 my $op = shift;
1636 my $av; 1637 my $av;
1637 if ($op->flags & OPf_SPECIAL) { 1638 if ($op->flags & OPf_SPECIAL) {
1638 my $sv = $pad[ $op->targ ]->as_sv; 1639 my $sv = $pad[ $op->targ ]->as_sv;
1639 $av = $] > 5.01000 ? "MUTABLE_AV($sv)" : $sv; 1640 $av = $] > 5.01000 ? "MUTABLE_AV($sv)" : $sv;
1640 } else { 1641 } else {
1641 my $gvsym; 1642 my $gvsym;
1642 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
1643 if ($op->can('padix')) { 1644 if ($op->can('padix')) {
1644 #warn "padix\n"; 1645 #warn "padix\n";
1645 $gvsym = $pad[ $op->padix ]->as_sv; 1646 $gvsym = $pad[ $op->padix ]->as_sv;
1646 } else { 1647 } else {
1647 $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
1648 #write_back_stack(); 1649 #write_back_stack();
1649 #runtime("PUSHs(&PL_sv_undef);"); 1650 #runtime("PUSHs(&PL_sv_undef);");
1650 #return $op->next; 1651 #return $op->next;
1651 } 1652 }
1652 } 1653 }
1653 else { #svop 1654 else { #svop
1654 $gvsym = $op->gv->save; 1655 $gvsym = $op->gv->save;
1655 } 1656 }
1656 $av = "GvAV($gvsym)"; 1657 $av = "GvAV($gvsym)";
1657 } 1658 }
1658 my $ix = $op->private; 1659 my $ix = $op->private;
1659 my $lval = $op->flags & OPf_MOD; 1660 my $lval = $op->flags & OPf_MOD;
1660 write_back_stack(); 1661 write_back_stack();
1661 runtime( 1662 runtime(
1662 "{ AV* av = $av;", 1663 "{ AV* av = $av;",
1663 " SV** const svp = av_fetch(av, $ix, $lval);", 1664 " SV** const svp = av_fetch(av, $ix, $lval);",
1664 " SV *sv = (svp ? *svp : &PL_sv_undef);", 1665 " SV *sv = (svp ? *svp : &PL_sv_undef);",
1665 !$lval ? " if (SvRMAGICAL(av) && SvGMAGICAL(sv)) mg_get(sv);" : "", 1666 !$lval ? " if (SvRMAGICAL(av) && SvGMAGICAL(sv)) mg_get(sv);" : "",
1666 " PUSHs(sv);", 1667 " PUSHs(sv);",
1667 "}" 1668 "}"
1668 ); 1669 );
1669 return $op->next; 1670 return $op->next;
1670 } 1671 }
1671 1672
1672 # coverage: ? 1673 # coverage: ?
1673 sub int_binop { 1674 sub int_binop {
1674 my ( $op, $operator, $unsigned ) = @_; 1675 my ( $op, $operator, $unsigned ) = @_;
1675 if ( $op->flags & OPf_STACKED ) { 1676 if ( $op->flags & OPf_STACKED ) {
1676 my $right = pop_int(); 1677 my $right = pop_int();
1677 if ( @stack >= 1 ) { 1678 if ( @stack >= 1 ) {
1678 my $left = top_int(); 1679 my $left = top_int();
1679 $stack[-1]->set_int( &$operator( $left, $right ), $unsigned ); 1680 $stack[-1]->set_int( &$operator( $left, $right ), $unsigned );
1680 } 1681 }
1681 else { 1682 else {
1682 my $sv_setxv = $unsigned ? 'sv_setuv' : 'sv_setiv'; 1683 my $sv_setxv = $unsigned ? 'sv_setuv' : 'sv_setiv';
1683 runtime( sprintf( "$sv_setxv(TOPs, %s);", &$operator( "TOPi", $right ) ) ); 1684 runtime( sprintf( "$sv_setxv(TOPs, %s);", &$operator( "TOPi", $right ) ) );
1684 } 1685 }
1685 } 1686 }
1686 else { 1687 else {
1687 my $targ = $pad[ $op->targ ]; 1688 my $targ = $pad[ $op->targ ];
1688 my $right = B::Pseudoreg->new( "IV", "riv" ); 1689 my $right = B::Pseudoreg->new( "IV", "riv" );
1689 my $left = B::Pseudoreg->new( "IV", "liv" ); 1690 my $left = B::Pseudoreg->new( "IV", "liv" );
1690 runtime( sprintf( "$$right = %s; $$left = %s;", pop_int(), pop_int ) ); 1691 runtime( sprintf( "$$right = %s; $$left = %s;", pop_int(), pop_int ) );
1691 $targ->set_int( &$operator( $$left, $$right ), $unsigned ); 1692 $targ->set_int( &$operator( $$left, $$right ), $unsigned );
1692 push( @stack, $targ ); 1693 push( @stack, $targ );
1693 } 1694 }
1694 return $op->next; 1695 return $op->next;
1695 } 1696 }
1696 1697
1697 sub INTS_CLOSED () { 0x1 } 1698 sub INTS_CLOSED () { 0x1 }
1698 sub INT_RESULT () { 0x2 } 1699 sub INT_RESULT () { 0x2 }
1699 sub NUMERIC_RESULT () { 0x4 } 1700 sub NUMERIC_RESULT () { 0x4 }
1700 1701
1701 # coverage: ? 1702 # coverage: ?
1702 sub numeric_binop { 1703 sub numeric_binop {
1703 my ( $op, $operator, $flags ) = @_; 1704 my ( $op, $operator, $flags ) = @_;
1704 my $force_int = 0; 1705 my $force_int = 0;
1705 $force_int ||= ( $flags & INT_RESULT ); 1706 $force_int ||= ( $flags & INT_RESULT );
1706 $force_int ||= 1707 $force_int ||=
1707 ( $flags & INTS_CLOSED 1708 ( $flags & INTS_CLOSED
1708 && @stack >= 2 1709 && @stack >= 2
1709 && valid_int( $stack[-2] ) 1710 && valid_int( $stack[-2] )
1710 && valid_int( $stack[-1] ) ); 1711 && valid_int( $stack[-1] ) );
1711 if ( $op->flags & OPf_STACKED ) { 1712 if ( $op->flags & OPf_STACKED ) {
1712 runtime(sprintf("/* %s */", $op->name)) if $verbose; 1713 runtime(sprintf("/* %s */", $op->name)) if $verbose;
1713 my $right = pop_numeric(); 1714 my $right = pop_numeric();
1714 if ( @stack >= 1 ) { 1715 if ( @stack >= 1 ) {
1715 my $left = top_numeric(); 1716 my $left = top_numeric();
1716 if ($force_int) { 1717 if ($force_int) {
1717 $stack[-1]->set_int( &$operator( $left, $right ) ); 1718 $stack[-1]->set_int( &$operator( $left, $right ) );
1718 } 1719 }
1719 else { 1720 else {
1720 $stack[-1]->set_numeric( &$operator( $left, $right ) ); 1721 $stack[-1]->set_numeric( &$operator( $left, $right ) );
1721 } 1722 }
1722 } 1723 }
1723 else { 1724 else {
1724 if ($force_int) { 1725 if ($force_int) {
1725 my $rightruntime = B::Pseudoreg->new( "IV", "riv" ); 1726 my $rightruntime = B::Pseudoreg->new( "IV", "riv" );
1726 runtime( sprintf( "$$rightruntime = %s;", $right ) ); 1727 runtime( sprintf( "$$rightruntime = %s;", $right ) );
1727 runtime( 1728 runtime(
1728 sprintf( 1729 sprintf(
1729 "sv_setiv(TOPs, %s);", &$operator( "TOPi", $$rightruntime ) 1730 "sv_setiv(TOPs, %s);", &$operator( "TOPi", $$rightruntime )
1730 ) 1731 )
1731 ); 1732 );
1732 } 1733 }
1733 else { 1734 else {
1734 my $rightruntime = B::Pseudoreg->new( "double", "rnv" ); 1735 my $rightruntime = B::Pseudoreg->new( "double", "rnv" );
1735 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) ); 1736 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) );
1736 runtime( 1737 runtime(
1737 sprintf( 1738 sprintf(
1738 "sv_setnv(TOPs, %s);", &$operator( "TOPn", $$rightruntime ) 1739 "sv_setnv(TOPs, %s);", &$operator( "TOPn", $$rightruntime )
1739 ) 1740 )
1740 ); 1741 );
1741 } 1742 }
1742 } 1743 }
1743 } 1744 }
1744 else { 1745 else {
1745 my $targ = $pad[ $op->targ ]; 1746 my $targ = $pad[ $op->targ ];
1746 $force_int ||= ( $targ->{type} == T_INT ); 1747 $force_int ||= ( $targ->{type} == T_INT );
1747 if ($force_int) { 1748 if ($force_int) {
1748 my $right = B::Pseudoreg->new( "IV", "riv" ); 1749 my $right = B::Pseudoreg->new( "IV", "riv" );
1749 my $left = B::Pseudoreg->new( "IV", "liv" ); 1750 my $left = B::Pseudoreg->new( "IV", "liv" );
1750 runtime( 1751 runtime(
1751 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1752 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1752 pop_numeric(), pop_numeric, $op->name ) ); 1753 pop_numeric(), pop_numeric, $op->name ) );
1753 $targ->set_int( &$operator( $$left, $$right ) ); 1754 $targ->set_int( &$operator( $$left, $$right ) );
1754 } 1755 }
1755 else { 1756 else {
1756 my $right = B::Pseudoreg->new( "double", "rnv" ); 1757 my $right = B::Pseudoreg->new( "double", "rnv" );
1757 my $left = B::Pseudoreg->new( "double", "lnv" ); 1758 my $left = B::Pseudoreg->new( "double", "lnv" );
1758 runtime( 1759 runtime(
1759 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1760 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1760 pop_numeric(), pop_numeric, $op->name ) ); 1761 pop_numeric(), pop_numeric, $op->name ) );
1761 $targ->set_numeric( &$operator( $$left, $$right ) ); 1762 $targ->set_numeric( &$operator( $$left, $$right ) );
1762 } 1763 }
1763 push( @stack, $targ ); 1764 push( @stack, $targ );
1764 } 1765 }
1765 return $op->next; 1766 return $op->next;
1766 } 1767 }
1767 1768
1768 # coverage: 18 1769 # coverage: 18
1769 sub pp_ncmp { 1770 sub pp_ncmp {
1770 my ($op) = @_; 1771 my ($op) = @_;
1771 if ( $op->flags & OPf_STACKED ) { 1772 if ( $op->flags & OPf_STACKED ) {
1772 my $right = pop_numeric(); 1773 my $right = pop_numeric();
1773 if ( @stack >= 1 ) { 1774 if ( @stack >= 1 ) {
1774 my $left = top_numeric(); 1775 my $left = top_numeric();
1775 runtime sprintf( "if (%s > %s){\t/* %s */", $left, $right, $op->name ); 1776 runtime sprintf( "if (%s > %s){\t/* %s */", $left, $right, $op->name );
1776 $stack[-1]->set_int(1); 1777 $stack[-1]->set_int(1);
1777 $stack[-1]->write_back(); 1778 $stack[-1]->write_back();
1778 runtime sprintf( "}else if (%s < %s ) {", $left, $right ); 1779 runtime sprintf( "}else if (%s < %s ) {", $left, $right );
1779 $stack[-1]->set_int(-1); 1780 $stack[-1]->set_int(-1);
1780 $stack[-1]->write_back(); 1781 $stack[-1]->write_back();
1781 runtime sprintf( "}else if (%s == %s) {", $left, $right ); 1782 runtime sprintf( "}else if (%s == %s) {", $left, $right );
1782 $stack[-1]->set_int(0); 1783 $stack[-1]->set_int(0);
1783 $stack[-1]->write_back(); 1784 $stack[-1]->write_back();
1784 runtime sprintf("}else {"); 1785 runtime sprintf("}else {");
1785 $stack[-1]->set_sv("&PL_sv_undef"); 1786 $stack[-1]->set_sv("&PL_sv_undef");
1786 runtime "}"; 1787 runtime "}";
1787 } 1788 }
1788 else { 1789 else {
1789 my $rightruntime = B::Pseudoreg->new( "double", "rnv" ); 1790 my $rightruntime = B::Pseudoreg->new( "double", "rnv" );
1790 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) ); 1791 runtime( sprintf( "$$rightruntime = %s;\t/* %s */", $right, $op->name ) );
1791 runtime sprintf( qq/if ("TOPn" > %s){/, $rightruntime ); 1792 runtime sprintf( qq/if ("TOPn" > %s){/, $rightruntime );
1792 runtime sprintf(" sv_setiv(TOPs,1);"); 1793 runtime sprintf(" sv_setiv(TOPs,1);");
1793 runtime sprintf( qq/}else if ( "TOPn" < %s ) {/, $$rightruntime ); 1794 runtime sprintf( qq/}else if ( "TOPn" < %s ) {/, $$rightruntime );
1794 runtime sprintf(" sv_setiv(TOPs,-1);"); 1795 runtime sprintf(" sv_setiv(TOPs,-1);");
1795 runtime sprintf( qq/} else if ("TOPn" == %s) {/, $$rightruntime ); 1796 runtime sprintf( qq/} else if ("TOPn" == %s) {/, $$rightruntime );
1796 runtime sprintf(" sv_setiv(TOPs,0);"); 1797 runtime sprintf(" sv_setiv(TOPs,0);");
1797 runtime sprintf(qq/}else {/); 1798 runtime sprintf(qq/}else {/);
1798 runtime sprintf(" sv_setiv(TOPs,&PL_sv_undef;"); 1799 runtime sprintf(" sv_setiv(TOPs,&PL_sv_undef;");
1799 runtime "}"; 1800 runtime "}";
1800 } 1801 }
1801 } 1802 }
1802 else { 1803 else {
1803 my $targ = $pad[ $op->targ ]; 1804 my $targ = $pad[ $op->targ ];
1804 my $right = B::Pseudoreg->new( "double", "rnv" ); 1805 my $right = B::Pseudoreg->new( "double", "rnv" );
1805 my $left = B::Pseudoreg->new( "double", "lnv" ); 1806 my $left = B::Pseudoreg->new( "double", "lnv" );
1806 runtime( 1807 runtime(
1807 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1808 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1808 pop_numeric(), pop_numeric, $op->name ) ); 1809 pop_numeric(), pop_numeric, $op->name ) );
1809 runtime sprintf( "if (%s > %s){ /*targ*/", $$left, $$right ); 1810 runtime sprintf( "if (%s > %s){ /*targ*/", $$left, $$right );
1810 $targ->set_int(1); 1811 $targ->set_int(1);
1811 $targ->write_back(); 1812 $targ->write_back();
1812 runtime sprintf( "}else if (%s < %s ) {", $$left, $$right ); 1813 runtime sprintf( "}else if (%s < %s ) {", $$left, $$right );
1813 $targ->set_int(-1); 1814 $targ->set_int(-1);
1814 $targ->write_back(); 1815 $targ->write_back();
1815 runtime sprintf( "}else if (%s == %s) {", $$left, $$right ); 1816 runtime sprintf( "}else if (%s == %s) {", $$left, $$right );
1816 $targ->set_int(0); 1817 $targ->set_int(0);
1817 $targ->write_back(); 1818 $targ->write_back();
1818 runtime sprintf("}else {"); 1819 runtime sprintf("}else {");
1819 $targ->set_sv("&PL_sv_undef"); 1820 $targ->set_sv("&PL_sv_undef");
1820 runtime "}"; 1821 runtime "}";
1821 push( @stack, $targ ); 1822 push( @stack, $targ );
1822 } 1823 }
1823 #runtime "return NULL;"; 1824 #runtime "return NULL;";
1824 return $op->next; 1825 return $op->next;
1825 } 1826 }
1826 1827
1827 # coverage: ? 1828 # coverage: ?
1828 sub sv_binop { 1829 sub sv_binop {
1829 my ( $op, $operator, $flags ) = @_; 1830 my ( $op, $operator, $flags ) = @_;
1830 if ( $op->flags & OPf_STACKED ) { 1831 if ( $op->flags & OPf_STACKED ) {
1831 my $right = pop_sv(); 1832 my $right = pop_sv();
1832 if ( @stack >= 1 ) { 1833 if ( @stack >= 1 ) {
1833 my $left = top_sv(); 1834 my $left = top_sv();
1834 if ( $flags & INT_RESULT ) { 1835 if ( $flags & INT_RESULT ) {
1835 $stack[-1]->set_int( &$operator( $left, $right ) ); 1836 $stack[-1]->set_int( &$operator( $left, $right ) );
1836 } 1837 }
1837 elsif ( $flags & NUMERIC_RESULT ) { 1838 elsif ( $flags & NUMERIC_RESULT ) {
1838 $stack[-1]->set_numeric( &$operator( $left, $right ) ); 1839 $stack[-1]->set_numeric( &$operator( $left, $right ) );
1839 } 1840 }
1840 else { 1841 else {
1841 # XXX Does this work? 1842 # XXX Does this work?
1842 runtime( 1843 runtime(
1843 sprintf( "sv_setsv($left, %s);\t/* %s */", 1844 sprintf( "sv_setsv($left, %s);\t/* %s */",
1844 &$operator( $left, $right ), $op->name ) ); 1845 &$operator( $left, $right ), $op->name ) );
1845 $stack[-1]->invalidate; 1846 $stack[-1]->invalidate;
1846 } 1847 }
1847 } 1848 }
1848 else { 1849 else {
1849 my $f; 1850 my $f;
1850 if ( $flags & INT_RESULT ) { 1851 if ( $flags & INT_RESULT ) {
1851 $f = "sv_setiv"; 1852 $f = "sv_setiv";
1852 } 1853 }
1853 elsif ( $flags & NUMERIC_RESULT ) { 1854 elsif ( $flags & NUMERIC_RESULT ) {
1854 $f = "sv_setnv"; 1855 $f = "sv_setnv";
1855 } 1856 }
1856 else { 1857 else {
1857 $f = "sv_setsv"; 1858 $f = "sv_setsv";
1858 } 1859 }
1859 runtime( sprintf( "%s(TOPs, %s);\t/* %s */", 1860 runtime( sprintf( "%s(TOPs, %s);\t/* %s */",
1860 $f, &$operator( "TOPs", $right ), $op->name ) ); 1861 $f, &$operator( "TOPs", $right ), $op->name ) );
1861 } 1862 }
1862 } 1863 }
1863 else { 1864 else {
1864 my $targ = $pad[ $op->targ ]; 1865 my $targ = $pad[ $op->targ ];
1865 runtime( sprintf( "right = %s; left = %s;\t/* %s */", 1866 runtime( sprintf( "right = %s; left = %s;\t/* %s */",
1866 pop_sv(), pop_sv, $op->name ) ); 1867 pop_sv(), pop_sv, $op->name ) );
1867 if ( $flags & INT_RESULT ) { 1868 if ( $flags & INT_RESULT ) {
1868 $targ->set_int( &$operator( "left", "right" ) ); 1869 $targ->set_int( &$operator( "left", "right" ) );
1869 } 1870 }
1870 elsif ( $flags & NUMERIC_RESULT ) { 1871 elsif ( $flags & NUMERIC_RESULT ) {
1871 $targ->set_numeric( &$operator( "left", "right" ) ); 1872 $targ->set_numeric( &$operator( "left", "right" ) );
1872 } 1873 }
1873 else { 1874 else {
1874 # XXX Does this work? 1875 # XXX Does this work?
1875 runtime(sprintf("sv_setsv(%s, %s);", 1876 runtime(sprintf("sv_setsv(%s, %s);",
1876 $targ->as_sv, &$operator( "left", "right" ) )); 1877 $targ->as_sv, &$operator( "left", "right" ) ));
1877 $targ->invalidate; 1878 $targ->invalidate;
1878 } 1879 }
1879 push( @stack, $targ ); 1880 push( @stack, $targ );
1880 } 1881 }
1881 return $op->next; 1882 return $op->next;
1882 } 1883 }
1883 1884
1884 # coverage: ? 1885 # coverage: ?
1885 sub bool_int_binop { 1886 sub bool_int_binop {
1886 my ( $op, $operator ) = @_; 1887 my ( $op, $operator ) = @_;
1887 my $right = B::Pseudoreg->new( "IV", "riv" ); 1888 my $right = B::Pseudoreg->new( "IV", "riv" );
1888 my $left = B::Pseudoreg->new( "IV", "liv" ); 1889 my $left = B::Pseudoreg->new( "IV", "liv" );
1889 runtime( sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1890 runtime( sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1890 pop_int(), pop_int(), $op->name ) ); 1891 pop_int(), pop_int(), $op->name ) );
1891 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) ); 1892 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
1892 $bool->set_int( &$operator( $$left, $$right ) ); 1893 $bool->set_int( &$operator( $$left, $$right ) );
1893 push( @stack, $bool ); 1894 push( @stack, $bool );
1894 return $op->next; 1895 return $op->next;
1895 } 1896 }
1896 1897
1897 # coverage: ? 1898 # coverage: ?
1898 sub bool_numeric_binop { 1899 sub bool_numeric_binop {
1899 my ( $op, $operator ) = @_; 1900 my ( $op, $operator ) = @_;
1900 my $right = B::Pseudoreg->new( "double", "rnv" ); 1901 my $right = B::Pseudoreg->new( "double", "rnv" );
1901 my $left = B::Pseudoreg->new( "double", "lnv" ); 1902 my $left = B::Pseudoreg->new( "double", "lnv" );
1902 runtime( 1903 runtime(
1903 sprintf( "$$right = %s; $$left = %s;\t/* %s */", 1904 sprintf( "$$right = %s; $$left = %s;\t/* %s */",
1904 pop_numeric(), pop_numeric(), $op->name ) ); 1905 pop_numeric(), pop_numeric(), $op->name ) );
1905 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) ); 1906 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
1906 $bool->set_numeric( &$operator( $$left, $$right ) ); 1907 $bool->set_numeric( &$operator( $$left, $$right ) );
1907 push( @stack, $bool ); 1908 push( @stack, $bool );
1908 return $op->next; 1909 return $op->next;
1909 } 1910 }
1910 1911
1911 # coverage: ? 1912 # coverage: ?
1912 sub bool_sv_binop { 1913 sub bool_sv_binop {
1913 my ( $op, $operator ) = @_; 1914 my ( $op, $operator ) = @_;
1914 runtime( sprintf( "right = %s; left = %s;\t/* %s */", 1915 runtime( sprintf( "right = %s; left = %s;\t/* %s */",
1915 pop_sv(), pop_sv(), $op->name ) ); 1916 pop_sv(), pop_sv(), $op->name ) );
1916 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) ); 1917 my $bool = B::Stackobj::Bool->new( B::Pseudoreg->new( "int", "b" ) );
1917 $bool->set_numeric( &$operator( "left", "right" ) ); 1918 $bool->set_numeric( &$operator( "left", "right" ) );
1918 push( @stack, $bool ); 1919 push( @stack, $bool );
1919 return $op->next; 1920 return $op->next;
1920 } 1921 }
1921 1922
1922 # coverage: ? 1923 # coverage: ?
1923 sub infix_op { 1924 sub infix_op {
1924 my $opname = shift; 1925 my $opname = shift;
1925 return sub { "$_[0] $opname $_[1]" } 1926 return sub { "$_[0] $opname $_[1]" }
1926 } 1927 }
1927 1928
1928 # coverage: ? 1929 # coverage: ?
1929 sub prefix_op { 1930 sub prefix_op {
1930 my $opname = shift; 1931 my $opname = shift;
1931 return sub { sprintf( "%s(%s)", $opname, join( ", ", @_ ) ) } 1932 return sub { sprintf( "%s(%s)", $opname, join( ", ", @_ ) ) }
1932 } 1933 }
1933 1934
1934 BEGIN { 1935 BEGIN {
1935 my $plus_op = infix_op("+"); 1936 my $plus_op = infix_op("+");
1936 my $minus_op = infix_op("-"); 1937 my $minus_op = infix_op("-");
1937 my $multiply_op = infix_op("*"); 1938 my $multiply_op = infix_op("*");
1938 my $divide_op = infix_op("/"); 1939 my $divide_op = infix_op("/");
1939 my $modulo_op = infix_op("%"); 1940 my $modulo_op = infix_op("%");
1940 my $lshift_op = infix_op("<<"); 1941 my $lshift_op = infix_op("<<");
1941 my $rshift_op = infix_op(">>"); 1942 my $rshift_op = infix_op(">>");
1942 my $scmp_op = prefix_op("sv_cmp"); 1943 my $scmp_op = prefix_op("sv_cmp");
1943 my $seq_op = prefix_op("sv_eq"); 1944 my $seq_op = prefix_op("sv_eq");
1944 my $sne_op = prefix_op("!sv_eq"); 1945 my $sne_op = prefix_op("!sv_eq");
1945 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; 1946 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
1946 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; 1947 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
1947 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; 1948 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
1948 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; 1949 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
1949 my $eq_op = infix_op("=="); 1950 my $eq_op = infix_op("==");
1950 my $ne_op = infix_op("!="); 1951 my $ne_op = infix_op("!=");
1951 my $lt_op = infix_op("<"); 1952 my $lt_op = infix_op("<");
1952 my $gt_op = infix_op(">"); 1953 my $gt_op = infix_op(">");
1953 my $le_op = infix_op("<="); 1954 my $le_op = infix_op("<=");
1954 my $ge_op = infix_op(">="); 1955 my $ge_op = infix_op(">=");
1955 1956
1956 # 1957 #
1957 # XXX The standard perl PP code has extra handling for 1958 # XXX The standard perl PP code has extra handling for
1958 # some special case arguments of these operators. 1959 # some special case arguments of these operators.
1959 # 1960 #
1960 sub pp_add { numeric_binop( $_[0], $plus_op ) } 1961 sub pp_add { numeric_binop( $_[0], $plus_op ) }
1961 sub pp_subtract { numeric_binop( $_[0], $minus_op ) } 1962 sub pp_subtract { numeric_binop( $_[0], $minus_op ) }
1962 sub pp_multiply { numeric_binop( $_[0], $multiply_op ) } 1963 sub pp_multiply { numeric_binop( $_[0], $multiply_op ) }
1963 sub pp_divide { numeric_binop( $_[0], $divide_op ) } 1964 sub pp_divide { numeric_binop( $_[0], $divide_op ) }
1964 1965
1965 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
1966 # http://perldoc.perl.org/perlop.html#Shift-Operators: 1967 # http://perldoc.perl.org/perlop.html#Shift-Operators:
1967 # 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,
1968 # else unsigned C integers are used. 1969 # else unsigned C integers are used.
1969 sub pp_left_shift { int_binop( $_[0], $lshift_op, VALID_UNSIGNED ) } 1970 sub pp_left_shift { int_binop( $_[0], $lshift_op, VALID_UNSIGNED ) }
1970 sub pp_right_shift { int_binop( $_[0], $rshift_op, VALID_UNSIGNED ) } 1971 sub pp_right_shift { int_binop( $_[0], $rshift_op, VALID_UNSIGNED ) }
1971 sub pp_i_add { int_binop( $_[0], $plus_op ) } 1972 sub pp_i_add { int_binop( $_[0], $plus_op ) }
1972 sub pp_i_subtract { int_binop( $_[0], $minus_op ) } 1973 sub pp_i_subtract { int_binop( $_[0], $minus_op ) }
1973 sub pp_i_multiply { int_binop( $_[0], $multiply_op ) } 1974 sub pp_i_multiply { int_binop( $_[0], $multiply_op ) }
1974 sub pp_i_divide { int_binop( $_[0], $divide_op ) } 1975 sub pp_i_divide { int_binop( $_[0], $divide_op ) }
1975 sub pp_i_modulo { int_binop( $_[0], $modulo_op ) } 1976 sub pp_i_modulo { int_binop( $_[0], $modulo_op ) }
1976 1977
1977 sub pp_eq { bool_numeric_binop( $_[0], $eq_op ) } 1978 sub pp_eq { bool_numeric_binop( $_[0], $eq_op ) }
1978 sub pp_ne { bool_numeric_binop( $_[0], $ne_op ) } 1979 sub pp_ne { bool_numeric_binop( $_[0], $ne_op ) }
1979 # coverage: 21 1980 # coverage: 21
1980 sub pp_lt { bool_numeric_binop( $_[0], $lt_op ) } 1981 sub pp_lt { bool_numeric_binop( $_[0], $lt_op ) }
1981 # coverage: 28 1982 # coverage: 28
1982 sub pp_gt { bool_numeric_binop( $_[0], $gt_op ) } 1983 sub pp_gt { bool_numeric_binop( $_[0], $gt_op ) }
1983 sub pp_le { bool_numeric_binop( $_[0], $le_op ) } 1984 sub pp_le { bool_numeric_binop( $_[0], $le_op ) }
1984 sub pp_ge { bool_numeric_binop( $_[0], $ge_op ) } 1985 sub pp_ge { bool_numeric_binop( $_[0], $ge_op ) }
1985 1986
1986 sub pp_i_eq { bool_int_binop( $_[0], $eq_op ) } 1987 sub pp_i_eq { bool_int_binop( $_[0], $eq_op ) }
1987 sub pp_i_ne { bool_int_binop( $_[0], $ne_op ) } 1988 sub pp_i_ne { bool_int_binop( $_[0], $ne_op ) }
1988 sub pp_i_lt { bool_int_binop( $_[0], $lt_op ) } 1989 sub pp_i_lt { bool_int_binop( $_[0], $lt_op ) }
1989 sub pp_i_gt { bool_int_binop( $_[0], $gt_op ) } 1990 sub pp_i_gt { bool_int_binop( $_[0], $gt_op ) }
1990 sub pp_i_le { bool_int_binop( $_[0], $le_op ) } 1991 sub pp_i_le { bool_int_binop( $_[0], $le_op ) }
1991 sub pp_i_ge { bool_int_binop( $_[0], $ge_op ) } 1992 sub pp_i_ge { bool_int_binop( $_[0], $ge_op ) }
1992 1993
1993 sub pp_scmp { sv_binop( $_[0], $scmp_op, INT_RESULT ) } 1994 sub pp_scmp { sv_binop( $_[0], $scmp_op, INT_RESULT ) }
1994 sub pp_slt { bool_sv_binop( $_[0], $slt_op ) } 1995 sub pp_slt { bool_sv_binop( $_[0], $slt_op ) }
1995 sub pp_sgt { bool_sv_binop( $_[0], $sgt_op ) } 1996 sub pp_sgt { bool_sv_binop( $_[0], $sgt_op ) }
1996 sub pp_sle { bool_sv_binop( $_[0], $sle_op ) } 1997 sub pp_sle { bool_sv_binop( $_[0], $sle_op ) }
1997 sub pp_sge { bool_sv_binop( $_[0], $sge_op ) } 1998 sub pp_sge { bool_sv_binop( $_[0], $sge_op ) }
1998 sub pp_seq { bool_sv_binop( $_[0], $seq_op ) } 1999 sub pp_seq { bool_sv_binop( $_[0], $seq_op ) }
1999 sub pp_sne { bool_sv_binop( $_[0], $sne_op ) } 2000 sub pp_sne { bool_sv_binop( $_[0], $sne_op ) }
2000 } 2001 }
2001 2002
2002 # 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
2003 sub pp_sassign { 2004 sub pp_sassign {
2004 my $op = shift; 2005 my $op = shift;
2005 my $backwards = $op->private & OPpASSIGN_BACKWARDS; 2006 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
2006 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};
2007 my ( $dst, $src ); 2008 my ( $dst, $src );
2008 runtime("/* pp_sassign */") if $verbose; 2009 runtime("/* pp_sassign */") if $verbose;
2009 if ( @stack >= 2 ) { 2010 if ( @stack >= 2 ) {
2010 $dst = pop @stack; 2011 $dst = pop @stack;
2011 $src = pop @stack; 2012 $src = pop @stack;
2012 ( $src, $dst ) = ( $dst, $src ) if $backwards; 2013 ( $src, $dst ) = ( $dst, $src ) if $backwards;
2013 my $type = $src->{type}; 2014 my $type = $src->{type};
2014 if ( $type == T_INT ) { 2015 if ( $type == T_INT ) {
2015 $dst->set_int( $src->as_int, $src->{flags} & VALID_UNSIGNED ); 2016 $dst->set_int( $src->as_int, $src->{flags} & VALID_UNSIGNED );
2016 } 2017 }
2017 elsif ( $type == T_DOUBLE ) { 2018 elsif ( $type == T_DOUBLE ) {
2018 $dst->set_numeric( $src->as_numeric ); 2019 $dst->set_numeric( $src->as_numeric );
2019 } 2020 }
2020 else { 2021 else {
2021 $dst->set_sv( $src->as_sv ); 2022 $dst->set_sv( $src->as_sv );
2022 } 2023 }
2023 push( @stack, $dst ); 2024 push( @stack, $dst );
2024 } 2025 }
2025 elsif ( @stack == 1 ) { 2026 elsif ( @stack == 1 ) {
2026 if ($backwards) { 2027 if ($backwards) {
2027 my $src = pop @stack; 2028 my $src = pop @stack;
2028 my $type = $src->{type}; 2029 my $type = $src->{type};
2029 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); 2030 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
2030 if ( $type == T_INT ) { 2031 if ( $type == T_INT ) {
2031 if ( $src->{flags} & VALID_UNSIGNED ) { 2032 if ( $src->{flags} & VALID_UNSIGNED ) {
2032 runtime sprintf( "sv_setuv(TOPs, %s);", $src->as_int ); 2033 runtime sprintf( "sv_setuv(TOPs, %s);", $src->as_int );
2033 } 2034 }
2034 else { 2035 else {
2035 runtime sprintf( "sv_setiv(TOPs, %s);", $src->as_int ); 2036 runtime sprintf( "sv_setiv(TOPs, %s);", $src->as_int );
2036 } 2037 }
2037 } 2038 }
2038 elsif ( $type == T_DOUBLE ) { 2039 elsif ( $type == T_DOUBLE ) {
2039 runtime sprintf( "sv_setnv(TOPs, %s);", $src->as_double ); 2040 runtime sprintf( "sv_setnv(TOPs, %s);", $src->as_double );
2040 } 2041 }
2041 else { 2042 else {
2042 runtime sprintf( "sv_setsv(TOPs, %s);", $src->as_sv ); 2043 runtime sprintf( "sv_setsv(TOPs, %s);", $src->as_sv );
2043 } 2044 }
2044 runtime("SvSETMAGIC(TOPs);"); 2045 runtime("SvSETMAGIC(TOPs);");
2045 } 2046 }
2046 else { 2047 else {
2047 my $dst = $stack[-1]; 2048 my $dst = $stack[-1];
2048 my $type = $dst->{type}; 2049 my $type = $dst->{type};
2049 runtime("sv = POPs;"); 2050 runtime("sv = POPs;");
2050 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); 2051 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
2051 if ( $type == T_INT ) { 2052 if ( $type == T_INT ) {
2052 $dst->set_int("SvIV(sv)"); 2053 $dst->set_int("SvIV(sv)");
2053 } 2054 }
2054 elsif ( $type == T_DOUBLE ) { 2055 elsif ( $type == T_DOUBLE ) {
2055 $dst->set_double("SvNV(sv)"); 2056 $dst->set_double("SvNV(sv)");
2056 } 2057 }
2057 else { 2058 else {
2058 runtime("SvSetMagicSV($dst->{sv}, sv);"); 2059 runtime("SvSetMagicSV($dst->{sv}, sv);");
2059 $dst->invalidate; 2060 $dst->invalidate;
2060 } 2061 }
2061 } 2062 }
2062 } 2063 }
2063 else { 2064 else {
2064 # empty perl stack, both at run-time 2065 # empty perl stack, both at run-time
2065 if ($backwards) { 2066 if ($backwards) {
2066 runtime("src = POPs; dst = TOPs;"); 2067 runtime("src = POPs; dst = TOPs;");
2067 } 2068 }
2068 else { 2069 else {
2069 runtime("dst = POPs; src = TOPs;"); 2070 runtime("dst = POPs; src = TOPs;");
2070 } 2071 }
2071 runtime( 2072 runtime(
2072 "MAYBE_TAINT_SASSIGN_SRC(src);", "SvSetSV(dst, src);", 2073 "MAYBE_TAINT_SASSIGN_SRC(src);", "SvSetSV(dst, src);",
2073 "SvSETMAGIC(dst);", "SETs(dst);" 2074 "SvSETMAGIC(dst);", "SETs(dst);"
2074 ); 2075 );
2075 } 2076 }
2076 return $op->next; 2077 return $op->next;
2077 } 2078 }
2078 2079
2079 # coverage: ny 2080 # coverage: ny
2080 sub pp_preinc { 2081 sub pp_preinc {
2081 my $op = shift; 2082 my $op = shift;
2082 if ( @stack >= 1 ) { 2083 if ( @stack >= 1 ) {
2083 my $obj = $stack[-1]; 2084 my $obj = $stack[-1];
2084 my $type = $obj->{type}; 2085 my $type = $obj->{type};
2085 if ( $type == T_INT || $type == T_DOUBLE ) { 2086 if ( $type == T_INT || $type == T_DOUBLE ) {
2086 $obj->set_int( $obj->as_int . " + 1" ); 2087 $obj->set_int( $obj->as_int . " + 1" );
2087 } 2088 }
2088 else { 2089 else {
2089 runtime sprintf( "PP_PREINC(%s);", $obj->as_sv ); 2090 runtime sprintf( "PP_PREINC(%s);", $obj->as_sv );
2090 $obj->invalidate(); 2091 $obj->invalidate();
2091 } 2092 }
2092 } 2093 }
2093 else { 2094 else {
2094 runtime sprintf("PP_PREINC(TOPs);"); 2095 runtime sprintf("PP_PREINC(TOPs);");
2095 } 2096 }
2096 return $op->next; 2097 return $op->next;
2097 } 2098 }
2098 2099
2099 # coverage: 1-32,35 2100 # coverage: 1-32,35
2100 sub pp_pushmark { 2101 sub pp_pushmark {
2101 my $op = shift; 2102 my $op = shift;
2102 # runtime(sprintf("/* %s */", $op->name)) if $verbose; 2103 # runtime(sprintf("/* %s */", $op->name)) if $verbose;
2103 write_back_stack(); 2104 write_back_stack();
2104 runtime("PUSHMARK(sp);"); 2105 runtime("PUSHMARK(sp);");
2105 return $op->next; 2106 return $op->next;
2106 } 2107 }
2107 2108
2108 # coverage: 28 2109 # coverage: 28
2109 sub pp_list { 2110 sub pp_list {
2110 my $op = shift; 2111 my $op = shift;
2111 runtime(sprintf("/* %s */", $op->name)) if $verbose; 2112 runtime(sprintf("/* %s */", $op->name)) if $verbose;
2112 write_back_stack(); 2113 write_back_stack();
2113 my $gimme = gimme($op); 2114 my $gimme = gimme($op);
2114 if ( not defined $gimme ) { 2115 if ( not defined $gimme ) {
2115 runtime("PP_LIST(block_gimme());"); 2116 runtime("PP_LIST(block_gimme());");
2116 } elsif ( $gimme == G_ARRAY ) { # sic 2117 } elsif ( $gimme == G_ARRAY ) { # sic
2117 runtime("POPMARK;"); # need this even though not a "full" pp_list 2118 runtime("POPMARK;"); # need this even though not a "full" pp_list
2118 } 2119 }
2119 else { 2120 else {
2120 runtime("PP_LIST($gimme);"); 2121 runtime("PP_LIST($gimme);");
2121 } 2122 }
2122 return $op->next; 2123 return $op->next;
2123 } 2124 }
2124 2125
2125 # coverage: 6,8,9,10,24,26,27,31,35 2126 # coverage: 6,8,9,10,24,26,27,31,35
2126 sub pp_entersub { 2127 sub pp_entersub {
2127 my $op = shift; 2128 my $op = shift;
2128 runtime(sprintf("/* %s */", $op->name)) if $verbose; 2129 runtime(sprintf("/* %s */", $op->name)) if $verbose;
2129 $curcop->write_back if $curcop; 2130 $curcop->write_back if $curcop;
2130 write_back_lexicals( REGISTER | TEMPORARY ); 2131 write_back_lexicals( REGISTER | TEMPORARY );
2131 write_back_stack(); 2132 write_back_stack();
2132 my $sym = doop($op); 2133 my $sym = doop($op);
2133 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){", 2134 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){",
2134 "\tPL_op = (*PL_op->op_ppaddr)(aTHX);", 2135 "\tPL_op = (*PL_op->op_ppaddr)(aTHX);",
2135 "\tSPAGAIN;}"); 2136 "\tSPAGAIN;}");
2136 $know_op = 0; 2137 $know_op = 0;
2137 invalidate_lexicals( REGISTER | TEMPORARY ); 2138 invalidate_lexicals( REGISTER | TEMPORARY );
2138 B::C::check_entersub($op); 2139 B::C::check_entersub($op);
2139 return $op->next; 2140 return $op->next;
2140 } 2141 }
2141 2142
2142 # coverage: 16,26,35,51,72,73 2143 # coverage: 16,26,35,51,72,73
2143 sub pp_bless { 2144 sub pp_bless {
2144 my $op = shift; 2145 my $op = shift;
2145 $curcop->write_back if $curcop; 2146 $curcop->write_back if $curcop;
2146 B::C::check_bless($op); 2147 B::C::check_bless($op);
2147 default_pp($op); 2148 default_pp($op);
2148 } 2149 }
2149 2150
2150 2151
2151 # coverage: ny 2152 # coverage: ny
2152 sub pp_formline { 2153 sub pp_formline {
2153 my $op = shift; 2154 my $op = shift;
2154 my $ppname = "pp_" . $op->name; 2155 my $ppname = "pp_" . $op->name;
2155 runtime(sprintf("/* %s */", $ppname)) if $verbose; 2156 runtime(sprintf("/* %s */", $ppname)) if $verbose;
2156 write_back_lexicals() unless $skip_lexicals{$ppname}; 2157 write_back_lexicals() unless $skip_lexicals{$ppname};
2157 write_back_stack() unless $skip_stack{$ppname}; 2158 write_back_stack() unless $skip_stack{$ppname};
2158 my $sym = doop($op); 2159 my $sym = doop($op);
2159 2160
2160 # See comment in pp_grepwhile to see why! 2161 # See comment in pp_grepwhile to see why!
2161 $init->add("((LISTOP*)$sym)->op_first = $sym;"); 2162 $init->add("((LISTOP*)$sym)->op_first = $sym;");
2162 runtime("if (PL_op == ((LISTOP*)($sym))->op_first) {"); 2163 runtime("if (PL_op == ((LISTOP*)($sym))->op_first) {");
2163 save_or_restore_lexical_state( ${ $op->first } ); 2164 save_or_restore_lexical_state( ${ $op->first } );
2164 runtime( sprintf( "goto %s;", label( $op->first ) ), 2165 runtime( sprintf( "goto %s;", label( $op->first ) ),
2165 "}"); 2166 "}");
2166 return $op->next; 2167 return $op->next;
2167 } 2168 }
2168 2169
2169 # coverage: 2,17,21,28,30 2170 # coverage: 2,17,21,28,30
2170 sub pp_goto { 2171 sub pp_goto {
2171 my $op = shift; 2172 my $op = shift;
2172 my $ppname = "pp_" . $op->name; 2173 my $ppname = "pp_" . $op->name;
2173 runtime(sprintf("/* %s */", $ppname)) if $verbose; 2174 runtime(sprintf("/* %s */", $ppname)) if $verbose;
2174 write_back_lexicals() unless $skip_lexicals{$ppname}; 2175 write_back_lexicals() unless $skip_lexicals{$ppname};
2175 write_back_stack() unless $skip_stack{$ppname}; 2176 write_back_stack() unless $skip_stack{$ppname};
2176 my $sym = doop($op); 2177 my $sym = doop($op);
2177 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;}");
2178 invalidate_lexicals() unless $skip_invalidate{$ppname}; 2179 invalidate_lexicals() unless $skip_invalidate{$ppname};
2179 return $op->next; 2180 return $op->next;
2180 } 2181 }
2181 2182
2182 # coverage: 1-39, c_argv.t 2 2183 # coverage: 1-39, c_argv.t 2
2183 sub pp_enter { 2184 sub pp_enter {
2184 # 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
2185 if (0 and $inline_ops) { 2186 if (0 and $inline_ops) {
2186 my $op = shift; 2187 my $op = shift;
2187 runtime(sprintf("/* %s */", $op->name)) if $verbose; 2188 runtime(sprintf("/* %s */", $op->name)) if $verbose;
2188 warn "inlining enter\n" if $debug{op}; 2189 warn "inlining enter\n" if $debug{op};
2189 $curcop->write_back if $curcop; 2190 $curcop->write_back if $curcop;
2190 if (!($op->flags & OPf_WANT)) { 2191 if (!($op->flags & OPf_WANT)) {
2191 my $cxix = $#cxstack; 2192 my $cxix = $#cxstack;
2192 if ( $cxix >= 0 ) { 2193 if ( $cxix >= 0 ) {
2193 if ( $op->flags & OPf_SPECIAL ) { 2194 if ( $op->flags & OPf_SPECIAL ) {
2194 runtime "gimme = block_gimme();"; 2195 runtime "gimme = block_gimme();";
2195 } else { 2196 } else {
2196 runtime "gimme = cxstack[cxstack_ix].blk_gimme;"; 2197 runtime "gimme = cxstack[cxstack_ix].blk_gimme;";
2197 } 2198 }
2198 } else { 2199 } else {
2199 runtime "gimme = G_SCALAR;"; 2200 runtime "gimme = G_SCALAR;";
2200 } 2201 }
2201 } else { 2202 } else {
2202 runtime "gimme = OP_GIMME(PL_op, -1);"; 2203 runtime "gimme = OP_GIMME(PL_op, -1);";
2203 } 2204 }
2204 runtime($] >= 5.011001 and $] < 5.011004 2205 runtime($] >= 5.011001 and $] < 5.011004
2205 ? 'ENTER_with_name("block");' : 'ENTER;', 2206 ? 'ENTER_with_name("block");' : 'ENTER;',
2206 "SAVETMPS;", 2207 "SAVETMPS;",
2207 "PUSHBLOCK(cx, CXt_BLOCK, SP);"); 2208 "PUSHBLOCK(cx, CXt_BLOCK, SP);");
2208 return $op->next; 2209 return $op->next;
2209 } else { 2210 } else {
2210 return default_pp(@_); 2211 return default_pp(@_);
2211 } 2212 }
2212 } 2213 }
2213 2214
2214 # coverage: ny 2215 # coverage: ny
2215 sub pp_enterwrite { pp_entersub(@_) } 2216 sub pp_enterwrite { pp_entersub(@_) }
2216 2217
2217 # coverage: 6,8,9,10,24,26,27,31 2218 # coverage: 6,8,9,10,24,26,27,31
2218 sub pp_leavesub { 2219 sub pp_leavesub {
2219 my $op = shift; 2220 my $op = shift;
2220 my $ppname = "pp_" . $op->name; 2221 my $ppname = "pp_" . $op->name;
2221 write_back_lexicals() unless $skip_lexicals{$ppname}; 2222 write_back_lexicals() unless $skip_lexicals{$ppname};
2222 write_back_stack() unless $skip_stack{$ppname}; 2223 write_back_stack() unless $skip_stack{$ppname};
2223 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){", 2224 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){",
2224 "\tPUTBACK;return 0;", 2225 "\tPUTBACK;return 0;",
2225 "}"); 2226 "}");
2226 doop($op); 2227 doop($op);
2227 return $op->next; 2228 return $op->next;
2228 } 2229 }
2229 2230
2230 # coverage: ny 2231 # coverage: ny
2231 sub pp_leavewrite { 2232 sub pp_leavewrite {
2232 my $op = shift; 2233 my $op = shift;
2233 write_back_lexicals( REGISTER | TEMPORARY ); 2234 write_back_lexicals( REGISTER | TEMPORARY );
2234 write_back_stack(); 2235 write_back_stack();
2235 my $sym = doop($op); 2236 my $sym = doop($op);
2236 2237
2237 # XXX Is this the right way to distinguish between it returning 2238 # XXX Is this the right way to distinguish between it returning
2238 # CvSTART(cv) (via doform) and pop_return()? 2239 # CvSTART(cv) (via doform) and pop_return()?
2239 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); 2240 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
2240 runtime("SPAGAIN;"); 2241 runtime("SPAGAIN;");
2241 $know_op = 0; 2242 $know_op = 0;
2242 invalidate_lexicals( REGISTER | TEMPORARY ); 2243 invalidate_lexicals( REGISTER | TEMPORARY );
2243 return $op->next; 2244 return $op->next;
2244 } 2245 }
2245 2246
2246 # coverage: ny 2247 # coverage: ny
2247 sub pp_entergiven { pp_enterwrite(@_) } 2248 sub pp_entergiven { pp_enterwrite(@_) }
2248 # coverage: ny 2249 # coverage: ny
2249 sub pp_leavegiven { pp_leavewrite(@_) } 2250 sub pp_leavegiven { pp_leavewrite(@_) }
2250 2251
2251 sub doeval { 2252 sub doeval {
2252 my $op = shift; 2253 my $op = shift;
2253 $curcop->write_back; 2254 $curcop->write_back;
2254 write_back_lexicals( REGISTER | TEMPORARY ); 2255 write_back_lexicals( REGISTER | TEMPORARY );
2255 write_back_stack(); 2256 write_back_stack();
2256 my $sym = loadop($op); 2257 my $sym = loadop($op);
2257 my $ppaddr = $op->ppaddr; 2258 my $ppaddr = $op->ppaddr;
2258 runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); 2259 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
2259 $know_op = 1; 2260 $know_op = 1;
2260 invalidate_lexicals( REGISTER | TEMPORARY ); 2261 invalidate_lexicals( REGISTER | TEMPORARY );
2261 return $op->next; 2262 return $op->next;
2262 } 2263 }
2263 2264
2264 # coverage: 12 2265 # coverage: 12
2265 sub pp_entereval { doeval(@_) } 2266 sub pp_entereval { doeval(@_) }
2266 # coverage: ny 2267 # coverage: ny
2267 sub pp_dofile { doeval(@_) } 2268 sub pp_dofile { doeval(@_) }
2268 2269
2269 # coverage: 28 2270 # coverage: 28
2270 #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.
2271 sub pp_require { 2272 sub pp_require {
2272 my $op = shift; 2273 my $op = shift;
2273 $curcop->write_back; 2274 $curcop->write_back;
2274 write_back_lexicals( REGISTER | TEMPORARY ); 2275 write_back_lexicals( REGISTER | TEMPORARY );
2275 write_back_stack(); 2276 write_back_stack();
2276 my $sym = doop($op); 2277 my $sym = doop($op);
2277 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ) {", 2278 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ) {",
2278 #(test 28). 2279 #(test 28).
2279 " PL_op = (*PL_op->op_ppaddr)(aTHX);", 2280 " PL_op = (*PL_op->op_ppaddr)(aTHX);",
2280 " SPAGAIN;", 2281 " SPAGAIN;",
2281 "}"); 2282 "}");
2282 $know_op = 1; 2283 $know_op = 1;
2283 invalidate_lexicals( REGISTER | TEMPORARY ); 2284 invalidate_lexicals( REGISTER | TEMPORARY );
2284 B::C::check_require($op); # mark package 2285 B::C::check_require($op); # mark package
2285 return $op->next; 2286 return $op->next;
2286 } 2287 }
2287 2288
2288 # coverage: 32 2289 # coverage: 32
2289 sub pp_entertry { 2290 sub pp_entertry {
2290 my $op = shift; 2291 my $op = shift;
2291 $curcop->write_back; 2292 $curcop->write_back;
2292 write_back_lexicals( REGISTER | TEMPORARY ); 2293 write_back_lexicals( REGISTER | TEMPORARY );
2293 write_back_stack(); 2294 write_back_stack();
2294 my $sym = doop($op); 2295 my $sym = doop($op);
2295 $entertry_defined = 1; 2296 $entertry_defined = 1;
2296 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
2297 # jump past leavetry 2298 # jump past leavetry
2298 $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
2299 my $l = label( $next ); 2300 my $l = label( $next );
2300 debug "ENTERTRY label=$l (".ref($op).") ->".$next->name."(".ref($next).")\n"; 2301 debug "ENTERTRY label=$l (".ref($op).") ->".$next->name."(".ref($next).")\n";
2301 runtime(sprintf( "PP_ENTERTRY(%s);", $l)); 2302 runtime(sprintf( "PP_ENTERTRY(%s);", $l));
2302 if ($next->isa('B::COP')) { 2303 if ($next->isa('B::COP')) {
2303 push_label($next, 'nextstate'); 2304 push_label($next, 'nextstate');
2304 } else { 2305 } else {
2305 push_label($op->other, 'leavetry') if $op->can("other"); 2306 push_label($op->other, 'leavetry') if $op->can("other");
2306 } 2307 }
2307 invalidate_lexicals( REGISTER | TEMPORARY ); 2308 invalidate_lexicals( REGISTER | TEMPORARY );
2308 return $op->next; 2309 return $op->next;
2309 } 2310 }
2310 2311
2311 # coverage: 32 2312 # coverage: 32
2312 sub pp_leavetry { 2313 sub pp_leavetry {
2313 my $op = shift; 2314 my $op = shift;
2314 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;
2315 default_pp($op); 2316 default_pp($op);
2316 runtime("PP_LEAVETRY;"); 2317 runtime("PP_LEAVETRY;");
2317 write_label($op->next); 2318 write_label($op->next);
2318 return $op->next; 2319 return $op->next;
2319 } 2320 }
2320 2321
2321 # coverage: ny 2322 # coverage: ny
2322 sub pp_grepstart { 2323 sub pp_grepstart {
2323 my $op = shift; 2324 my $op = shift;
2324 if ( $need_freetmps && $freetmps_each_loop ) { 2325 if ( $need_freetmps && $freetmps_each_loop ) {
2325 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up 2326 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
2326 $need_freetmps = 0; 2327 $need_freetmps = 0;
2327 } 2328 }
2328 write_back_stack(); 2329 write_back_stack();
2329 my $sym = doop($op); 2330 my $sym = doop($op);
2330 my $next = $op->next; 2331 my $next = $op->next;
2331 $next->save; 2332 $next->save;
2332 my $nexttonext = $next->next; 2333 my $nexttonext = $next->next;
2333 $nexttonext->save; 2334 $nexttonext->save;
2334 save_or_restore_lexical_state($$nexttonext); 2335 save_or_restore_lexical_state($$nexttonext);
2335 runtime( 2336 runtime(
2336 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;", 2337 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;",
2337 label($nexttonext) ) 2338 label($nexttonext) )
2338 ); 2339 );
2339 return $op->next->other; 2340 return $op->next->other;
2340 } 2341 }
2341 2342
2342 # coverage: ny 2343 # coverage: ny
2343 sub pp_mapstart { 2344 sub pp_mapstart {
2344 my $op = shift; 2345 my $op = shift;
2345 if ( $need_freetmps && $freetmps_each_loop ) { 2346 if ( $need_freetmps && $freetmps_each_loop ) {
2346 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up 2347 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
2347 $need_freetmps = 0; 2348 $need_freetmps = 0;
2348 } 2349 }
2349 write_back_stack(); 2350 write_back_stack();
2350 2351
2351 # 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
2352 # we need to be able to distinguish the two at runtime. 2353 # we need to be able to distinguish the two at runtime.
2353 my $sym = doop($op); 2354 my $sym = doop($op);
2354 my $next = $op->next; 2355 my $next = $op->next;
2355 $next->save; 2356 $next->save;
2356 my $nexttonext = $next->next; 2357 my $nexttonext = $next->next;
2357 $nexttonext->save; 2358 $nexttonext->save;
2358 save_or_restore_lexical_state($$nexttonext); 2359 save_or_restore_lexical_state($$nexttonext);
2359 runtime( 2360 runtime(
2360 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;", 2361 sprintf( "if (PL_op == (($sym)->op_next)->op_next) goto %s;",
2361 label($nexttonext) ) 2362 label($nexttonext) )
2362 ); 2363 );
2363 return $op->next->other; 2364 return $op->next->other;
2364 } 2365 }
2365 2366
2366 # coverage: ny 2367 # coverage: ny
2367 sub pp_grepwhile { 2368 sub pp_grepwhile {
2368 my $op = shift; 2369 my $op = shift;
2369 my $next = $op->next; 2370 my $next = $op->next;
2370 unshift( @bblock_todo, $next ); 2371 unshift( @bblock_todo, $next );
2371 write_back_lexicals(); 2372 write_back_lexicals();
2372 write_back_stack(); 2373 write_back_stack();
2373 my $sym = doop($op); 2374 my $sym = doop($op);
2374 2375
2375 # 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
2376 # 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
2377 # 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
2378 # 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
2379 # 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).
2380 $init->add("((LOGOP*)$sym)->op_next = $sym;"); 2381 $init->add("((LOGOP*)$sym)->op_next = $sym;");
2381 save_or_restore_lexical_state($$next); 2382 save_or_restore_lexical_state($$next);
2382 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) ) );
2383 $know_op = 0; 2384 $know_op = 0;
2384 return $op->other; 2385 return $op->other;
2385 } 2386 }
2386 2387
2387 # coverage: ny 2388 # coverage: ny
2388 sub pp_mapwhile { pp_grepwhile(@_) } 2389 sub pp_mapwhile { pp_grepwhile(@_) }
2389 2390
2390 # coverage: 24 2391 # coverage: 24
2391 sub pp_return { 2392 sub pp_return {
2392 my $op = shift; 2393 my $op = shift;
2393 write_back_lexicals( REGISTER | TEMPORARY ); 2394 write_back_lexicals( REGISTER | TEMPORARY );
2394 write_back_stack(); 2395 write_back_stack();
2395 doop($op); 2396 doop($op);
2396 runtime( "PUTBACK;", "return PL_op;" ); 2397 runtime( "PUTBACK;", "return PL_op;" );
2397 $know_op = 0; 2398 $know_op = 0;
2398 return $op->next; 2399 return $op->next;
2399 } 2400 }
2400 2401
2401 sub nyi { 2402 sub nyi {
2402 my $op = shift; 2403 my $op = shift;
2403 warn sprintf( "%s not yet implemented properly\n", $op->ppaddr ); 2404 warn sprintf( "%s not yet implemented properly\n", $op->ppaddr );
2404 return default_pp($op); 2405 return default_pp($op);
2405 } 2406 }
2406 2407
2407 # coverage: 17 2408 # coverage: 17
2408 sub pp_range { 2409 sub pp_range {
2409 my $op = shift; 2410 my $op = shift;
2410 my $flags = $op->flags; 2411 my $flags = $op->flags;
2411 if ( !( $flags & OPf_WANT ) ) { 2412 if ( !( $flags & OPf_WANT ) ) {
2412 if ($strict) { 2413 if ($strict) {
2413 error("context of range unknown at compile-time\n"); 2414 error("context of range unknown at compile-time\n");
2414 } else { 2415 } else {
2415 warn("context of range unknown at compile-time\n"); 2416 warn("context of range unknown at compile-time\n");
2416 runtime('warn("context of range unknown at compile-time");'); 2417 runtime('warn("context of range unknown at compile-time");');
2417 } 2418 }
2418 return default_pp($op); 2419 return default_pp($op);
2419 } 2420 }
2420 write_back_lexicals(); 2421 write_back_lexicals();
2421 write_back_stack(); 2422 write_back_stack();
2422 unless ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) { 2423 unless ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) {
2423 # We need to save our UNOP structure since pp_flop uses 2424 # We need to save our UNOP structure since pp_flop uses
2424 # 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.
2425 $op->save; 2426 $op->save;
2426 save_or_restore_lexical_state( ${ $op->other } ); 2427 save_or_restore_lexical_state( ${ $op->other } );
2427 runtime sprintf( "if (SvTRUE(PL_curpad[%d])) goto %s;", 2428 runtime sprintf( "if (SvTRUE(PL_curpad[%d])) goto %s;",
2428 $op->targ, label( $op->other ) ); 2429 $op->targ, label( $op->other ) );
2429 unshift( @bblock_todo, $op->other ); 2430 unshift( @bblock_todo, $op->other );
2430 } 2431 }
2431 return $op->next; 2432 return $op->next;
2432 } 2433 }
2433 2434
2434 # coverage: 17, 30 2435 # coverage: 17, 30
2435 sub pp_flip { 2436 sub pp_flip {
2436 my $op = shift; 2437 my $op = shift;
2437 my $flags = $op->flags; 2438 my $flags = $op->flags;
2438 if ( !( $flags & OPf_WANT ) ) { 2439 if ( !( $flags & OPf_WANT ) ) {
2439 if ($strict) { 2440 if ($strict) {
2440 error("context of flip unknown at compile-time\n"); 2441 error("context of flip unknown at compile-time\n");
2441 } else { 2442 } else {
2442 warn("context of flip unknown at compile-time\n"); 2443 warn("context of flip unknown at compile-time\n");
2443 runtime('warn("context of flip unknown at compile-time");'); 2444 runtime('warn("context of flip unknown at compile-time");');
2444 } 2445 }
2445 return default_pp($op); 2446 return default_pp($op);
2446 } 2447 }
2447 if ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) { 2448 if ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ) {
2448 return $op->first->other; 2449 return $op->first->other;
2449 } 2450 }
2450 write_back_lexicals(); 2451 write_back_lexicals();
2451 write_back_stack(); 2452 write_back_stack();
2452 # We need to save our UNOP structure since pp_flop uses 2453 # We need to save our UNOP structure since pp_flop uses
2453 # 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.
2454 $op->save; 2455 $op->save;
2455 my $ix = $op->targ; 2456 my $ix = $op->targ;
2456 my $rangeix = $op->first->targ; 2457 my $rangeix = $op->first->targ;
2457 runtime( 2458 runtime(
2458 ( $op->private & OPpFLIP_LINENUM ) 2459 ( $op->private & OPpFLIP_LINENUM )
2459 ? "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))) {"
2460 : "if (SvTRUE(TOPs)) {" 2461 : "if (SvTRUE(TOPs)) {"
2461 ); 2462 );
2462 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);"); 2463 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
2463 if ( $op->flags & OPf_SPECIAL ) { 2464 if ( $op->flags & OPf_SPECIAL ) {
2464 runtime("sv_setiv(PL_curpad[$ix], 1);"); 2465 runtime("sv_setiv(PL_curpad[$ix], 1);");
2465 } 2466 }
2466 else { 2467 else {
2467 save_or_restore_lexical_state( ${ $op->first->other } ); 2468 save_or_restore_lexical_state( ${ $op->first->other } );
2468 runtime( "\tsv_setiv(PL_curpad[$ix], 0);", 2469 runtime( "\tsv_setiv(PL_curpad[$ix], 0);",
2469 "\tsp--;", sprintf( "\tgoto %s;", label( $op->first->other ) ) ); 2470 "\tsp--;", sprintf( "\tgoto %s;", label( $op->first->other ) ) );
2470 } 2471 }
2471 runtime( "}", qq{sv_setpv(PL_curpad[$ix], "");}, "SETs(PL_curpad[$ix]);" ); 2472 runtime( "}", qq{sv_setpv(PL_curpad[$ix], "");}, "SETs(PL_curpad[$ix]);" );
2472 $know_op = 0; 2473 $know_op = 0;
2473 return $op->next; 2474 return $op->next;
2474 } 2475 }
2475 2476
2476 # coverage: 17 2477 # coverage: 17
2477 sub pp_flop { 2478 sub pp_flop {
2478 my $op = shift; 2479 my $op = shift;
2479 default_pp($op); 2480 default_pp($op);
2480 $know_op = 0; 2481 $know_op = 0;
2481 return $op->next; 2482 return $op->next;
2482 } 2483 }
2483 2484
2484 sub enterloop { 2485 sub enterloop {
2485 my $op = shift; 2486 my $op = shift;
2486 my $nextop = $op->nextop; 2487 my $nextop = $op->nextop;
2487 my $lastop = $op->lastop; 2488 my $lastop = $op->lastop;
2488 my $redoop = $op->redoop; 2489 my $redoop = $op->redoop;
2489 $curcop->write_back if $curcop; 2490 $curcop->write_back if $curcop;
2490 debug "enterloop: pushing on cxstack\n" if $debug{cxstack}; 2491 debug "enterloop: pushing on cxstack\n" if $debug{cxstack};
2491 push( 2492 push(
2492 @cxstack, 2493 @cxstack,
2493 { 2494 {
2494 type => $PERL512 ? CXt_LOOP_PLAIN : CXt_LOOP, 2495 type => $PERL512 ? CXt_LOOP_PLAIN : CXt_LOOP,
2495 op => $op, 2496 op => $op,
2496 "label" => $curcop->[0]->label, 2497 "label" => $curcop->[0]->label,
2497 nextop => $nextop, 2498 nextop => $nextop,
2498 lastop => $lastop, 2499 lastop => $lastop,
2499 redoop => $redoop 2500 redoop => $redoop
2500 } 2501 }
2501 ); 2502 );
2502 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};
2503 $nextop->save; 2504 $nextop->save;
2504 $lastop->save; 2505 $lastop->save;
2505 $redoop->save; 2506 $redoop->save;
2506 # 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
2507 # never executed. This is needed to get @cxstack right. 2508 # never executed. This is needed to get @cxstack right.
2508 # Use case: while(1) { .. } 2509 # Use case: while(1) { .. }
2509 unshift @bblock_todo, ($lastop); 2510 unshift @bblock_todo, ($lastop);
2510 if (0 and $inline_ops and $op->name eq 'enterloop') { 2511 if (0 and $inline_ops and $op->name eq 'enterloop') {
2511 warn "inlining enterloop\n" if $debug{op}; 2512 warn "inlining enterloop\n" if $debug{op};
2512 # XXX = GIMME_V fails on freebsd7 5.8.8 (28) 2513 # XXX = GIMME_V fails on freebsd7 5.8.8 (28)
2513 # = block_gimme() fails on the rest, but passes on freebsd7 2514 # = block_gimme() fails on the rest, but passes on freebsd7
2514 runtime "gimme = GIMME_V;"; # XXX 2515 runtime "gimme = GIMME_V;"; # XXX
2515 if ($PERL512) { 2516 if ($PERL512) {
2516 runtime('ENTER_with_name("loop1");', 2517 runtime('ENTER_with_name("loop1");',
2517 'SAVETMPS;', 2518 'SAVETMPS;',
2518 'ENTER_with_name("loop2");', 2519 'ENTER_with_name("loop2");',
2519 'PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);', 2520 'PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);',
2520 'PUSHLOOP_PLAIN(cx, SP);'); 2521 'PUSHLOOP_PLAIN(cx, SP);');
2521 } else { 2522 } else {
2522 runtime('ENTER;', 2523 runtime('ENTER;',
2523 'SAVETMPS;', 2524 'SAVETMPS;',
2524 'ENTER;', 2525 'ENTER;',
2525 'PUSHBLOCK(cx, CXt_LOOP, SP);', 2526 'PUSHBLOCK(cx, CXt_LOOP, SP);',
2526 'PUSHLOOP(cx, 0, SP);'); 2527 'PUSHLOOP(cx, 0, SP);');
2527 } 2528 }
2528 return $op->next; 2529 return $op->next;
2529 } else { 2530 } else {
2530 return default_pp($op); 2531 return default_pp($op);
2531 } 2532 }
2532 } 2533 }
2533 2534
2534 # coverage: 6,21,28,30 2535 # coverage: 6,21,28,30
2535 sub pp_enterloop { enterloop(@_) } 2536 sub pp_enterloop { enterloop(@_) }
2536 # coverage: 2 2537 # coverage: 2
2537 sub pp_enteriter { enterloop(@_) } 2538 sub pp_enteriter { enterloop(@_) }
2538 2539
2539 # coverage: 6,21,28,30 2540 # coverage: 6,21,28,30
2540 sub pp_leaveloop { 2541 sub pp_leaveloop {
2541 my $op = shift; 2542 my $op = shift;
2542 if ( !@cxstack ) { 2543 if ( !@cxstack ) {
2543 die "panic: leaveloop, no cxstack"; 2544 die "panic: leaveloop, no cxstack";
2544 } 2545 }
2545 debug "leaveloop: popping from cxstack\n" if $debug{cxstack}; 2546 debug "leaveloop: popping from cxstack\n" if $debug{cxstack};
2546 pop(@cxstack); 2547 pop(@cxstack);
2547 return default_pp($op); 2548 return default_pp($op);
2548 } 2549 }
2549 2550
2550 # coverage: ? 2551 # coverage: ?
2551 sub pp_next { 2552 sub pp_next {
2552 my $op = shift; 2553 my $op = shift;
2553 my $cxix; 2554 my $cxix;
2554 if ( $op->flags & OPf_SPECIAL ) { 2555 if ( $op->flags & OPf_SPECIAL ) {
2555 $cxix = dopoptoloop(); 2556 $cxix = dopoptoloop();
2556 if ( $cxix < 0 ) { 2557 if ( $cxix < 0 ) {
2557 warn "Warning: \"next\" used outside loop\n"; 2558 warn "Warning: \"next\" used outside loop\n";
2558 return default_pp($op); # no optimization 2559 return default_pp($op); # no optimization
2559 } 2560 }
2560 } 2561 }
2561 else { 2562 else {
2562 my $label = $op->pv; 2563 my $label = $op->pv;
2563 if ($label) { 2564 if ($label) {
2564 $cxix = dopoptolabel( $label ); 2565 $cxix = dopoptolabel( $label );
2565 if ( $cxix < 0 ) { 2566 if ( $cxix < 0 ) {
2566 # coverage: t/testcc 21 2567 # coverage: t/testcc 21
2567 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 ));
2568 $labels->{nlabel}->{$label} = $$op; 2569 $labels->{nlabel}->{$label} = $$op;
2569 return $op->next; 2570 return $op->next;
2570 } 2571 }
2571 } 2572 }
2572 # Add support to leave non-loop blocks. 2573 # Add support to leave non-loop blocks.
2573 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 2574 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
2574 if (!$cxstack[$cxix]->{'nextop'} or !$cxstack[$cxix]->{'label'}) { 2575 if (!$cxstack[$cxix]->{'nextop'} or !$cxstack[$cxix]->{'label'}) {
2575 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");
2576 } 2577 }
2577 } 2578 }
2578 } 2579 }
2579 default_pp($op); 2580 default_pp($op);
2580 my $nextop = $cxstack[$cxix]->{nextop}; 2581 my $nextop = $cxstack[$cxix]->{nextop};
2581 if ($nextop) { 2582 if ($nextop) {
2582 push( @bblock_todo, $nextop ); 2583 push( @bblock_todo, $nextop );
2583 save_or_restore_lexical_state($$nextop); 2584 save_or_restore_lexical_state($$nextop);
2584 runtime( sprintf( "goto %s;", label($nextop) ) ); 2585 runtime( sprintf( "goto %s;", label($nextop) ) );
2585 } 2586 }
2586 return $op->next; 2587 return $op->next;
2587 } 2588 }
2588 2589
2589 # coverage: ? 2590 # coverage: ?
2590 sub pp_redo { 2591 sub pp_redo {
2591 my $op = shift; 2592 my $op = shift;
2592 my $cxix; 2593 my $cxix;
2593 if ( $op->flags & OPf_SPECIAL ) { 2594 if ( $op->flags & OPf_SPECIAL ) {
2594 $cxix = dopoptoloop(); 2595 $cxix = dopoptoloop();
2595 if ( $cxix < 0 ) { 2596 if ( $cxix < 0 ) {
2596 warn("Warning: \"redo\" used outside loop\n"); 2597 warn("Warning: \"redo\" used outside loop\n");
2597 return default_pp($op); # no optimization 2598 return default_pp($op); # no optimization
2598 } 2599 }
2599 } 2600 }
2600 else { 2601 else {
2601 my $label = $op->pv; 2602 my $label = $op->pv;
2602 if ($label) { 2603 if ($label) {
2603 $cxix = dopoptolabel( $label ); 2604 $cxix = dopoptolabel( $label );
2604 if ( $cxix < 0 ) { 2605 if ( $cxix < 0 ) {
2605 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 ));
2606 $labels->{nlabel}->{$label} = $$op; 2607 $labels->{nlabel}->{$label} = $$op;
2607 return $op->next; 2608 return $op->next;
2608 } 2609 }
2609 } 2610 }
2610 # Add support to leave non-loop blocks. 2611 # Add support to leave non-loop blocks.
2611 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 2612 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
2612 if (!$cxstack[$cxix]->{'redoop'} or !$cxstack[$cxix]->{'label'}) { 2613 if (!$cxstack[$cxix]->{'redoop'} or !$cxstack[$cxix]->{'label'}) {
2613 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");
2614 } 2615 }
2615 } 2616 }
2616 } 2617 }
2617 default_pp($op); 2618 default_pp($op);
2618 my $redoop = $cxstack[$cxix]->{redoop}; 2619 my $redoop = $cxstack[$cxix]->{redoop};
2619 if ($redoop) { 2620 if ($redoop) {
2620 push( @bblock_todo, $redoop ); 2621 push( @bblock_todo, $redoop );
2621 save_or_restore_lexical_state($$redoop); 2622 save_or_restore_lexical_state($$redoop);
2622 runtime( sprintf( "goto %s;", label($redoop) ) ); 2623 runtime( sprintf( "goto %s;", label($redoop) ) );
2623 } 2624 }
2624 return $op->next; 2625 return $op->next;
2625 } 2626 }
2626 2627
2627 # coverage: issue36, cc_last.t 2628 # coverage: issue36, cc_last.t
2628 sub pp_last { 2629 sub pp_last {
2629 my $op = shift; 2630 my $op = shift;
2630 my $cxix; 2631 my $cxix;
2631 if ( $op->flags & OPf_SPECIAL ) { 2632 if ( $op->flags & OPf_SPECIAL ) {
2632 $cxix = dopoptoloop(); 2633 $cxix = dopoptoloop();
2633 if ( $cxix < 0 ) { 2634 if ( $cxix < 0 ) {
2634 warn("Warning: \"last\" used outside loop\n"); 2635 warn("Warning: \"last\" used outside loop\n");
2635 #return default_pp($op); # no optimization 2636 #return default_pp($op); # no optimization
2636 } 2637 }
2637 } 2638 }
2638 else { 2639 else {
2639 my $label = $op->pv; 2640 my $label = $op->pv;
2640 if ($label) { 2641 if ($label) {
2641 $cxix = dopoptolabel( $label ); 2642 $cxix = dopoptolabel( $label );
2642 if ( $cxix < 0 ) { 2643 if ( $cxix < 0 ) {
2643 # coverage: cc_last.t 2 (ok) 4 (ok) 2644 # coverage: cc_last.t 2 (ok) 4 (ok)
2644 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 ));
2645 # last does not jump into the future, by name without $$op 2646 # last does not jump into the future, by name without $$op
2646 # instead it should jump to the block afterwards 2647 # instead it should jump to the block afterwards
2647 $labels->{nlabel}->{$label} = $$op; 2648 $labels->{nlabel}->{$label} = $$op;
2648 return $op->next; 2649 return $op->next;
2649 } 2650 }
2650 } 2651 }
2651 2652
2652 # 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
2653 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) { 2654 if ( CxTYPE_no_LOOP( $cxstack[$cxix] ) ) {
2654 if (!$cxstack[$cxix]->{'lastop'} or !$cxstack[$cxix]->{'label'}) { 2655 if (!$cxstack[$cxix]->{'lastop'} or !$cxstack[$cxix]->{'label'}) {
2655 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");
2656 } 2657 }
2657 } 2658 }
2658 } 2659 }
2659 default_pp($op); 2660 default_pp($op);
2660 if ($cxstack[$cxix]->{lastop} and $cxstack[$cxix]->{lastop}->next) { 2661 if ($cxstack[$cxix]->{lastop} and $cxstack[$cxix]->{lastop}->next) {
2661 my $lastop = $cxstack[$cxix]->{lastop}->next; 2662 my $lastop = $cxstack[$cxix]->{lastop}->next;
2662 push( @bblock_todo, $lastop ); 2663 push( @bblock_todo, $lastop );
2663 save_or_restore_lexical_state($$lastop); 2664 save_or_restore_lexical_state($$lastop);
2664 runtime( sprintf( "goto %s;", label($lastop) ) ); 2665 runtime( sprintf( "goto %s;", label($lastop) ) );
2665 } 2666 }
2666 return $op->next; 2667 return $op->next;
2667 } 2668 }
2668 2669
2669 # coverage: 3,4 2670 # coverage: 3,4
2670 sub pp_subst { 2671 sub pp_subst {
2671 my $op = shift; 2672 my $op = shift;
2672 write_back_lexicals(); 2673 write_back_lexicals();
2673 write_back_stack(); 2674 write_back_stack();
2674 my $sym = doop($op); 2675 my $sym = doop($op);
2675 my $replroot = $op->pmreplroot; 2676 my $replroot = $op->pmreplroot;
2676 if ($$replroot) { 2677 if ($$replroot) {
2677 save_or_restore_lexical_state($$replroot); 2678 save_or_restore_lexical_state($$replroot);
2678 runtime sprintf( 2679 runtime sprintf(
2679 "if (PL_op == ((PMOP*)(%s))%s) goto %s;", 2680 "if (PL_op == ((PMOP*)(%s))%s) goto %s;",
2680 $sym, $PERL510 ? "->op_pmreplrootu.op_pmreplroot" : "->op_pmreplroot", 2681 $sym, $PERL510 ? "->op_pmreplrootu.op_pmreplroot" : "->op_pmreplroot",
2681 label($replroot) 2682 label($replroot)
2682 ); 2683 );
2683 $op->pmreplstart->save; 2684 $op->pmreplstart->save;
2684 push( @bblock_todo, $replroot ); 2685 push( @bblock_todo, $replroot );
2685 } 2686 }
2686 invalidate_lexicals(); 2687 invalidate_lexicals();
2687 return $op->next; 2688 return $op->next;
2688 } 2689 }
2689 2690
2690 # coverage: 3 2691 # coverage: 3
2691 sub pp_substcont { 2692 sub pp_substcont {
2692 my $op = shift; 2693 my $op = shift;
2693 write_back_lexicals(); 2694 write_back_lexicals();
2694 write_back_stack(); 2695 write_back_stack();
2695 doop($op); 2696 doop($op);
2696 my $pmop = $op->other; 2697 my $pmop = $op->other;
2697 #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;
2698 2699
2699 # my $pmopsym = objsym($pmop); 2700 # my $pmopsym = objsym($pmop);
2700 my $pmopsym = $pmop->save; # XXX can this recurse? 2701 my $pmopsym = $pmop->save; # XXX can this recurse?
2701 # warn "pmopsym = $pmopsym\n" if $verbose; 2702 # warn "pmopsym = $pmopsym\n" if $verbose;
2702 save_or_restore_lexical_state( ${ $pmop->pmreplstart } ); 2703 save_or_restore_lexical_state( ${ $pmop->pmreplstart } );
2703 runtime sprintf( 2704 runtime sprintf(
2704 "if (PL_op == ((PMOP*)(%s))%s) goto %s;", 2705 "if (PL_op == ((PMOP*)(%s))%s) goto %s;",
2705 $pmopsym, 2706 $pmopsym,
2706 $PERL510 ? "->op_pmstashstartu.op_pmreplstart" : "->op_pmreplstart", 2707 $PERL510 ? "->op_pmstashstartu.op_pmreplstart" : "->op_pmreplstart",
2707 label( $pmop->pmreplstart ) 2708 label( $pmop->pmreplstart )
2708 ); 2709 );
2709 push( @bblock_todo, $pmop->pmreplstart ); 2710 push( @bblock_todo, $pmop->pmreplstart );
2710 invalidate_lexicals(); 2711 invalidate_lexicals();
2711 return $pmop->next; 2712 return $pmop->next;
2712 } 2713 }
2713 2714
2714 # coverage: issue24 2715 # coverage: issue24
2715 # resolve the DBM library at compile-time, not at run-time 2716 # resolve the DBM library at compile-time, not at run-time
2716 sub pp_dbmopen { 2717 sub pp_dbmopen {
2717 my $op = shift; 2718 my $op = shift;
2718 require AnyDBM_File; 2719 require AnyDBM_File;
2719 my $dbm = $AnyDBM_File::ISA[0]; 2720 my $dbm = $AnyDBM_File::ISA[0];
2720 svref_2object( \&{"$dbm\::bootstrap"} )->save; 2721 svref_2object( \&{"$dbm\::bootstrap"} )->save;
2721 return default_pp($op); 2722 return default_pp($op);
2722 } 2723 }
2723 2724
2724 sub default_pp { 2725 sub default_pp {
2725 my $op = shift; 2726 my $op = shift;
2726 my $ppname = "pp_" . $op->name; 2727 my $ppname = "pp_" . $op->name;
2727 # runtime(sprintf("/* %s */", $ppname)) if $verbose; 2728 # runtime(sprintf("/* %s */", $ppname)) if $verbose;
2728 if ( $curcop and $need_curcop{$ppname} ) { 2729 if ( $curcop and $need_curcop{$ppname} ) {
2729 $curcop->write_back; 2730 $curcop->write_back;
2730 } 2731 }
2731 write_back_lexicals() unless $skip_lexicals{$ppname}; 2732 write_back_lexicals() unless $skip_lexicals{$ppname};
2732 write_back_stack() unless $skip_stack{$ppname}; 2733 write_back_stack() unless $skip_stack{$ppname};
2733 doop($op); 2734 doop($op);
2734 2735
2735 # 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
2736 # when it's named in $op->targ then we could call 2737 # when it's named in $op->targ then we could call
2737 # invalidate_lexicals(TEMPORARY) and avoid having to write back all 2738 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
2738 # 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.
2739 invalidate_lexicals() unless $skip_invalidate{$ppname}; 2740 invalidate_lexicals() unless $skip_invalidate{$ppname};
2740 return $op->next; 2741 return $op->next;
2741 } 2742 }
2742 2743
2743 sub compile_op { 2744 sub compile_op {
2744 my $op = shift; 2745 my $op = shift;
2745 my $ppname = "pp_" . $op->name; 2746 my $ppname = "pp_" . $op->name;
2746 if ( exists $ignore_op{$ppname} ) { 2747 if ( exists $ignore_op{$ppname} ) {
2747 return $op->next; 2748 return $op->next;
2748 } 2749 }
2749 debug peek_stack() if $debug{stack}; 2750 debug peek_stack() if $debug{stack};
2750 if ( $debug{op} ) { 2751 if ( $debug{op} ) {
2751 debug sprintf( "%s [%s]\n", 2752 debug sprintf( "%s [%s]\n",
2752 peekop($op), $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ ); 2753 peekop($op), $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ );
2753 } 2754 }
2754 no strict 'refs'; 2755 no strict 'refs';
2755 if ( defined(&$ppname) ) { 2756 if ( defined(&$ppname) ) {
2756 $know_op = 0; 2757 $know_op = 0;
2757 return &$ppname($op); 2758 return &$ppname($op);
2758 } 2759 }
2759 else { 2760 else {
2760 return default_pp($op); 2761 return default_pp($op);
2761 } 2762 }
2762 } 2763 }
2763 2764
2764 sub compile_bblock { 2765 sub compile_bblock {
2765 my $op = shift; 2766 my $op = shift;
2766 warn "compile_bblock: ", peekop($op), "\n" if $debug{bblock}; 2767 warn "compile_bblock: ", peekop($op), "\n" if $debug{bblock};
2767 save_or_restore_lexical_state($$op); 2768 save_or_restore_lexical_state($$op);
2768 write_label($op); 2769 write_label($op);
2769 $know_op = 0; 2770 $know_op = 0;
2770 do { 2771 do {
2771 $op = compile_op($op); 2772 $op = compile_op($op);
2772 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}))) {
2773 runtime("PERL_ASYNC_CHECK();"); 2774 runtime("PERL_ASYNC_CHECK();");
2774 } 2775 }
2775 } while ( defined($op) && $$op && !exists( $leaders->{$$op} ) ); 2776 } while ( defined($op) && $$op && !exists( $leaders->{$$op} ) );
2776 write_back_stack(); # boo hoo: big loss 2777 write_back_stack(); # boo hoo: big loss
2777 reload_lexicals(); 2778 reload_lexicals();
2778 return $op; 2779 return $op;
2779 } 2780 }
2780 2781
2781 sub cc { 2782 sub cc {
2782 my ( $name, $root, $start, @padlist ) = @_; 2783 my ( $name, $root, $start, @padlist ) = @_;
2783 my $op; 2784 my $op;
2784 if ( $done{$$start} ) { 2785 if ( $done{$$start} ) {
2785 warn "repeat=>" . ref($start) . " $name,\n" if $verbose; 2786 warn "repeat=>" . ref($start) . " $name,\n" if $verbose;
2786 $decl->add( sprintf( "#define $name %s", $done{$$start} ) ); 2787 $decl->add( sprintf( "#define $name %s", $done{$$start} ) );
2787 return; 2788 return;
2788 } 2789 }
2789 warn "cc $name\n" if $verbose; 2790 warn "cc $name\n" if $verbose;
2790 init_pp($name); 2791 init_pp($name);
2791 load_pad(@padlist); 2792 load_pad(@padlist);
2792 %lexstate = (); 2793 %lexstate = ();
2793 B::Pseudoreg->new_scope; 2794 B::Pseudoreg->new_scope;
2794 @cxstack = (); 2795 @cxstack = ();
2795 if ( $debug{timings} ) { 2796 if ( $debug{timings} ) {
2796 warn sprintf( "Basic block analysis at %s\n", timing_info ); 2797 warn sprintf( "Basic block analysis at %s\n", timing_info );
2797 } 2798 }
2798 $leaders = find_leaders( $root, $start ); 2799 $leaders = find_leaders( $root, $start );
2799 my @leaders = keys %$leaders; 2800 my @leaders = keys %$leaders;
2800 if ( $#leaders > -1 ) { 2801 if ( $#leaders > -1 ) {
2801 # Don't add basic blocks of dead code. 2802 # Don't add basic blocks of dead code.
2802 # It would produce errors when processing $cxstack. 2803 # It would produce errors when processing $cxstack.
2803 # @bblock_todo = ( values %$leaders ); 2804 # @bblock_todo = ( values %$leaders );
2804 # Instead, save $root (pp_leavesub) separately, 2805 # Instead, save $root (pp_leavesub) separately,
2805 # because it will not get compiled if located in dead code. 2806 # because it will not get compiled if located in dead code.
2806 $root->save; 2807 $root->save;
2807 unshift @bblock_todo, ($start) if $$start; 2808 unshift @bblock_todo, ($start) if $$start;
2808 } 2809 }
2809 else { 2810 else {
2810 runtime("return PL_op?PL_op->op_next:0;"); 2811 runtime("return PL_op?PL_op->op_next:0;");
2811 } 2812 }
2812 if ( $debug{timings} ) { 2813 if ( $debug{timings} ) {
2813 warn sprintf( "Compilation at %s\n", timing_info ); 2814 warn sprintf( "Compilation at %s\n", timing_info );
2814 } 2815 }
2815 while (@bblock_todo) { 2816 while (@bblock_todo) {
2816 $op = shift @bblock_todo; 2817 $op = shift @bblock_todo;
2817 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};
2818 next if !defined($op) || !$$op || $done{$$op}; 2819 next if !defined($op) || !$$op || $done{$$op};
2819 warn "...compiling it\n" if $debug{bblock}; 2820 warn "...compiling it\n" if $debug{bblock};
2820 do { 2821 do {
2821 $done{$$op} = $name; 2822 $done{$$op} = $name;
2822 $op = compile_bblock($op); 2823 $op = compile_bblock($op);
2823 if ( $need_freetmps && $freetmps_each_bblock ) { 2824 if ( $need_freetmps && $freetmps_each_bblock ) {
2824 runtime("FREETMPS;"); 2825 runtime("FREETMPS;");
2825 $need_freetmps = 0; 2826 $need_freetmps = 0;
2826 } 2827 }
2827 } while defined($op) && $$op && !$done{$$op}; 2828 } while defined($op) && $$op && !$done{$$op};
2828 if ( $need_freetmps && $freetmps_each_loop ) { 2829 if ( $need_freetmps && $freetmps_each_loop ) {
2829 runtime("FREETMPS;"); 2830 runtime("FREETMPS;");
2830 $need_freetmps = 0; 2831 $need_freetmps = 0;
2831 } 2832 }
2832 if ( !$$op ) { 2833 if ( !$$op ) {
2833 runtime( "PUTBACK;", 2834 runtime( "PUTBACK;",
2834 "return NULL;" ); 2835 "return NULL;" );
2835 } 2836 }
2836 elsif ( $done{$$op} ) { 2837 elsif ( $done{$$op} ) {
2837 save_or_restore_lexical_state($$op); 2838 save_or_restore_lexical_state($$op);
2838 runtime( sprintf( "goto %s;", label($op) ) ); 2839 runtime( sprintf( "goto %s;", label($op) ) );
2839 } 2840 }
2840 } 2841 }
2841 if ( $debug{timings} ) { 2842 if ( $debug{timings} ) {
2842 warn sprintf( "Saving runtime at %s\n", timing_info ); 2843 warn sprintf( "Saving runtime at %s\n", timing_info );
2843 } 2844 }
2844 declare_pad(@padlist); 2845 declare_pad(@padlist);
2845 save_runtime(); 2846 save_runtime();
2846 } 2847 }
2847 2848
2848 sub cc_recurse { 2849 sub cc_recurse {
2849 my ($ccinfo); 2850 my ($ccinfo);
2850 my $start = cc_queue(@_) if @_; 2851 my $start = cc_queue(@_) if @_;
2851 2852
2852 while ( $ccinfo = shift @cc_todo ) { 2853 while ( $ccinfo = shift @cc_todo ) {
2853 if ($DB::deep and $ccinfo->[0] =~ /^pp_sub_(DB|Term__ReadLine)_/) { 2854 if ($DB::deep and $ccinfo->[0] =~ /^pp_sub_(DB|Term__ReadLine)_/) {
2854 warn "cc $ccinfo->[0] skipped (debugging)\n" if $verbose; 2855 warn "cc $ccinfo->[0] skipped (debugging)\n" if $verbose;
2855 debug "cc(ccinfo): @$ccinfo skipped (debugging)\n" if $debug{queue}; 2856 debug "cc(ccinfo): @$ccinfo skipped (debugging)\n" if $debug{queue};
2856 } 2857 }
2857 elsif ($cc_pp_sub{$ccinfo->[0]}) { # skip duplicates 2858 elsif ($cc_pp_sub{$ccinfo->[0]}) { # skip duplicates
2858 warn "cc $ccinfo->[0] already defined\n" if $verbose; 2859 warn "cc $ccinfo->[0] already defined\n" if $verbose;
2859 debug "cc(ccinfo): @$ccinfo already defined\n" if $debug{queue}; 2860 debug "cc(ccinfo): @$ccinfo already defined\n" if $debug{queue};
2860 } else { 2861 } else {
2861 debug "cc(ccinfo): @$ccinfo\n" if $debug{queue}; 2862 debug "cc(ccinfo): @$ccinfo\n" if $debug{queue};
2862 cc(@$ccinfo); 2863 cc(@$ccinfo);
2863 $cc_pp_sub{$ccinfo->[0]}++; 2864 $cc_pp_sub{$ccinfo->[0]}++;
2864 } 2865 }
2865 } 2866 }
2866 return $start; 2867 return $start;
2867 } 2868 }
2868 2869
2869 sub cc_obj { 2870 sub cc_obj {
2870 my ( $name, $cvref ) = @_; 2871 my ( $name, $cvref ) = @_;
2871 my $cv = svref_2object($cvref); 2872 my $cv = svref_2object($cvref);
2872 my @padlist = $cv->PADLIST->ARRAY; 2873 my @padlist = $cv->PADLIST->ARRAY;
2873 my $curpad_sym = $padlist[1]->save; 2874 my $curpad_sym = $padlist[1]->save;
2874 cc_recurse( $name, $cv->ROOT, $cv->START, @padlist ); 2875 cc_recurse( $name, $cv->ROOT, $cv->START, @padlist );
2875 } 2876 }
2876 2877
2877 sub cc_main { 2878 sub cc_main {
2878 my @comppadlist = comppadlist->ARRAY; 2879 my @comppadlist = comppadlist->ARRAY;
2879 my $curpad_nam = $comppadlist[0]->save; 2880 my $curpad_nam = $comppadlist[0]->save;
2880 my $curpad_sym = $comppadlist[1]->save; 2881 my $curpad_sym = $comppadlist[1]->save;
2881 my $init_av = init_av->save; 2882 my $init_av = init_av->save;
2882 my $start = cc_recurse( "pp_main", main_root, main_start, @comppadlist ); 2883 my $start = cc_recurse( "pp_main", main_root, main_start, @comppadlist );
2883 2884
2884 # Do save_unused_subs before saving inc_hv 2885 # Do save_unused_subs before saving inc_hv
2885 B::C::module($module) if $module; 2886 B::C::module($module) if $module;
2886 save_unused_subs(); 2887 save_unused_subs();
2887 2888
2888 my $warner = $SIG{__WARN__}; 2889 my $warner = $SIG{__WARN__};
2889 save_sig($warner); 2890 save_sig($warner);
2890 2891
2891 my($inc_hv, $inc_av, $end_av); 2892 my($inc_hv, $inc_av, $end_av);
2892 if ( !defined($module) ) { 2893 if ( !defined($module) ) {
2893 # forbid run-time extends of curpad syms, names and INC 2894 # forbid run-time extends of curpad syms, names and INC
2894 warn "save context:\n" if $verbose; 2895 warn "save context:\n" if $verbose;
2895 $init->add("/* save context */"); 2896 $init->add("/* save context */");
2896 $init->add('/* %INC */'); 2897 $init->add('/* %INC */');
2897 inc_cleanup(); 2898 inc_cleanup();
2898 my $inc_gv = svref_2object( \*main::INC ); 2899 my $inc_gv = svref_2object( \*main::INC );
2899 $inc_hv = $inc_gv->HV->save('main::INC'); 2900 $inc_hv = $inc_gv->HV->save('main::INC');
2900 $init->add( sprintf( "GvHV(%s) = s\\_%x;", 2901 $init->add( sprintf( "GvHV(%s) = s\\_%x;",
2901 $inc_gv->save('main::INC'), $inc_gv->HV ) ); 2902 $inc_gv->save('main::INC'), $inc_gv->HV ) );
2902 local ($B::C::pv_copy_on_grow, $B::C::const_strings); 2903 local ($B::C::pv_copy_on_grow, $B::C::const_strings);
2903 $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;
2904 $inc_hv = $inc_gv->HV->save('main::INC'); 2905 $inc_hv = $inc_gv->HV->save('main::INC');
2905 $inc_av = $inc_gv->AV->save('main::INC'); 2906 $inc_av = $inc_gv->AV->save('main::INC');
2906 } 2907 }
2907 { 2908 {
2908 # >=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.
2909 local ($B::C::pv_copy_on_grow, $B::C::const_strings); 2910 local ($B::C::pv_copy_on_grow, $B::C::const_strings);
2910 $B::C::in_endav = 1; 2911 $B::C::in_endav = 1;
2911 $end_av = end_av->save; 2912 $end_av = end_av->save;
2912 } 2913 }
2913 cc_recurse(); 2914 cc_recurse();
2914 return if $errors or $check; 2915 return if $errors or $check;
2915 2916
2916 if ( !defined($module) ) { 2917 if ( !defined($module) ) {
2917 # XXX TODO push BEGIN/END blocks to modules code. 2918 # XXX TODO push BEGIN/END blocks to modules code.
2918 $init->add( 2919 $init->add(
2919 sprintf( "PL_main_root = s\\_%x;", ${ main_root() } ), 2920 sprintf( "PL_main_root = s\\_%x;", ${ main_root() } ),
2920 "PL_main_start = $start;", 2921 "PL_main_start = $start;",
2921 "PL_curpad = AvARRAY($curpad_sym);", 2922 "PL_curpad = AvARRAY($curpad_sym);",
2922 "PL_comppad = $curpad_sym;", 2923 "PL_comppad = $curpad_sym;",
2923 "av_store(CvPADLIST(PL_main_cv), 0, SvREFCNT_inc($curpad_nam));", 2924 "av_store(CvPADLIST(PL_main_cv), 0, SvREFCNT_inc($curpad_nam));",
2924 "av_store(CvPADLIST(PL_main_cv), 1, SvREFCNT_inc($curpad_sym));", 2925 "av_store(CvPADLIST(PL_main_cv), 1, SvREFCNT_inc($curpad_sym));",
2925 "GvHV(PL_incgv) = $inc_hv;", 2926 "GvHV(PL_incgv) = $inc_hv;",
2926 "GvAV(PL_incgv) = $inc_av;", 2927 "GvAV(PL_incgv) = $inc_av;",
2927 "PL_initav = (AV*)$init_av;", 2928 "PL_initav = (AV*)$init_av;",
2928 "PL_endav = (AV*)$end_av;" 2929 "PL_endav = (AV*)$end_av;"
2929 ); 2930 );
2930 if ($] < 5.017) { 2931 if ($] < 5.017) {
2931 my $amagic_generate = B::amagic_generation; 2932 my $amagic_generate = B::amagic_generation;
2932 $init->add("PL_amagic_generation = $amagic_generate;"); 2933 $init->add("PL_amagic_generation = $amagic_generate;");
2933 }; 2934 };
2934 } 2935 }
2935 2936
2936 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
2937 fixup_ppaddr(); 2938 fixup_ppaddr();
2938 output_boilerplate(); 2939 output_boilerplate();
2939 print "\n"; 2940 print "\n";
2940 output_all("perl_init"); 2941 output_all("perl_init");
2941 output_runtime(); 2942 output_runtime();
2942 print "\n"; 2943 print "\n";
2943 output_main_rest(); 2944 output_main_rest();
2944 2945
2945 if ( defined($module) ) { 2946 if ( defined($module) ) {
2946 my $cmodule = $module ||= 'main'; 2947 my $cmodule = $module ||= 'main';
2947 $cmodule =~ s/::/__/g; 2948 $cmodule =~ s/::/__/g;
2948 print <<"EOT"; 2949 print <<"EOT";
2949 2950
2950 #include "XSUB.h" 2951 #include "XSUB.h"
2951 XS(boot_$cmodule) 2952 XS(boot_$cmodule)
2952 { 2953 {
2953 dXSARGS; 2954 dXSARGS;
2954 perl_init(); 2955 perl_init();
2955 ENTER; 2956 ENTER;
2956 SAVETMPS; 2957 SAVETMPS;
2957 SAVEVPTR(PL_curpad); 2958 SAVEVPTR(PL_curpad);
2958 SAVEVPTR(PL_op); 2959 SAVEVPTR(PL_op);
2959 PL_curpad = AvARRAY($curpad_sym); 2960 PL_curpad = AvARRAY($curpad_sym);
2960 PL_op = $start; 2961 PL_op = $start;
2961 pp_main(aTHX); 2962 pp_main(aTHX);
2962 FREETMPS; 2963 FREETMPS;
2963 LEAVE; 2964 LEAVE;
2964 ST(0) = &PL_sv_yes; 2965 ST(0) = &PL_sv_yes;
2965 XSRETURN(1); 2966 XSRETURN(1);
2966 } 2967 }
2967 EOT 2968 EOT
2968 } else { 2969 } else {
2969 output_main(); 2970 output_main();
2970 } 2971 }
2971 if ( $debug{timings} ) { 2972 if ( $debug{timings} ) {
2972 warn sprintf( "Done at %s\n", timing_info ); 2973 warn sprintf( "Done at %s\n", timing_info );
2973 } 2974 }
2974 } 2975 }
2975 2976
2976 sub compile_stats { 2977 sub compile_stats {
2977 return "Total number of OPs processed: $op_count\n"; 2978 return "Total number of OPs processed: $op_count\n";
2978 } 2979 }
2979 2980
2980 # 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
2981 sub import { 2982 sub import {
2982 my @options = @_; 2983 my @options = @_;
2983 # Allow debugging in CHECK blocks without Od 2984 # Allow debugging in CHECK blocks without Od
2984 $DB::single = 1 if defined &DB::DB; 2985 $DB::single = 1 if defined &DB::DB;
2985 my ( $option, $opt, $arg ); 2986 my ( $option, $opt, $arg );
2986 # init with -O0 2987 # init with -O0
2987 foreach my $ref ( values %optimise ) { 2988 foreach my $ref ( values %optimise ) {
2988 $$ref = 0; 2989 $$ref = 0;
2989 } 2990 }
2990 $B::C::fold = 0 if $] >= 5.013009; # utf8::Cased tables 2991 $B::C::fold = 0 if $] >= 5.013009; # utf8::Cased tables
2991 $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
2992 OPTION: 2993 OPTION:
2993 while ( $option = shift @options ) { 2994 while ( $option = shift @options ) {
2994 if ( $option =~ /^-(.)(.*)/ ) { 2995 if ( $option =~ /^-(.)(.*)/ ) {
2995 $opt = $1; 2996 $opt = $1;
2996 $arg = $2; 2997 $arg = $2;
2997 } 2998 }
2998 else { 2999 else {
2999 unshift @options, $option; 3000 unshift @options, $option;
3000 last OPTION; 3001 last OPTION;
3001 } 3002 }
3002 if ( $opt eq "-" && $arg eq "-" ) { 3003 if ( $opt eq "-" && $arg eq "-" ) {
3003 shift @options; 3004 shift @options;
3004 last OPTION; 3005 last OPTION;
3005 } 3006 }
3006 elsif ( $opt eq "o" ) { 3007 elsif ( $opt eq "o" ) {
3007 $arg ||= shift @options; 3008 $arg ||= shift @options;
3008 open( STDOUT, ">$arg" ) or return "open '>$arg': $!\n"; 3009 open( STDOUT, ">$arg" ) or return "open '>$arg': $!\n";
3009 } 3010 }
3010 elsif ( $opt eq "c" ) { 3011 elsif ( $opt eq "c" ) {
3011 $check = 1; 3012 $check = 1;
3012 $B::C::check = 1; 3013 $B::C::check = 1;
3013 } 3014 }
3014 elsif ( $opt eq "v" ) { 3015 elsif ( $opt eq "v" ) {
3015 $verbose = 1; 3016 $verbose = 1;
3016 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)
3017 } 3018 }
3018 elsif ( $opt eq "u" ) { 3019 elsif ( $opt eq "u" ) {
3019 $arg ||= shift @options; 3020 $arg ||= shift @options;
3020 eval "require $arg;"; 3021 eval "require $arg;";
3021 mark_unused( $arg, 1 ); 3022 mark_unused( $arg, 1 );
3022 } 3023 }
3023 elsif ( $opt eq "U" ) { 3024 elsif ( $opt eq "U" ) {
3024 $arg ||= shift @options; 3025 $arg ||= shift @options;
3025 mark_skip( $arg ); 3026 mark_skip( $arg );
3026 } 3027 }
3027 elsif ( $opt eq "strict" ) { 3028 elsif ( $opt eq "strict" ) {
3028 $arg ||= shift @options; 3029 $arg ||= shift @options;
3029 $strict++; 3030 $strict++;
3030 } 3031 }
3031 elsif ( $opt eq "f" ) { 3032 elsif ( $opt eq "f" ) {
3032 $arg ||= shift @options; 3033 $arg ||= shift @options;
3033 my $value = $arg !~ s/^no-//; 3034 my $value = $arg !~ s/^no-//;
3034 $arg =~ s/-/_/g; 3035 $arg =~ s/-/_/g;
3035 my $ref = $optimise{$arg}; 3036 my $ref = $optimise{$arg};
3036 if ( defined($ref) ) { 3037 if ( defined($ref) ) {
3037 $$ref = $value; 3038 $$ref = $value;
3038 } 3039 }
3039 else { 3040 else {
3040 # Pass down to B::C 3041 # Pass down to B::C
3041 my $ref = $B::C::option_map{$arg}; 3042 my $ref = $B::C::option_map{$arg};
3042 if ( defined($ref) ) { 3043 if ( defined($ref) ) {
3043 $$ref = $value; 3044 $$ref = $value;
3044 $c_optimise{$ref}++; 3045 $c_optimise{$ref}++;
3045 } 3046 }
3046 else { 3047 else {
3047 warn qq(ignoring unknown optimisation option "$arg"\n); 3048 warn qq(ignoring unknown optimisation option "$arg"\n);
3048 } 3049 }
3049 } 3050 }
3050 } 3051 }
3051 elsif ( $opt eq "O" ) { 3052 elsif ( $opt eq "O" ) {
3052 $arg = 1 if $arg eq ""; 3053 $arg = 1 if $arg eq "";
3053 foreach my $ref ( values %optimise ) { 3054 foreach my $ref ( values %optimise ) {
3054 $$ref = 0; 3055 $$ref = 0;
3055 } 3056 }
3056 if ($arg >= 2) { 3057 if ($arg >= 2) {
3057 $freetmps_each_loop = 1; 3058 $freetmps_each_loop = 1;
3058 $B::C::destruct = 0 unless $] < 5.008; # fast_destruct 3059 $B::C::destruct = 0 unless $] < 5.008; # fast_destruct
3059 } 3060 }
3060 if ( $arg >= 1 ) { 3061 if ( $arg >= 1 ) {
3061 $type_attr = 1; 3062 $type_attr = 1;
3062 $freetmps_each_bblock = 1 unless $freetmps_each_loop; 3063 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
3063 } 3064 }
3064 } 3065 }
3065 elsif ( $opt eq "n" ) { 3066 elsif ( $opt eq "n" ) {
3066 $arg ||= shift @options; 3067 $arg ||= shift @options;
3067 $init_name = $arg; 3068 $init_name = $arg;
3068 } 3069 }
3069 elsif ( $opt eq "m" ) { 3070 elsif ( $opt eq "m" ) {
3070 $module = $arg; 3071 $module = $arg;
3071 mark_unused( $arg, undef ); 3072 mark_unused( $arg, undef );
3072 } 3073 }
3073 elsif ( $opt eq "p" ) { 3074 elsif ( $opt eq "p" ) {
3074 $arg ||= shift @options; 3075 $arg ||= shift @options;
3075 $patchlevel = $arg; 3076 $patchlevel = $arg;
3076 } 3077 }
3077 elsif ( $opt eq "D" ) { 3078 elsif ( $opt eq "D" ) {
3078 $arg ||= shift @options; 3079 $arg ||= shift @options;
3079 $verbose++; 3080 $verbose++;
3080 $arg = 'oOscprSqlt' if $arg eq 'full'; 3081 $arg = 'oOscprSqlt' if $arg eq 'full';
3081 foreach $arg ( split( //, $arg ) ) { 3082 foreach $arg ( split( //, $arg ) ) {
3082 if ( $arg eq "o" ) { 3083 if ( $arg eq "o" ) {
3083 B->debug(1); 3084 B->debug(1);
3084 } 3085 }
3085 elsif ( $arg eq "O" ) { 3086 elsif ( $arg eq "O" ) {
3086 $debug{op}++; 3087 $debug{op}++;
3087 } 3088 }
3088 elsif ( $arg eq "s" ) { 3089 elsif ( $arg eq "s" ) {
3089 $debug{stack}++; 3090 $debug{stack}++;
3090 } 3091 }
3091 elsif ( $arg eq "c" ) { 3092 elsif ( $arg eq "c" ) {
3092 $debug{cxstack}++; 3093 $debug{cxstack}++;
3093 } 3094 }
3094 elsif ( $arg eq "p" ) { 3095 elsif ( $arg eq "p" ) {
3095 $debug{pad}++; 3096 $debug{pad}++;
3096 } 3097 }
3097 elsif ( $arg eq "r" ) { 3098 elsif ( $arg eq "r" ) {
3098 $debug{runtime}++; 3099 $debug{runtime}++;
3099 } 3100 }
3100 elsif ( $arg eq "S" ) { 3101 elsif ( $arg eq "S" ) {
3101 $debug{shadow}++; 3102 $debug{shadow}++;
3102 } 3103 }
3103 elsif ( $arg eq "q" ) { 3104 elsif ( $arg eq "q" ) {
3104 $debug{queue}++; 3105 $debug{queue}++;
3105 } 3106 }
3106 elsif ( $arg eq "l" ) { 3107 elsif ( $arg eq "l" ) {
3107 $debug{lineno}++; 3108 $debug{lineno}++;
3108 } 3109 }
3109 elsif ( $arg eq "t" ) { 3110 elsif ( $arg eq "t" ) {
3110 $debug{timings}++; 3111 $debug{timings}++;
3111 } 3112 }
3112 elsif ( $arg eq "F" and eval "require B::Flags;" ) { 3113 elsif ( $arg eq "F" and eval "require B::Flags;" ) {
3113 $debug{flags}++; 3114 $debug{flags}++;
3114 $B::C::debug{flags}++; 3115 $B::C::debug{flags}++;
3115 } 3116 }
3116 elsif ( exists $B::C::debug_map{$arg} ) { 3117 elsif ( exists $B::C::debug_map{$arg} ) {
3117 $B::C::debug{ $B::C::debug_map{$arg} }++; 3118 $B::C::debug{ $B::C::debug_map{$arg} }++;
3118 } 3119 }
3119 else { 3120 else {
3120 warn qq(ignoring unknown -D option "$arg"\n); 3121 warn qq(ignoring unknown -D option "$arg"\n);
3121 } 3122 }
3122 } 3123 }
3123 } 3124 }
3124 } 3125 }
3125 $strict++ if !$strict and $Config{ccflags} !~ m/-DDEBUGGING/; 3126 $strict++ if !$strict and $Config{ccflags} !~ m/-DDEBUGGING/;
3126 3127
3127 # 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
3128 # seperate Opcodes package. 3129 # seperate Opcodes package.
3129 eval { require Opcodes; }; 3130 eval { require Opcodes; };
3130 if (!$@ and $Opcodes::VERSION) { 3131 if (!$@ and $Opcodes::VERSION) {
3131 my $MAXO = Opcodes::opcodes(); 3132 my $MAXO = Opcodes::opcodes();
3132 for (0..$MAXO-1) { 3133 for (0..$MAXO-1) {
3133 no strict 'refs'; 3134 no strict 'refs';
3134 my $ppname = "pp_".Opcodes::opname($_); 3135 my $ppname = "pp_".Opcodes::opname($_);
3135 # 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
3136 # But pp_enter, pp_leave use/change global stack. 3137 # But pp_enter, pp_leave use/change global stack.
3137 next if $ppname eq 'pp_enter' || $ppname eq 'pp_leave'; 3138 next if $ppname eq 'pp_enter' || $ppname eq 'pp_leave';
3138 $no_stack{$ppname} = 1 3139 $no_stack{$ppname} = 1
3139 if Opcodes::opflags($_) & 512; 3140 if Opcodes::opflags($_) & 512;
3140 # XXX More Opcodes options to be added later 3141 # XXX More Opcodes options to be added later
3141 } 3142 }
3142 } 3143 }
3143 #if ($debug{op}) { 3144 #if ($debug{op}) {
3144 # warn "no_stack: ",join(" ",sort keys %no_stack),"\n"; 3145 # warn "no_stack: ",join(" ",sort keys %no_stack),"\n";
3145 #} 3146 #}
3146 3147
3147 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',
3148 'B::Section', 'B::Pseudoreg', 'B::Shadow', 'O', 'Opcodes', 3149 'B::Section', 'B::Pseudoreg', 'B::Shadow', 'O', 'Opcodes',
3149 'B::Stackobj', 'B::Stackobj::Bool', 'B::Stackobj::Padsv', 'B::Stackobj::Const', 3150 'B::Stackobj', 'B::Stackobj::Bool', 'B::Stackobj::Padsv', 'B::Stackobj::Const',
3150 'B::Bblock'); 3151 'B::Bblock');
3151 mark_skip('DB', 'Term::ReadLine') if defined &DB::DB; 3152 mark_skip('DB', 'Term::ReadLine') if defined &DB::DB;
3152 3153
3153 # Set some B::C optimizations. 3154 # Set some B::C optimizations.
3154 # 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.
3155 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),
3156 $PERL510 ? () : "pv_copy_on_grow") 3157 $PERL510 ? () : "pv_copy_on_grow")
3157 { 3158 {
3158 no strict 'refs'; 3159 no strict 'refs';
3159 ${"B::C::$_"} = 1 unless $c_optimise{$_}; 3160 ${"B::C::$_"} = 1 unless $c_optimise{$_};
3160 } 3161 }
3161 $B::C::stash = 0 unless $c_optimise{stash}; 3162 $B::C::stash = 0 unless $c_optimise{stash};
3162 if (!$B::C::Flags::have_independent_comalloc) { 3163 if (!$B::C::Flags::have_independent_comalloc) {
3163 $B::C::av_init = 1 unless $c_optimise{av_init}; 3164 $B::C::av_init = 1 unless $c_optimise{av_init};
3164 $B::C::av_init2 = 0 unless $c_optimise{av_init2}; 3165 $B::C::av_init2 = 0 unless $c_optimise{av_init2};
3165 } else { 3166 } else {
3166 $B::C::av_init = 0 unless $c_optimise{av_init}; 3167 $B::C::av_init = 0 unless $c_optimise{av_init};
3167 $B::C::av_init2 = 1 unless $c_optimise{av_init2}; 3168 $B::C::av_init2 = 1 unless $c_optimise{av_init2};
3168 } 3169 }
3169 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
3170 @options; 3171 @options;
3171 } 3172 }
3172 3173
3173 # -MO=CC entry point 3174 # -MO=CC entry point
3174 sub compile { 3175 sub compile {
3175 my @options = @_; 3176 my @options = @_;
3176 @options = import(@options); 3177 @options = import(@options);
3177 3178
3178 init_sections(); 3179 init_sections();
3179 $init = B::Section->get("init"); 3180 $init = B::Section->get("init");
3180 $decl = B::Section->get("decl"); 3181 $decl = B::Section->get("decl");
3181 3182
3182 # just some subs or main? 3183 # just some subs or main?
3183 if (@options) { 3184 if (@options) {
3184 return sub { 3185 return sub {
3185 my ( $objname, $ppname ); 3186 my ( $objname, $ppname );
3186 foreach $objname (@options) { 3187 foreach $objname (@options) {
3187 $objname = "main::$objname" unless $objname =~ /::/; 3188 $objname = "main::$objname" unless $objname =~ /::/;
3188 ( $ppname = $objname ) =~ s/^.*?:://; 3189 ( $ppname = $objname ) =~ s/^.*?:://;
3189 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)"; 3190 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
3190 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@; 3191 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
3191 return if $errors; 3192 return if $errors;
3192 } 3193 }
3193 my $warner = $SIG{__WARN__}; 3194 my $warner = $SIG{__WARN__};
3194 save_sig($warner); 3195 save_sig($warner);
3195 fixup_ppaddr(); 3196 fixup_ppaddr();
3196 return if $check; 3197 return if $check;
3197 output_boilerplate(); 3198 output_boilerplate();
3198 print "\n"; 3199 print "\n";
3199 output_all( $init_name || "init_module" ); 3200 output_all( $init_name || "init_module" );
3200 output_runtime(); 3201 output_runtime();
3201 # output_main_rest(); 3202 # output_main_rest();
3202 } 3203 }
3203 } 3204 }
3204 else { 3205 else {
3205 return sub { cc_main() }; 3206 return sub { cc_main() };
3206 } 3207 }
3207 } 3208 }
3208 3209
3209 1; 3210 1;
3210 3211
3211 __END__ 3212 __END__
3212 3213
3213 =head1 EXAMPLES 3214 =head1 EXAMPLES
3214 3215
3215 perl -MO=CC,-O2,-ofoo.c foo.pl 3216 perl -MO=CC,-O2,-ofoo.c foo.pl
3216 perl cc_harness -o foo foo.c 3217 perl cc_harness -o foo foo.c
3217 3218
3218 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
3219 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
3220 help make use of this compiler. 3221 help make use of this compiler.
3221 3222
3222 # create a shared XS module 3223 # create a shared XS module
3223 perl -MO=CC,-mFoo,-oFoo.c Foo.pm 3224 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
3224 perl cc_harness -shared -c -o Foo.so Foo.c 3225 perl cc_harness -shared -c -o Foo.so Foo.c
3225 3226
3226 # side-effects just for the types and attributes 3227 # side-effects just for the types and attributes
3227 perl -MB::CC -e'my int $i:unsigned; ...' 3228 perl -MB::CC -e'my int $i:unsigned; ...'
3228 3229
3229 =head1 TYPES 3230 =head1 TYPES
3230 3231
3231 Implemented type classes are B<int> and B<double>. 3232 Implemented type classes are B<int> and B<double>.
3232 Planned is B<string> also. 3233 Planned is B<string> also.
3233 Implemented are only SCALAR types yet. 3234 Implemented are only SCALAR types yet.
3234 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.
3235 3236
3236 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
3237 and an optional 'r' suffix for register allocation. 3238 and an optional 'r' suffix for register allocation.
3238 3239
3239 C<my ($i_i, $j_ir, $num_d);> 3240 C<my ($i_i, $j_ir, $num_d);>
3240 3241
3241 Planned type attributes are B<int>, B<double>, B<string>, 3242 Planned type attributes are B<int>, B<double>, B<string>,
3242 B<unsigned>, B<ro> / B<const>. 3243 B<unsigned>, B<ro> / B<const>.
3243 3244
3244 The attributes are perl attributes, and int|double|string are either 3245 The attributes are perl attributes, and int|double|string are either
3245 compiler classes or hints for more allowed types. 3246 compiler classes or hints for more allowed types.
3246 3247
3247 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;>
3248 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;>
3249 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;>
3250 3251
3251 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.
3252 With :const or :ro even more. 3253 With :const or :ro even more.
3253 C<my string %hash :const 3254 C<my string %hash :const
3254 = (foo => 'foo', bar => 'bar');> declare string values, 3255 = (foo => 'foo', bar => 'bar');> declare string values,
3255 generate as read-only perfect hash. 3256 generate as read-only perfect hash.
3256 3257
3257 B<:unsigned> is valid for int only and declares an UV. 3258 B<:unsigned> is valid for int only and declares an UV.
3258 3259
3259 B<:register> denotes optionally a short and hot life-time. 3260 B<:register> denotes optionally a short and hot life-time.
3260 3261
3261 B<:temporary> are usually generated internally, nameless lexicals. 3262 B<:temporary> are usually generated internally, nameless lexicals.
3262 They are more aggressivly destroyed and ignored. 3263 They are more aggressivly destroyed and ignored.
3263 3264
3264 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
3265 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
3266 to perl (lexical write_back). 3267 to perl (lexical write_back).
3267 3268
3268 STATUS 3269 STATUS
3269 3270
3270 OK (classes only): 3271 OK (classes only):
3271 3272
3272 my int $i; 3273 my int $i;
3273 my double $d; 3274 my double $d;
3274 3275
3275 NOT YET OK (attributes): 3276 NOT YET OK (attributes):
3276 3277
3277 my int $i :register; 3278 my int $i :register;
3278 my $i :int; 3279 my $i :int;
3279 my $const :int:const; 3280 my $const :int:const;
3280 my $uv :int:unsigned; 3281 my $uv :int:unsigned;
3281 3282
3282 ISSUES 3283 ISSUES
3283 3284
3284 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
3285 implement the classes and attribute type stubs in your code, 3286 implement the classes and attribute type stubs in your code,
3286 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 {}>.
3287 (TODO: empty should be enough to be detected by the compiler.) 3288 (TODO: empty should be enough to be detected by the compiler.)
3288 3289
3289 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
3290 functions, even if they are used at compile time only. 3291 functions, even if they are used at compile time only.
3291 3292
3292 Using attributes adds an import block to your code. 3293 Using attributes adds an import block to your code.
3293 3294
3294 Only B<our> variable attributes are checked at compile-time, 3295 Only B<our> variable attributes are checked at compile-time,
3295 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.
3296 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
3297 the defined package. 3298 the defined package.
3298 Perl attributes need to be fixed for types hints. 3299 Perl attributes need to be fixed for types hints.
3299 3300
3300 FUTURE 3301 FUTURE
3301 3302
3302 We should be able to support types on ARRAY and HASH. 3303 We should be able to support types on ARRAY and HASH.
3303 3304
3304 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.
3305 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
3306 3307
3307 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
3308 string %hash1 : readonly = (foo => 'bar');# string keys only => maybe gperf 3309 string %hash1 : readonly = (foo => 'bar');# string keys only => maybe gperf
3309 # compile-time error on write 3310 # compile-time error on write
3310 3311
3311 Typed hash keys are always strings, values are typed. 3312 Typed hash keys are always strings, values are typed.
3312 3313
3313 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,
3314 i.e. for argument and return types. See L<types> and 3315 i.e. for argument and return types. See L<types> and
3315 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>
3316 3317
3317 =head1 BUGS 3318 =head1 BUGS
3318 3319
3319 Plenty. Current status: experimental. 3320 Plenty. Current status: experimental.
3320 3321
3321 =head1 DIFFERENCES 3322 =head1 DIFFERENCES
3322 3323
3323 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
3324 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
3325 compiler backend cannot cope. 3326 compiler backend cannot cope.
3326 3327
3327 =head2 Loops 3328 =head2 Loops
3328 3329
3329 Standard perl calculates the target of "next", "last", and "redo" 3330 Standard perl calculates the target of "next", "last", and "redo"
3330 at run-time. The compiler calculates the targets at compile-time. 3331 at run-time. The compiler calculates the targets at compile-time.
3331 For example, the program 3332 For example, the program
3332 3333
3333 sub skip_on_odd { next NUMBER if $_[0] % 2 } 3334 sub skip_on_odd { next NUMBER if $_[0] % 2 }
3334 NUMBER: for ($i = 0; $i < 5; $i++) { 3335 NUMBER: for ($i = 0; $i < 5; $i++) {
3335 skip_on_odd($i); 3336 skip_on_odd($i);
3336 print $i; 3337 print $i;
3337 } 3338 }
3338 3339
3339 produces the output 3340 produces the output
3340 3341
3341 024 3342 024
3342 3343
3343 with standard perl but calculates with the compiler the 3344 with standard perl but calculates with the compiler the
3344 goto label_NUMBER wrong, producing 01234. 3345 goto label_NUMBER wrong, producing 01234.
3345 3346
3346 =head2 Context of ".." 3347 =head2 Context of ".."
3347 3348
3348 The context (scalar or array) of the ".." operator determines whether 3349 The context (scalar or array) of the ".." operator determines whether
3349 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
3350 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
3351 to know the context at compile-time. For example, 3352 to know the context at compile-time. For example,
3352 3353
3353 @a = (4,6,1,0,0,1); 3354 @a = (4,6,1,0,0,1);
3354 sub range { (shift @a)..(shift @a) } 3355 sub range { (shift @a)..(shift @a) }
3355 print range(); 3356 print range();
3356 while (@a) { print scalar(range()) } 3357 while (@a) { print scalar(range()) }
3357 3358
3358 generates the output 3359 generates the output
3359 3360
3360 456123E0 3361 456123E0
3361 3362
3362 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.
3363 3364
3364 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.
3365 3366
3366 =head2 Arithmetic 3367 =head2 Arithmetic
3367 3368
3368 Compiled Perl programs use native C arithmetic much more frequently 3369 Compiled Perl programs use native C arithmetic much more frequently
3369 than standard perl. Operations on large numbers or on boundary 3370 than standard perl. Operations on large numbers or on boundary
3370 cases may produce different behaviour. 3371 cases may produce different behaviour.
3371 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>.
3372 3373
3373 =head2 Deprecated features 3374 =head2 Deprecated features
3374 3375
3375 Features of standard perl such as C<$[> which have been deprecated 3376 Features of standard perl such as C<$[> which have been deprecated
3376 in standard perl since Perl5 was released have not been implemented 3377 in standard perl since Perl5 was released have not been implemented
3377 in the compiler. 3378 in the compiler.
3378 3379
3379 =head1 AUTHORS 3380 =head1 AUTHORS
3380 3381
3381 Malcolm Beattie C<MICB at cpan.org> I<(1996-1998, retired)>, 3382 Malcolm Beattie C<MICB at cpan.org> I<(1996-1998, retired)>,
3382 Vishal Bhatia <vishal at deja.com> I(1999), 3383 Vishal Bhatia <vishal at deja.com> I(1999),
3383 Gurusamy Sarathy <gsar@cpan.org> I(1998-2001), 3384 Gurusamy Sarathy <gsar@cpan.org> I(1998-2001),
3384 Reini Urban C<perl-compiler@googlegroups.com> I(2008-), 3385 Reini Urban C<perl-compiler@googlegroups.com> I(2008-),
3385 Heinz Knutzen C<heinz.knutzen at gmx.de> I(2010) 3386 Heinz Knutzen C<heinz.knutzen at gmx.de> I(2010)
3386 3387
3387 =cut 3388 =cut
3388 3389
3389 # Local Variables: 3390 # Local Variables:
3390 # mode: cperl 3391 # mode: cperl
3391 # cperl-indent-level: 2 3392 # cperl-indent-level: 2
3392 # fill-column: 78 3393 # fill-column: 78
3393 # End: 3394 # End:
3394 # vim: expandtab shiftwidth=2: 3395 # vim: expandtab shiftwidth=2:
Powered by Google Project Hosting