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