This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
setstate stop-gap from Vishal Bhatia
[perl5.git] / ext / B / B / CC.pm
CommitLineData
a798dbf2
MB
1# CC.pm
2#
1a52ab62 3# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
a798dbf2
MB
4#
5# You may distribute under the terms of either the GNU General Public
6# License or the Artistic License, as specified in the README file.
7#
8package B::CC;
9use strict;
10use B qw(main_start main_root class comppadlist peekop svref_2object
56eca212 11 timing_info init_av sv_undef amagic_generation
4c1f658f
NIS
12 OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
13 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
a6f4eb0a 14 OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
4c1f658f
NIS
15 CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
16 );
0cc1d052 17use B::C qw(save_unused_subs objsym init_sections mark_unused
a798dbf2
MB
18 output_all output_boilerplate output_main);
19use B::Bblock qw(find_leaders);
20use B::Stackobj qw(:types :flags);
21
22# These should probably be elsewhere
23# Flags for $op->flags
a798dbf2
MB
24
25my $module; # module name (when compiled with -m)
26my %done; # hash keyed by $$op of leaders of basic blocks
27 # which have already been done.
28my $leaders; # ref to hash of basic block leaders. Keys are $$op
29 # addresses, values are the $op objects themselves.
30my @bblock_todo; # list of leaders of basic blocks that need visiting
31 # sometime.
32my @cc_todo; # list of tuples defining what PP code needs to be
33 # saved (e.g. CV, main or PMOP repl code). Each tuple
34 # is [$name, $root, $start, @padlist]. PMOP repl code
35 # tuples inherit padlist.
36my @stack; # shadows perl's stack when contents are known.
37 # Values are objects derived from class B::Stackobj
38my @pad; # Lexicals in current pad as Stackobj-derived objects
39my @padlist; # Copy of current padlist so PMOP repl code can find it
40my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
41my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
42my %constobj; # OP_CONST constants as Stackobj-derived objects
43 # keyed by $$sv.
44my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
45 # block or even to the end of each loop of blocks,
46 # depending on optimisation options.
47my $know_op = 0; # Set when C variable op already holds the right op
48 # (from an immediately preceding DOOP(ppname)).
49my $errors = 0; # Number of errors encountered
50my %skip_stack; # Hash of PP names which don't need write_back_stack
51my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
52my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
53my %ignore_op; # Hash of ops which do nothing except returning op_next
df2464c8 54my %need_curcop; # Hash of ops which need PL_curcop
a798dbf2
MB
55
56BEGIN {
edcf81c0 57 foreach (qw(pp_setstate pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
a798dbf2
MB
58 $ignore_op{$_} = 1;
59 }
60}
61
a798dbf2
MB
62my ($module_name);
63my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
64 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
65
66# Optimisation options. On the command line, use hyphens instead of
67# underscores for compatibility with gcc-style options. We use
68# underscores here because they are OK in (strict) barewords.
69my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
70my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
71 freetmps_each_loop => \$freetmps_each_loop,
72 omit_taint => \$omit_taint);
73# perl patchlevel to generate code for (defaults to current patchlevel)
74my $patchlevel = int(0.5 + 1000 * ($] - 5));
75
76# Could rewrite push_runtime() and output_runtime() to use a
77# temporary file if memory is at a premium.
78my $ppname; # name of current fake PP function
79my $runtime_list_ref;
80my $declare_ref; # Hash ref keyed by C variable type of declarations.
81
82my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
83 # tuples to be written out.
84
85my ($init, $decl);
86
87sub init_hash { map { $_ => 1 } @_ }
88
89#
90# Initialise the hashes for the default PP functions where we can avoid
91# either write_back_stack, write_back_lexicals or invalidate_lexicals.
92#
93%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
94%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
5ab5c7a4
VB
95%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
96 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
97 pp_entertry pp_enterloop pp_enteriter pp_entersub
3f872cb9 98 pp_enter pp_method);
a798dbf2
MB
99
100sub debug {
101 if ($debug_runtime) {
102 warn(@_);
103 } else {
104 runtime(map { chomp; "/* $_ */"} @_);
105 }
106}
107
108sub declare {
109 my ($type, $var) = @_;
110 push(@{$declare_ref->{$type}}, $var);
111}
112
113sub push_runtime {
114 push(@$runtime_list_ref, @_);
115 warn join("\n", @_) . "\n" if $debug_runtime;
116}
117
118sub save_runtime {
119 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
120}
121
122sub output_runtime {
123 my $ppdata;
124 print qq(#include "cc_runtime.h"\n);
125 foreach $ppdata (@pp_list) {
126 my ($name, $runtime, $declare) = @$ppdata;
0a574d6e 127 print "\nstatic\nCCPP($name)\n{\n";
a798dbf2
MB
128 my ($type, $varlist, $line);
129 while (($type, $varlist) = each %$declare) {
130 print "\t$type ", join(", ", @$varlist), ";\n";
131 }
132 foreach $line (@$runtime) {
133 print $line, "\n";
134 }
135 print "}\n";
136 }
137}
138
139sub runtime {
140 my $line;
141 foreach $line (@_) {
142 push_runtime("\t$line");
143 }
144}
145
146sub init_pp {
147 $ppname = shift;
148 $runtime_list_ref = [];
149 $declare_ref = {};
150 runtime("djSP;");
151 declare("I32", "oldsave");
152 declare("SV", "**svp");
153 map { declare("SV", "*$_") } qw(sv src dst left right);
154 declare("MAGIC", "*mg");
66918de8 155 $decl->add("static OP * $ppname (pTHX);");
a798dbf2
MB
156 debug "init_pp: $ppname\n" if $debug_queue;
157}
158
159# Initialise runtime_callback function for Stackobj class
160BEGIN { B::Stackobj::set_callback(\&runtime) }
161
162# Initialise saveoptree_callback for B::C class
163sub cc_queue {
164 my ($name, $root, $start, @pl) = @_;
165 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
166 if $debug_queue;
167 if ($name eq "*ignore*") {
168 $name = 0;
169 } else {
170 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
171 }
172 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
173 $start = $fakeop->save;
174 debug "cc_queue: name $name returns $start\n" if $debug_queue;
175 return $start;
176}
177BEGIN { B::C::set_callback(\&cc_queue) }
178
179sub valid_int { $_[0]->{flags} & VALID_INT }
180sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
181sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
182sub valid_sv { $_[0]->{flags} & VALID_SV }
183
184sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
185sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
186sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
187sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
a9b6343a 188sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
a798dbf2
MB
189
190sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
191sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
192sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
193sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
194sub pop_bool {
195 if (@stack) {
a9b6343a 196 return ((pop @stack)->as_bool);
a798dbf2
MB
197 } else {
198 # Careful: POPs has an auto-decrement and SvTRUE evaluates
199 # its argument more than once.
200 runtime("sv = POPs;");
201 return "SvTRUE(sv)";
202 }
203}
204
205sub write_back_lexicals {
206 my $avoid = shift || 0;
207 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
208 if $debug_shadow;
209 my $lex;
210 foreach $lex (@pad) {
211 next unless ref($lex);
212 $lex->write_back unless $lex->{flags} & $avoid;
213 }
214}
215
216sub write_back_stack {
217 my $obj;
218 return unless @stack;
219 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
220 foreach $obj (@stack) {
221 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
222 }
223 @stack = ();
224}
225
226sub invalidate_lexicals {
227 my $avoid = shift || 0;
228 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
229 if $debug_shadow;
230 my $lex;
231 foreach $lex (@pad) {
232 next unless ref($lex);
233 $lex->invalidate unless $lex->{flags} & $avoid;
234 }
235}
236
237sub reload_lexicals {
238 my $lex;
239 foreach $lex (@pad) {
240 next unless ref($lex);
241 my $type = $lex->{type};
242 if ($type == T_INT) {
243 $lex->as_int;
244 } elsif ($type == T_DOUBLE) {
245 $lex->as_double;
246 } else {
247 $lex->as_sv;
248 }
249 }
250}
251
252{
253 package B::Pseudoreg;
254 #
255 # This class allocates pseudo-registers (OK, so they're C variables).
256 #
257 my %alloc; # Keyed by variable name. A value of 1 means the
258 # variable has been declared. A value of 2 means
259 # it's in use.
260
261 sub new_scope { %alloc = () }
262
263 sub new ($$$) {
264 my ($class, $type, $prefix) = @_;
265 my ($ptr, $i, $varname, $status, $obj);
266 $prefix =~ s/^(\**)//;
267 $ptr = $1;
268 $i = 0;
269 do {
270 $varname = "$prefix$i";
271 $status = $alloc{$varname};
272 } while $status == 2;
273 if ($status != 1) {
274 # Not declared yet
275 B::CC::declare($type, "$ptr$varname");
276 $alloc{$varname} = 2; # declared and in use
277 }
278 $obj = bless \$varname, $class;
279 return $obj;
280 }
281 sub DESTROY {
282 my $obj = shift;
283 $alloc{$$obj} = 1; # no longer in use but still declared
284 }
285}
286{
287 package B::Shadow;
288 #
289 # This class gives a standard API for a perl object to shadow a
290 # C variable and only generate reloads/write-backs when necessary.
291 #
292 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
293 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
294 # Use $obj->invalidate whenever an unknown function may have
295 # set shadow itself.
296
297 sub new {
298 my ($class, $write_back) = @_;
299 # Object fields are perl shadow variable, validity flag
300 # (for *C* variable) and callback sub for write_back
301 # (passed perl shadow variable as argument).
302 bless [undef, 1, $write_back], $class;
303 }
304 sub load {
305 my ($obj, $newval) = @_;
306 $obj->[1] = 0; # C variable no longer valid
307 $obj->[0] = $newval;
308 }
309 sub write_back {
310 my $obj = shift;
311 if (!($obj->[1])) {
312 $obj->[1] = 1; # C variable will now be valid
313 &{$obj->[2]}($obj->[0]);
314 }
315 }
316 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
317}
318my $curcop = new B::Shadow (sub {
319 my $opsym = shift->save;
81009501 320 runtime("PL_curcop = (COP*)$opsym;");
a798dbf2
MB
321});
322
323#
324# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
325#
326sub dopoptoloop {
327 my $cxix = $#cxstack;
328 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
329 $cxix--;
330 }
331 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
332 return $cxix;
333}
334
335sub dopoptolabel {
336 my $label = shift;
337 my $cxix = $#cxstack;
73544139
NIS
338 while ($cxix >= 0 &&
339 ($cxstack[$cxix]->{type} != CXt_LOOP ||
340 $cxstack[$cxix]->{label} ne $label)) {
a798dbf2
MB
341 $cxix--;
342 }
343 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
344 return $cxix;
345}
346
347sub error {
348 my $format = shift;
349 my $file = $curcop->[0]->filegv->SV->PV;
350 my $line = $curcop->[0]->line;
351 $errors++;
352 if (@_) {
353 warn sprintf("%s:%d: $format\n", $file, $line, @_);
354 } else {
355 warn sprintf("%s:%d: %s\n", $file, $line, $format);
356 }
357}
358
359#
360# Load pad takes (the elements of) a PADLIST as arguments and loads
361# up @pad with Stackobj-derived objects which represent those lexicals.
362# If/when perl itself can generate type information (my int $foo) then
363# we'll take advantage of that here. Until then, we'll use various hacks
364# to tell the compiler when we want a lexical to be a particular type
365# or to be a register.
366#
367sub load_pad {
368 my ($namelistav, $valuelistav) = @_;
369 @padlist = @_;
370 my @namelist = $namelistav->ARRAY;
371 my @valuelist = $valuelistav->ARRAY;
372 my $ix;
373 @pad = ();
374 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
375 # Temporary lexicals don't get named so it's possible for @valuelist
376 # to be strictly longer than @namelist. We count $ix up to the end of
377 # @valuelist but index into @namelist for the name. Any temporaries which
378 # run off the end of @namelist will make $namesv undefined and we treat
379 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
380 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
381 for ($ix = 1; $ix < @valuelist; $ix++) {
382 my $namesv = $namelist[$ix];
383 my $type = T_UNKNOWN;
384 my $flags = 0;
385 my $name = "tmp$ix";
386 my $class = class($namesv);
387 if (!defined($namesv) || $class eq "SPECIAL") {
81009501 388 # temporaries have &PL_sv_undef instead of a PVNV for a name
a798dbf2
MB
389 $flags = VALID_SV|TEMPORARY|REGISTER;
390 } else {
391 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
392 $name = $1;
393 if ($2 eq "i") {
394 $type = T_INT;
395 $flags = VALID_SV|VALID_INT;
396 } elsif ($2 eq "d") {
397 $type = T_DOUBLE;
398 $flags = VALID_SV|VALID_DOUBLE;
399 }
400 $flags |= REGISTER if $3;
401 }
402 }
403 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
404 "i_$name", "d_$name");
8bac7e00 405
81009501 406 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
a798dbf2
MB
407 }
408}
409
8bac7e00
GS
410sub declare_pad {
411 my $ix;
412 for ($ix = 1; $ix <= $#pad; $ix++) {
413 my $type = $pad[$ix]->{type};
414 declare("IV", $type == T_INT ?
415 sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
416 declare("double", $type == T_DOUBLE ?
417 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
418
419 }
420}
a798dbf2
MB
421#
422# Debugging stuff
423#
424sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
425
426#
427# OP stuff
428#
429
430sub label {
431 my $op = shift;
432 # XXX Preserve original label name for "real" labels?
433 return sprintf("lab_%x", $$op);
434}
435
436sub write_label {
437 my $op = shift;
438 push_runtime(sprintf(" %s:", label($op)));
439}
440
441sub loadop {
442 my $op = shift;
443 my $opsym = $op->save;
81009501 444 runtime("PL_op = $opsym;") unless $know_op;
a798dbf2
MB
445 return $opsym;
446}
447
448sub doop {
449 my $op = shift;
450 my $ppname = $op->ppaddr;
451 my $sym = loadop($op);
452 runtime("DOOP($ppname);");
453 $know_op = 1;
454 return $sym;
455}
456
457sub gimme {
458 my $op = shift;
459 my $flags = $op->flags;
a6f4eb0a 460 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
a798dbf2
MB
461}
462
463#
464# Code generation for PP code
465#
466
467sub pp_null {
468 my $op = shift;
469 return $op->next;
470}
471
472sub pp_stub {
473 my $op = shift;
474 my $gimme = gimme($op);
a6f4eb0a
VB
475 if ($gimme != G_ARRAY) {
476 my $obj= new B::Stackobj::Const(sv_undef);
477 push(@stack, $obj);
a798dbf2 478 # XXX Change to push a constant sv_undef Stackobj onto @stack
a6f4eb0a
VB
479 #write_back_stack();
480 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
a798dbf2
MB
481 }
482 return $op->next;
483}
484
485sub pp_unstack {
486 my $op = shift;
487 @stack = ();
488 runtime("PP_UNSTACK;");
489 return $op->next;
490}
491
492sub pp_and {
493 my $op = shift;
494 my $next = $op->next;
495 reload_lexicals();
496 unshift(@bblock_todo, $next);
497 if (@stack >= 1) {
498 my $bool = pop_bool();
499 write_back_stack();
44887cfa 500 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
a798dbf2
MB
501 } else {
502 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
503 "*sp--;");
504 }
505 return $op->other;
506}
507
508sub pp_or {
509 my $op = shift;
510 my $next = $op->next;
511 reload_lexicals();
512 unshift(@bblock_todo, $next);
513 if (@stack >= 1) {
44887cfa 514 my $bool = pop_bool @stack;
a798dbf2 515 write_back_stack();
44887cfa
NIS
516 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
517 $bool, label($next)));
a798dbf2
MB
518 } else {
519 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
520 "*sp--;");
521 }
522 return $op->other;
523}
524
525sub pp_cond_expr {
526 my $op = shift;
1a67a97c 527 my $false = $op->next;
a798dbf2
MB
528 unshift(@bblock_todo, $false);
529 reload_lexicals();
530 my $bool = pop_bool();
531 write_back_stack();
532 runtime(sprintf("if (!$bool) goto %s;", label($false)));
1a67a97c 533 return $op->other;
a798dbf2
MB
534}
535
536sub pp_padsv {
537 my $op = shift;
538 my $ix = $op->targ;
539 push(@stack, $pad[$ix]);
540 if ($op->flags & OPf_MOD) {
541 my $private = $op->private;
542 if ($private & OPpLVAL_INTRO) {
81009501 543 runtime("SAVECLEARSV(PL_curpad[$ix]);");
a798dbf2 544 } elsif ($private & OPpDEREF) {
81009501 545 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
a798dbf2
MB
546 $ix, $private & OPpDEREF));
547 $pad[$ix]->invalidate;
548 }
549 }
550 return $op->next;
551}
552
553sub pp_const {
554 my $op = shift;
555 my $sv = $op->sv;
556 my $obj = $constobj{$$sv};
557 if (!defined($obj)) {
558 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
559 }
560 push(@stack, $obj);
561 return $op->next;
562}
563
564sub pp_nextstate {
565 my $op = shift;
566 $curcop->load($op);
567 @stack = ();
568 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
569 runtime("TAINT_NOT;") unless $omit_taint;
81009501 570 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
a798dbf2
MB
571 if ($freetmps_each_bblock || $freetmps_each_loop) {
572 $need_freetmps = 1;
573 } else {
574 runtime("FREETMPS;");
575 }
576 return $op->next;
577}
578
579sub pp_dbstate {
580 my $op = shift;
581 $curcop->invalidate; # XXX?
582 return default_pp($op);
583}
584
df2464c8 585#default_pp will handle this:
df2464c8
VB
586#sub pp_bless { $curcop->write_back; default_pp(@_) }
587#sub pp_repeat { $curcop->write_back; default_pp(@_) }
a798dbf2
MB
588# The following subs need $curcop->write_back if we decide to support arybase:
589# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
df2464c8
VB
590#sub pp_caller { $curcop->write_back; default_pp(@_) }
591#sub pp_reset { $curcop->write_back; default_pp(@_) }
a798dbf2 592
5ab5c7a4
VB
593sub pp_rv2gv{
594 my $op =shift;
595 $curcop->write_back;
596 write_back_lexicals() unless $skip_lexicals{$ppname};
597 write_back_stack() unless $skip_stack{$ppname};
598 my $sym=doop($op);
599 if ($op->private & OPpDEREF) {
600 $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
601 $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
602 $op->first->type));
603 }
604 return $op->next;
605}
59c10aa2
VB
606sub pp_sort {
607 my $op = shift;
608 my $ppname = $op->ppaddr;
5ab5c7a4
VB
609 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
610 #this indicates the sort BLOCK Array case
611 #ugly surgery required.
612 my $root=$op->first->sibling->first;
613 my $start=$root->first;
59c10aa2
VB
614 $op->first->save;
615 $op->first->sibling->save;
616 $root->save;
5ab5c7a4
VB
617 my $sym=$start->save;
618 my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
619 $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
620 }
59c10aa2 621 $curcop->write_back;
5ab5c7a4
VB
622 write_back_lexicals();
623 write_back_stack();
59c10aa2
VB
624 doop($op);
625 return $op->next;
5ab5c7a4 626}
a798dbf2
MB
627sub pp_gv {
628 my $op = shift;
629 my $gvsym = $op->gv->save;
630 write_back_stack();
631 runtime("XPUSHs((SV*)$gvsym);");
632 return $op->next;
633}
634
635sub pp_gvsv {
636 my $op = shift;
637 my $gvsym = $op->gv->save;
638 write_back_stack();
639 if ($op->private & OPpLVAL_INTRO) {
640 runtime("XPUSHs(save_scalar($gvsym));");
641 } else {
642 runtime("XPUSHs(GvSV($gvsym));");
643 }
644 return $op->next;
645}
646
647sub pp_aelemfast {
648 my $op = shift;
649 my $gvsym = $op->gv->save;
650 my $ix = $op->private;
651 my $flag = $op->flags & OPf_MOD;
652 write_back_stack();
653 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
81009501 654 "PUSHs(svp ? *svp : &PL_sv_undef);");
a798dbf2
MB
655 return $op->next;
656}
657
658sub int_binop {
659 my ($op, $operator) = @_;
660 if ($op->flags & OPf_STACKED) {
661 my $right = pop_int();
662 if (@stack >= 1) {
663 my $left = top_int();
664 $stack[-1]->set_int(&$operator($left, $right));
665 } else {
666 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
667 }
668 } else {
669 my $targ = $pad[$op->targ];
670 my $right = new B::Pseudoreg ("IV", "riv");
671 my $left = new B::Pseudoreg ("IV", "liv");
672 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
673 $targ->set_int(&$operator($$left, $$right));
674 push(@stack, $targ);
675 }
676 return $op->next;
677}
678
679sub INTS_CLOSED () { 0x1 }
680sub INT_RESULT () { 0x2 }
681sub NUMERIC_RESULT () { 0x4 }
682
683sub numeric_binop {
684 my ($op, $operator, $flags) = @_;
685 my $force_int = 0;
686 $force_int ||= ($flags & INT_RESULT);
687 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
688 && valid_int($stack[-2]) && valid_int($stack[-1]));
689 if ($op->flags & OPf_STACKED) {
690 my $right = pop_numeric();
691 if (@stack >= 1) {
692 my $left = top_numeric();
693 if ($force_int) {
694 $stack[-1]->set_int(&$operator($left, $right));
695 } else {
696 $stack[-1]->set_numeric(&$operator($left, $right));
697 }
698 } else {
699 if ($force_int) {
73544139
NIS
700 my $rightruntime = new B::Pseudoreg ("IV", "riv");
701 runtime(sprintf("$$rightruntime = %s;",$right));
a798dbf2 702 runtime(sprintf("sv_setiv(TOPs, %s);",
73544139 703 &$operator("TOPi", $$rightruntime)));
a798dbf2 704 } else {
73544139
NIS
705 my $rightruntime = new B::Pseudoreg ("double", "rnv");
706 runtime(sprintf("$$rightruntime = %s;",$right));
a798dbf2 707 runtime(sprintf("sv_setnv(TOPs, %s);",
73544139 708 &$operator("TOPn",$$rightruntime)));
a798dbf2
MB
709 }
710 }
711 } else {
712 my $targ = $pad[$op->targ];
713 $force_int ||= ($targ->{type} == T_INT);
714 if ($force_int) {
715 my $right = new B::Pseudoreg ("IV", "riv");
716 my $left = new B::Pseudoreg ("IV", "liv");
717 runtime(sprintf("$$right = %s; $$left = %s;",
718 pop_numeric(), pop_numeric));
719 $targ->set_int(&$operator($$left, $$right));
720 } else {
721 my $right = new B::Pseudoreg ("double", "rnv");
722 my $left = new B::Pseudoreg ("double", "lnv");
723 runtime(sprintf("$$right = %s; $$left = %s;",
724 pop_numeric(), pop_numeric));
725 $targ->set_numeric(&$operator($$left, $$right));
726 }
727 push(@stack, $targ);
728 }
729 return $op->next;
730}
731
8bac7e00
GS
732sub pp_ncmp {
733 my ($op) = @_;
734 if ($op->flags & OPf_STACKED) {
735 my $right = pop_numeric();
736 if (@stack >= 1) {
737 my $left = top_numeric();
738 runtime sprintf("if (%s > %s){",$left,$right);
739 $stack[-1]->set_int(1);
740 $stack[-1]->write_back();
741 runtime sprintf("}else if (%s < %s ) {",$left,$right);
742 $stack[-1]->set_int(-1);
743 $stack[-1]->write_back();
744 runtime sprintf("}else if (%s == %s) {",$left,$right);
745 $stack[-1]->set_int(0);
746 $stack[-1]->write_back();
747 runtime sprintf("}else {");
748 $stack[-1]->set_sv("&PL_sv_undef");
749 runtime "}";
750 } else {
751 my $rightruntime = new B::Pseudoreg ("double", "rnv");
752 runtime(sprintf("$$rightruntime = %s;",$right));
753 runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
754 runtime sprintf("sv_setiv(TOPs,1);");
755 runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
756 runtime sprintf("sv_setiv(TOPs,-1);");
757 runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
758 runtime sprintf("sv_setiv(TOPs,0);");
759 runtime sprintf(qq/}else {/);
760 runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
761 runtime "}";
762 }
763 } else {
764 my $targ = $pad[$op->targ];
765 my $right = new B::Pseudoreg ("double", "rnv");
766 my $left = new B::Pseudoreg ("double", "lnv");
767 runtime(sprintf("$$right = %s; $$left = %s;",
768 pop_numeric(), pop_numeric));
769 runtime sprintf("if (%s > %s){",$$left,$$right);
770 $targ->set_int(1);
771 $targ->write_back();
772 runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
773 $targ->set_int(-1);
774 $targ->write_back();
775 runtime sprintf("}else if (%s == %s) {",$$left,$$right);
776 $targ->set_int(0);
777 $targ->write_back();
778 runtime sprintf("}else {");
779 $targ->set_sv("&PL_sv_undef");
780 runtime "}";
781 push(@stack, $targ);
782 }
783 return $op->next;
784}
785
a798dbf2
MB
786sub sv_binop {
787 my ($op, $operator, $flags) = @_;
788 if ($op->flags & OPf_STACKED) {
789 my $right = pop_sv();
790 if (@stack >= 1) {
791 my $left = top_sv();
792 if ($flags & INT_RESULT) {
793 $stack[-1]->set_int(&$operator($left, $right));
794 } elsif ($flags & NUMERIC_RESULT) {
795 $stack[-1]->set_numeric(&$operator($left, $right));
796 } else {
797 # XXX Does this work?
798 runtime(sprintf("sv_setsv($left, %s);",
799 &$operator($left, $right)));
800 $stack[-1]->invalidate;
801 }
802 } else {
803 my $f;
804 if ($flags & INT_RESULT) {
805 $f = "sv_setiv";
806 } elsif ($flags & NUMERIC_RESULT) {
807 $f = "sv_setnv";
808 } else {
809 $f = "sv_setsv";
810 }
811 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
812 }
813 } else {
814 my $targ = $pad[$op->targ];
815 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
816 if ($flags & INT_RESULT) {
817 $targ->set_int(&$operator("left", "right"));
818 } elsif ($flags & NUMERIC_RESULT) {
819 $targ->set_numeric(&$operator("left", "right"));
820 } else {
821 # XXX Does this work?
822 runtime(sprintf("sv_setsv(%s, %s);",
823 $targ->as_sv, &$operator("left", "right")));
824 $targ->invalidate;
825 }
826 push(@stack, $targ);
827 }
828 return $op->next;
829}
830
831sub bool_int_binop {
832 my ($op, $operator) = @_;
833 my $right = new B::Pseudoreg ("IV", "riv");
834 my $left = new B::Pseudoreg ("IV", "liv");
835 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
836 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
837 $bool->set_int(&$operator($$left, $$right));
838 push(@stack, $bool);
839 return $op->next;
840}
841
842sub bool_numeric_binop {
843 my ($op, $operator) = @_;
844 my $right = new B::Pseudoreg ("double", "rnv");
845 my $left = new B::Pseudoreg ("double", "lnv");
846 runtime(sprintf("$$right = %s; $$left = %s;",
847 pop_numeric(), pop_numeric()));
848 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
849 $bool->set_numeric(&$operator($$left, $$right));
850 push(@stack, $bool);
851 return $op->next;
852}
853
854sub bool_sv_binop {
855 my ($op, $operator) = @_;
856 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
857 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
858 $bool->set_numeric(&$operator("left", "right"));
859 push(@stack, $bool);
860 return $op->next;
861}
862
863sub infix_op {
864 my $opname = shift;
865 return sub { "$_[0] $opname $_[1]" }
866}
867
868sub prefix_op {
869 my $opname = shift;
870 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
871}
872
873BEGIN {
874 my $plus_op = infix_op("+");
875 my $minus_op = infix_op("-");
876 my $multiply_op = infix_op("*");
877 my $divide_op = infix_op("/");
878 my $modulo_op = infix_op("%");
879 my $lshift_op = infix_op("<<");
a0d31f98 880 my $rshift_op = infix_op(">>");
a798dbf2
MB
881 my $scmp_op = prefix_op("sv_cmp");
882 my $seq_op = prefix_op("sv_eq");
883 my $sne_op = prefix_op("!sv_eq");
884 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
885 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
886 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
887 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
888 my $eq_op = infix_op("==");
889 my $ne_op = infix_op("!=");
890 my $lt_op = infix_op("<");
891 my $gt_op = infix_op(">");
892 my $le_op = infix_op("<=");
893 my $ge_op = infix_op(">=");
894
895 #
896 # XXX The standard perl PP code has extra handling for
897 # some special case arguments of these operators.
898 #
0ca04487
VB
899 sub pp_add { numeric_binop($_[0], $plus_op) }
900 sub pp_subtract { numeric_binop($_[0], $minus_op) }
901 sub pp_multiply { numeric_binop($_[0], $multiply_op) }
a798dbf2
MB
902 sub pp_divide { numeric_binop($_[0], $divide_op) }
903 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
a798dbf2
MB
904
905 sub pp_left_shift { int_binop($_[0], $lshift_op) }
906 sub pp_right_shift { int_binop($_[0], $rshift_op) }
907 sub pp_i_add { int_binop($_[0], $plus_op) }
908 sub pp_i_subtract { int_binop($_[0], $minus_op) }
909 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
910 sub pp_i_divide { int_binop($_[0], $divide_op) }
911 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
912
913 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
914 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
915 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
916 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
917 sub pp_le { bool_numeric_binop($_[0], $le_op) }
918 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
919
920 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
921 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
922 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
923 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
924 sub pp_i_le { bool_int_binop($_[0], $le_op) }
925 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
926
927 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
928 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
929 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
930 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
931 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
932 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
933 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
934}
935
936
937sub pp_sassign {
938 my $op = shift;
939 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
940 my ($dst, $src);
941 if (@stack >= 2) {
942 $dst = pop @stack;
943 $src = pop @stack;
944 ($src, $dst) = ($dst, $src) if $backwards;
945 my $type = $src->{type};
946 if ($type == T_INT) {
0ca04487 947 $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
a798dbf2
MB
948 } elsif ($type == T_DOUBLE) {
949 $dst->set_numeric($src->as_numeric);
950 } else {
951 $dst->set_sv($src->as_sv);
952 }
953 push(@stack, $dst);
954 } elsif (@stack == 1) {
955 if ($backwards) {
956 my $src = pop @stack;
957 my $type = $src->{type};
81009501 958 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
a798dbf2 959 if ($type == T_INT) {
0ca04487
VB
960 if ($src->{flags} & VALID_UNSIGNED){
961 runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
962 }else{
963 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
964 }
a798dbf2
MB
965 } elsif ($type == T_DOUBLE) {
966 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
967 } else {
968 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
969 }
970 runtime("SvSETMAGIC(TOPs);");
971 } else {
b8f1fa48 972 my $dst = $stack[-1];
a798dbf2
MB
973 my $type = $dst->{type};
974 runtime("sv = POPs;");
975 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
976 if ($type == T_INT) {
977 $dst->set_int("SvIV(sv)");
978 } elsif ($type == T_DOUBLE) {
979 $dst->set_double("SvNV(sv)");
980 } else {
0bfcb1eb 981 runtime("SvSetMagicSV($dst->{sv}, sv);");
a798dbf2
MB
982 $dst->invalidate;
983 }
984 }
985 } else {
986 if ($backwards) {
987 runtime("src = POPs; dst = TOPs;");
988 } else {
989 runtime("dst = POPs; src = TOPs;");
990 }
991 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
992 "SvSetSV(dst, src);",
993 "SvSETMAGIC(dst);",
994 "SETs(dst);");
995 }
996 return $op->next;
997}
998
999sub pp_preinc {
1000 my $op = shift;
1001 if (@stack >= 1) {
1002 my $obj = $stack[-1];
1003 my $type = $obj->{type};
1004 if ($type == T_INT || $type == T_DOUBLE) {
1005 $obj->set_int($obj->as_int . " + 1");
1006 } else {
1007 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
1008 $obj->invalidate();
1009 }
1010 } else {
1011 runtime sprintf("PP_PREINC(TOPs);");
1012 }
1013 return $op->next;
1014}
1015
1016sub pp_pushmark {
1017 my $op = shift;
1018 write_back_stack();
1019 runtime("PUSHMARK(sp);");
1020 return $op->next;
1021}
1022
1023sub pp_list {
1024 my $op = shift;
1025 write_back_stack();
1026 my $gimme = gimme($op);
a6f4eb0a 1027 if ($gimme == G_ARRAY) { # sic
a798dbf2
MB
1028 runtime("POPMARK;"); # need this even though not a "full" pp_list
1029 } else {
1030 runtime("PP_LIST($gimme);");
1031 }
1032 return $op->next;
1033}
1034
1035sub pp_entersub {
1036 my $op = shift;
8bac7e00 1037 $curcop->write_back;
a798dbf2
MB
1038 write_back_lexicals(REGISTER|TEMPORARY);
1039 write_back_stack();
1040 my $sym = doop($op);
5cfd8ad4 1041 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
66918de8 1042 runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
5cfd8ad4 1043 runtime("SPAGAIN;}");
a798dbf2
MB
1044 $know_op = 0;
1045 invalidate_lexicals(REGISTER|TEMPORARY);
1046 return $op->next;
1047}
a6f4eb0a
VB
1048sub pp_formline {
1049 my $op = shift;
1050 my $ppname = $op->ppaddr;
a6f4eb0a
VB
1051 write_back_lexicals() unless $skip_lexicals{$ppname};
1052 write_back_stack() unless $skip_stack{$ppname};
1053 my $sym=doop($op);
1054 # See comment in pp_grepwhile to see why!
1055 $init->add("((LISTOP*)$sym)->op_first = $sym;");
0bfcb1eb
VB
1056 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1057 runtime( sprintf("goto %s;",label($op->first)));
a6f4eb0a
VB
1058 runtime("}");
1059 return $op->next;
1060}
a798dbf2 1061
5cfd8ad4
VB
1062sub pp_goto{
1063
1064 my $op = shift;
1065 my $ppname = $op->ppaddr;
1066 write_back_lexicals() unless $skip_lexicals{$ppname};
1067 write_back_stack() unless $skip_stack{$ppname};
1068 my $sym=doop($op);
1069 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
1070 invalidate_lexicals() unless $skip_invalidate{$ppname};
1071 return $op->next;
1072}
a798dbf2
MB
1073sub pp_enterwrite {
1074 my $op = shift;
1075 pp_entersub($op);
1076}
5ab5c7a4
VB
1077sub pp_leavesub{
1078 my $op = shift;
1079 write_back_lexicals() unless $skip_lexicals{$ppname};
1080 write_back_stack() unless $skip_stack{$ppname};
1081 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
1082 runtime("\tPUTBACK;return 0;");
1083 runtime("}");
1084 doop($op);
1085 return $op->next;
1086}
a798dbf2
MB
1087sub pp_leavewrite {
1088 my $op = shift;
1089 write_back_lexicals(REGISTER|TEMPORARY);
1090 write_back_stack();
1091 my $sym = doop($op);
1092 # XXX Is this the right way to distinguish between it returning
1093 # CvSTART(cv) (via doform) and pop_return()?
66918de8 1094 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
a798dbf2
MB
1095 runtime("SPAGAIN;");
1096 $know_op = 0;
1097 invalidate_lexicals(REGISTER|TEMPORARY);
1098 return $op->next;
1099}
1100
1101sub doeval {
1102 my $op = shift;
1103 $curcop->write_back;
1104 write_back_lexicals(REGISTER|TEMPORARY);
1105 write_back_stack();
1106 my $sym = loadop($op);
1107 my $ppaddr = $op->ppaddr;
cd2dd2fd 1108 #runtime(qq/printf("$ppaddr type eval\n");/);
a798dbf2
MB
1109 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1110 $know_op = 1;
1111 invalidate_lexicals(REGISTER|TEMPORARY);
1112 return $op->next;
1113}
1114
1115sub pp_entereval { doeval(@_) }
a798dbf2
MB
1116sub pp_dofile { doeval(@_) }
1117
cd2dd2fd
VB
1118#pp_require is protected by pp_entertry, so no protection for it.
1119sub pp_require {
1120 my $op = shift;
1121 $curcop->write_back;
1122 write_back_lexicals(REGISTER|TEMPORARY);
1123 write_back_stack();
1124 my $sym = doop($op);
1125 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1126 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
1127 runtime("SPAGAIN;}");
1128 $know_op = 1;
1129 invalidate_lexicals(REGISTER|TEMPORARY);
1130 return $op->next;
1131}
1132
1133
a798dbf2
MB
1134sub pp_entertry {
1135 my $op = shift;
1136 $curcop->write_back;
1137 write_back_lexicals(REGISTER|TEMPORARY);
1138 write_back_stack();
1139 my $sym = doop($op);
1140 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
a6f4eb0a 1141 declare("JMPENV", $jmpbuf);
a798dbf2
MB
1142 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1143 invalidate_lexicals(REGISTER|TEMPORARY);
1144 return $op->next;
1145}
1146
a6f4eb0a
VB
1147sub pp_leavetry{
1148 my $op=shift;
1149 default_pp($op);
1150 runtime("PP_LEAVETRY;");
1151 return $op->next;
1152}
1153
a798dbf2
MB
1154sub pp_grepstart {
1155 my $op = shift;
1156 if ($need_freetmps && $freetmps_each_loop) {
1157 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1158 $need_freetmps = 0;
1159 }
1160 write_back_stack();
a2093a06
GS
1161 my $sym= doop($op);
1162 my $next=$op->next;
1163 $next->save;
1164 my $nexttonext=$next->next;
1165 $nexttonext->save;
1166 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1167 label($nexttonext)));
a798dbf2
MB
1168 return $op->next->other;
1169}
1170
1171sub pp_mapstart {
1172 my $op = shift;
1173 if ($need_freetmps && $freetmps_each_loop) {
1174 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1175 $need_freetmps = 0;
1176 }
1177 write_back_stack();
e0c90f07
VB
1178 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1179 # we need to be able to distinguish the two at runtime.
1180 my $sym= doop($op);
1181 my $next=$op->next;
1182 $next->save;
1183 my $nexttonext=$next->next;
1184 $nexttonext->save;
a2093a06
GS
1185 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1186 label($nexttonext)));
a798dbf2
MB
1187 return $op->next->other;
1188}
1189
1190sub pp_grepwhile {
1191 my $op = shift;
1192 my $next = $op->next;
1193 unshift(@bblock_todo, $next);
1194 write_back_lexicals();
1195 write_back_stack();
1196 my $sym = doop($op);
1197 # pp_grepwhile can return either op_next or op_other and we need to
1198 # be able to distinguish the two at runtime. Since it's possible for
1199 # both ops to be "inlined", the fields could both be zero. To get
1200 # around that, we hack op_next to be our own op (purely because we
1201 # know it's a non-NULL pointer and can't be the same as op_other).
1202 $init->add("((LOGOP*)$sym)->op_next = $sym;");
81009501 1203 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
a798dbf2
MB
1204 $know_op = 0;
1205 return $op->other;
1206}
1207
1208sub pp_mapwhile {
1209 pp_grepwhile(@_);
1210}
1211
1212sub pp_return {
1213 my $op = shift;
1214 write_back_lexicals(REGISTER|TEMPORARY);
1215 write_back_stack();
1216 doop($op);
a9b6343a 1217 runtime("PUTBACK;", "return PL_op;");
a798dbf2
MB
1218 $know_op = 0;
1219 return $op->next;
1220}
1221
1222sub nyi {
1223 my $op = shift;
1224 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1225 return default_pp($op);
1226}
1227
1228sub pp_range {
1229 my $op = shift;
1230 my $flags = $op->flags;
4c1f658f 1231 if (!($flags & OPf_WANT)) {
a798dbf2
MB
1232 error("context of range unknown at compile-time");
1233 }
1234 write_back_lexicals();
1235 write_back_stack();
cfa4c8ee 1236 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
a798dbf2
MB
1237 # We need to save our UNOP structure since pp_flop uses
1238 # it to find and adjust out targ. We don't need it ourselves.
1239 $op->save;
81009501 1240 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1a67a97c
SM
1241 $op->targ, label($op->other));
1242 unshift(@bblock_todo, $op->other);
a798dbf2 1243 }
1a67a97c 1244 return $op->next;
a798dbf2
MB
1245}
1246
1247sub pp_flip {
1248 my $op = shift;
1249 my $flags = $op->flags;
4c1f658f 1250 if (!($flags & OPf_WANT)) {
a798dbf2
MB
1251 error("context of flip unknown at compile-time");
1252 }
cfa4c8ee 1253 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1a67a97c 1254 return $op->first->other;
a798dbf2
MB
1255 }
1256 write_back_lexicals();
1257 write_back_stack();
1258 # We need to save our UNOP structure since pp_flop uses
1259 # it to find and adjust out targ. We don't need it ourselves.
1260 $op->save;
1261 my $ix = $op->targ;
1262 my $rangeix = $op->first->targ;
1263 runtime(($op->private & OPpFLIP_LINENUM) ?
81009501 1264 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
a798dbf2 1265 : "if (SvTRUE(TOPs)) {");
81009501 1266 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
a798dbf2 1267 if ($op->flags & OPf_SPECIAL) {
81009501 1268 runtime("sv_setiv(PL_curpad[$ix], 1);");
a798dbf2 1269 } else {
81009501 1270 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
a798dbf2 1271 "\tsp--;",
1a67a97c 1272 sprintf("\tgoto %s;", label($op->first->other)));
a798dbf2
MB
1273 }
1274 runtime("}",
81009501
GS
1275 qq{sv_setpv(PL_curpad[$ix], "");},
1276 "SETs(PL_curpad[$ix]);");
a798dbf2
MB
1277 $know_op = 0;
1278 return $op->next;
1279}
1280
1281sub pp_flop {
1282 my $op = shift;
1283 default_pp($op);
1284 $know_op = 0;
1285 return $op->next;
1286}
1287
1288sub enterloop {
1289 my $op = shift;
1290 my $nextop = $op->nextop;
1291 my $lastop = $op->lastop;
1292 my $redoop = $op->redoop;
1293 $curcop->write_back;
1294 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1295 push(@cxstack, {
1296 type => CXt_LOOP,
1297 op => $op,
1298 "label" => $curcop->[0]->label,
1299 nextop => $nextop,
1300 lastop => $lastop,
1301 redoop => $redoop
1302 });
1303 $nextop->save;
1304 $lastop->save;
1305 $redoop->save;
1306 return default_pp($op);
1307}
1308
1309sub pp_enterloop { enterloop(@_) }
1310sub pp_enteriter { enterloop(@_) }
1311
1312sub pp_leaveloop {
1313 my $op = shift;
1314 if (!@cxstack) {
1315 die "panic: leaveloop";
1316 }
1317 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1318 pop(@cxstack);
1319 return default_pp($op);
1320}
1321
1322sub pp_next {
1323 my $op = shift;
1324 my $cxix;
1325 if ($op->flags & OPf_SPECIAL) {
1326 $cxix = dopoptoloop();
1327 if ($cxix < 0) {
1328 error('"next" used outside loop');
1329 return $op->next; # ignore the op
1330 }
1331 } else {
1332 $cxix = dopoptolabel($op->pv);
1333 if ($cxix < 0) {
1334 error('Label not found at compile time for "next %s"', $op->pv);
1335 return $op->next; # ignore the op
1336 }
1337 }
1338 default_pp($op);
1339 my $nextop = $cxstack[$cxix]->{nextop};
1340 push(@bblock_todo, $nextop);
1341 runtime(sprintf("goto %s;", label($nextop)));
1342 return $op->next;
1343}
1344
1345sub pp_redo {
1346 my $op = shift;
1347 my $cxix;
1348 if ($op->flags & OPf_SPECIAL) {
1349 $cxix = dopoptoloop();
1350 if ($cxix < 0) {
1351 error('"redo" used outside loop');
1352 return $op->next; # ignore the op
1353 }
1354 } else {
1355 $cxix = dopoptolabel($op->pv);
1356 if ($cxix < 0) {
1357 error('Label not found at compile time for "redo %s"', $op->pv);
1358 return $op->next; # ignore the op
1359 }
1360 }
1361 default_pp($op);
1362 my $redoop = $cxstack[$cxix]->{redoop};
1363 push(@bblock_todo, $redoop);
1364 runtime(sprintf("goto %s;", label($redoop)));
1365 return $op->next;
1366}
1367
1368sub pp_last {
1369 my $op = shift;
1370 my $cxix;
1371 if ($op->flags & OPf_SPECIAL) {
1372 $cxix = dopoptoloop();
1373 if ($cxix < 0) {
1374 error('"last" used outside loop');
1375 return $op->next; # ignore the op
1376 }
1377 } else {
1378 $cxix = dopoptolabel($op->pv);
1379 if ($cxix < 0) {
1380 error('Label not found at compile time for "last %s"', $op->pv);
1381 return $op->next; # ignore the op
1382 }
1383 # XXX Add support for "last" to leave non-loop blocks
1384 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1385 error('Use of "last" for non-loop blocks is not yet implemented');
1386 return $op->next; # ignore the op
1387 }
1388 }
1389 default_pp($op);
1390 my $lastop = $cxstack[$cxix]->{lastop}->next;
1391 push(@bblock_todo, $lastop);
1392 runtime(sprintf("goto %s;", label($lastop)));
1393 return $op->next;
1394}
1395
1396sub pp_subst {
1397 my $op = shift;
1398 write_back_lexicals();
1399 write_back_stack();
1400 my $sym = doop($op);
1401 my $replroot = $op->pmreplroot;
1402 if ($$replroot) {
81009501 1403 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
a798dbf2
MB
1404 $sym, label($replroot));
1405 $op->pmreplstart->save;
1406 push(@bblock_todo, $replroot);
1407 }
1408 invalidate_lexicals();
1409 return $op->next;
1410}
1411
1412sub pp_substcont {
1413 my $op = shift;
1414 write_back_lexicals();
1415 write_back_stack();
1416 doop($op);
1417 my $pmop = $op->other;
0cc1d052
NIS
1418 # warn sprintf("substcont: op = %s, pmop = %s\n",
1419 # peekop($op), peekop($pmop));#debug
1420# my $pmopsym = objsym($pmop);
a798dbf2 1421 my $pmopsym = $pmop->save; # XXX can this recurse?
0cc1d052 1422# warn "pmopsym = $pmopsym\n";#debug
81009501 1423 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
a798dbf2
MB
1424 $pmopsym, label($pmop->pmreplstart));
1425 invalidate_lexicals();
1426 return $pmop->next;
1427}
1428
1429sub default_pp {
1430 my $op = shift;
3f872cb9 1431 my $ppname = "pp_" . $op->name;
df2464c8
VB
1432 if ($curcop and $need_curcop{$ppname}){
1433 $curcop->write_back;
1434 }
a798dbf2
MB
1435 write_back_lexicals() unless $skip_lexicals{$ppname};
1436 write_back_stack() unless $skip_stack{$ppname};
1437 doop($op);
1438 # XXX If the only way that ops can write to a TEMPORARY lexical is
1439 # when it's named in $op->targ then we could call
1440 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1441 # the temporaries. For now, we'll play it safe and write back the lot.
1442 invalidate_lexicals() unless $skip_invalidate{$ppname};
1443 return $op->next;
1444}
1445
1446sub compile_op {
1447 my $op = shift;
3f872cb9 1448 my $ppname = "pp_" . $op->name;
a798dbf2
MB
1449 if (exists $ignore_op{$ppname}) {
1450 return $op->next;
1451 }
1452 debug peek_stack() if $debug_stack;
1453 if ($debug_op) {
1454 debug sprintf("%s [%s]\n",
1455 peekop($op),
1456 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1457 }
1458 no strict 'refs';
1459 if (defined(&$ppname)) {
1460 $know_op = 0;
1461 return &$ppname($op);
1462 } else {
1463 return default_pp($op);
1464 }
1465}
1466
1467sub compile_bblock {
1468 my $op = shift;
1469 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1470 write_label($op);
1471 $know_op = 0;
1472 do {
1473 $op = compile_op($op);
1474 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1475 write_back_stack(); # boo hoo: big loss
1476 reload_lexicals();
1477 return $op;
1478}
1479
1480sub cc {
1481 my ($name, $root, $start, @padlist) = @_;
1482 my $op;
1483 init_pp($name);
1484 load_pad(@padlist);
1485 B::Pseudoreg->new_scope;
1486 @cxstack = ();
1487 if ($debug_timings) {
1488 warn sprintf("Basic block analysis at %s\n", timing_info);
1489 }
1490 $leaders = find_leaders($root, $start);
56eca212
GS
1491 my @leaders= keys %$leaders;
1492 if ($#leaders > -1) {
1493 @bblock_todo = ($start, values %$leaders) ;
1494 } else{
1495 runtime("return PL_op?PL_op->op_next:0;");
1496 }
a798dbf2
MB
1497 if ($debug_timings) {
1498 warn sprintf("Compilation at %s\n", timing_info);
1499 }
1500 while (@bblock_todo) {
1501 $op = shift @bblock_todo;
1502 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1503 next if !defined($op) || !$$op || $done{$$op};
1504 #warn "...compiling it\n"; # debug
1505 do {
1506 $done{$$op} = 1;
1507 $op = compile_bblock($op);
1508 if ($need_freetmps && $freetmps_each_bblock) {
1509 runtime("FREETMPS;");
1510 $need_freetmps = 0;
1511 }
1512 } while defined($op) && $$op && !$done{$$op};
1513 if ($need_freetmps && $freetmps_each_loop) {
1514 runtime("FREETMPS;");
1515 $need_freetmps = 0;
1516 }
1517 if (!$$op) {
a9b6343a 1518 runtime("PUTBACK;","return PL_op;");
a798dbf2
MB
1519 } elsif ($done{$$op}) {
1520 runtime(sprintf("goto %s;", label($op)));
1521 }
1522 }
1523 if ($debug_timings) {
1524 warn sprintf("Saving runtime at %s\n", timing_info);
1525 }
8bac7e00 1526 declare_pad(@padlist) ;
a798dbf2
MB
1527 save_runtime();
1528}
1529
1530sub cc_recurse {
1531 my $ccinfo;
1532 my $start;
1533 $start = cc_queue(@_) if @_;
1534 while ($ccinfo = shift @cc_todo) {
1535 cc(@$ccinfo);
1536 }
1537 return $start;
1538}
1539
1540sub cc_obj {
1541 my ($name, $cvref) = @_;
1542 my $cv = svref_2object($cvref);
1543 my @padlist = $cv->PADLIST->ARRAY;
1544 my $curpad_sym = $padlist[1]->save;
1545 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1546}
1547
1548sub cc_main {
1549 my @comppadlist = comppadlist->ARRAY;
0cc1d052
NIS
1550 my $curpad_nam = $comppadlist[0]->save;
1551 my $curpad_sym = $comppadlist[1]->save;
1552 my $init_av = init_av->save;
a798dbf2 1553 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
cfa4c8ee 1554 # Do save_unused_subs before saving inc_hv
0cc1d052 1555 save_unused_subs();
a798dbf2
MB
1556 cc_recurse();
1557
cfa4c8ee
VB
1558 my $inc_hv = svref_2object(\%INC)->save;
1559 my $inc_av = svref_2object(\@INC)->save;
56eca212 1560 my $amagic_generate= amagic_generation;
a798dbf2
MB
1561 return if $errors;
1562 if (!defined($module)) {
81009501
GS
1563 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1564 "PL_main_start = $start;",
5cfd8ad4 1565 "PL_curpad = AvARRAY($curpad_sym);",
5ab5c7a4 1566 "PL_initav = (AV *) $init_av;",
0cc1d052
NIS
1567 "GvHV(PL_incgv) = $inc_hv;",
1568 "GvAV(PL_incgv) = $inc_av;",
5cfd8ad4 1569 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
44887cfa 1570 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
56eca212 1571 "PL_amagic_generation= $amagic_generate;",
44887cfa
NIS
1572 );
1573
a798dbf2 1574 }
73544139 1575 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
a798dbf2
MB
1576 output_boilerplate();
1577 print "\n";
1578 output_all("perl_init");
1579 output_runtime();
1580 print "\n";
1581 output_main();
1582 if (defined($module)) {
1583 my $cmodule = $module;
1584 $cmodule =~ s/::/__/g;
1585 print <<"EOT";
1586
1587#include "XSUB.h"
1588XS(boot_$cmodule)
1589{
1590 dXSARGS;
1591 perl_init();
1592 ENTER;
1593 SAVETMPS;
81009501
GS
1594 SAVESPTR(PL_curpad);
1595 SAVESPTR(PL_op);
1596 PL_curpad = AvARRAY($curpad_sym);
1597 PL_op = $start;
66918de8 1598 pp_main(aTHX);
a798dbf2
MB
1599 FREETMPS;
1600 LEAVE;
81009501 1601 ST(0) = &PL_sv_yes;
a798dbf2
MB
1602 XSRETURN(1);
1603}
1604EOT
1605 }
1606 if ($debug_timings) {
1607 warn sprintf("Done at %s\n", timing_info);
1608 }
1609}
1610
1611sub compile {
1612 my @options = @_;
1613 my ($option, $opt, $arg);
1614 OPTION:
1615 while ($option = shift @options) {
1616 if ($option =~ /^-(.)(.*)/) {
1617 $opt = $1;
1618 $arg = $2;
1619 } else {
1620 unshift @options, $option;
1621 last OPTION;
1622 }
1623 if ($opt eq "-" && $arg eq "-") {
1624 shift @options;
1625 last OPTION;
1626 } elsif ($opt eq "o") {
1627 $arg ||= shift @options;
ff06c60c 1628 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
a798dbf2
MB
1629 } elsif ($opt eq "n") {
1630 $arg ||= shift @options;
1631 $module_name = $arg;
1632 } elsif ($opt eq "u") {
1633 $arg ||= shift @options;
0cc1d052 1634 mark_unused($arg,undef);
a798dbf2
MB
1635 } elsif ($opt eq "f") {
1636 $arg ||= shift @options;
1637 my $value = $arg !~ s/^no-//;
1638 $arg =~ s/-/_/g;
1639 my $ref = $optimise{$arg};
1640 if (defined($ref)) {
1641 $$ref = $value;
1642 } else {
1643 warn qq(ignoring unknown optimisation option "$arg"\n);
1644 }
1645 } elsif ($opt eq "O") {
1646 $arg = 1 if $arg eq "";
1647 my $ref;
1648 foreach $ref (values %optimise) {
1649 $$ref = 0;
1650 }
1651 if ($arg >= 2) {
1652 $freetmps_each_loop = 1;
1653 }
1654 if ($arg >= 1) {
1655 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1656 }
1657 } elsif ($opt eq "m") {
1658 $arg ||= shift @options;
1659 $module = $arg;
a9b6343a 1660 mark_unused($arg,undef);
a798dbf2
MB
1661 } elsif ($opt eq "p") {
1662 $arg ||= shift @options;
1663 $patchlevel = $arg;
1664 } elsif ($opt eq "D") {
1665 $arg ||= shift @options;
1666 foreach $arg (split(//, $arg)) {
1667 if ($arg eq "o") {
1668 B->debug(1);
1669 } elsif ($arg eq "O") {
1670 $debug_op = 1;
1671 } elsif ($arg eq "s") {
1672 $debug_stack = 1;
1673 } elsif ($arg eq "c") {
1674 $debug_cxstack = 1;
1675 } elsif ($arg eq "p") {
1676 $debug_pad = 1;
1677 } elsif ($arg eq "r") {
1678 $debug_runtime = 1;
1679 } elsif ($arg eq "S") {
1680 $debug_shadow = 1;
1681 } elsif ($arg eq "q") {
1682 $debug_queue = 1;
1683 } elsif ($arg eq "l") {
1684 $debug_lineno = 1;
1685 } elsif ($arg eq "t") {
1686 $debug_timings = 1;
1687 }
1688 }
1689 }
1690 }
1691 init_sections();
1692 $init = B::Section->get("init");
1693 $decl = B::Section->get("decl");
1694
1695 if (@options) {
1696 return sub {
1697 my ($objname, $ppname);
1698 foreach $objname (@options) {
1699 $objname = "main::$objname" unless $objname =~ /::/;
1700 ($ppname = $objname) =~ s/^.*?:://;
1701 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1702 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1703 return if $errors;
1704 }
1705 output_boilerplate();
1706 print "\n";
1707 output_all($module_name || "init_module");
1708 output_runtime();
1709 }
1710 } else {
1711 return sub { cc_main() };
1712 }
1713}
1714
17151;
7f20e9dd
GS
1716
1717__END__
1718
1719=head1 NAME
1720
1721B::CC - Perl compiler's optimized C translation backend
1722
1723=head1 SYNOPSIS
1724
1725 perl -MO=CC[,OPTIONS] foo.pl
1726
1727=head1 DESCRIPTION
1728
1a52ab62
MB
1729This compiler backend takes Perl source and generates C source code
1730corresponding to the flow of your program. In other words, this
1731backend is somewhat a "real" compiler in the sense that many people
1732think about compilers. Note however that, currently, it is a very
1733poor compiler in that although it generates (mostly, or at least
1734sometimes) correct code, it performs relatively few optimisations.
1735This will change as the compiler develops. The result is that
1736running an executable compiled with this backend may start up more
1737quickly than running the original Perl program (a feature shared
1738by the B<C> compiler backend--see F<B::C>) and may also execute
1739slightly faster. This is by no means a good optimising compiler--yet.
1740
1741=head1 OPTIONS
1742
1743If there are any non-option arguments, they are taken to be
1744names of objects to be saved (probably doesn't work properly yet).
1745Without extra arguments, it saves the main program.
1746
1747=over 4
1748
1749=item B<-ofilename>
1750
1751Output to filename instead of STDOUT
1752
1753=item B<-v>
1754
1755Verbose compilation (currently gives a few compilation statistics).
1756
1757=item B<-->
1758
1759Force end of options
1760
1761=item B<-uPackname>
1762
1763Force apparently unused subs from package Packname to be compiled.
1764This allows programs to use eval "foo()" even when sub foo is never
1765seen to be used at compile time. The down side is that any subs which
1766really are never used also have code generated. This option is
1767necessary, for example, if you have a signal handler foo which you
1768initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1769to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1770options. The compiler tries to figure out which packages may possibly
1771have subs in which need compiling but the current version doesn't do
1772it very well. In particular, it is confused by nested packages (i.e.
1773of the form C<A::B>) where package C<A> does not contain any subs.
1774
1775=item B<-mModulename>
1776
1777Instead of generating source for a runnable executable, generate
1778source for an XSUB module. The boot_Modulename function (which
1779DynaLoader can look for) does the appropriate initialisation and runs
1780the main part of the Perl source that is being compiled.
1781
1782
1783=item B<-D>
1784
1785Debug options (concatenated or separate flags like C<perl -D>).
1786
1787=item B<-Dr>
1788
1789Writes debugging output to STDERR just as it's about to write to the
1790program's runtime (otherwise writes debugging info as comments in
1791its C output).
1792
1793=item B<-DO>
1794
1795Outputs each OP as it's compiled
1796
1797=item B<-Ds>
1798
1799Outputs the contents of the shadow stack at each OP
1800
1801=item B<-Dp>
1802
1803Outputs the contents of the shadow pad of lexicals as it's loaded for
1804each sub or the main program.
1805
1806=item B<-Dq>
1807
1808Outputs the name of each fake PP function in the queue as it's about
1809to process it.
1810
1811=item B<-Dl>
1812
1813Output the filename and line number of each original line of Perl
1814code as it's processed (C<pp_nextstate>).
1815
1816=item B<-Dt>
1817
1818Outputs timing information of compilation stages.
1819
1820=item B<-f>
1821
1822Force optimisations on or off one at a time.
1823
1824=item B<-ffreetmps-each-bblock>
1825
1826Delays FREETMPS from the end of each statement to the end of the each
1827basic block.
1828
1829=item B<-ffreetmps-each-loop>
1830
1831Delays FREETMPS from the end of each statement to the end of the group
1832of basic blocks forming a loop. At most one of the freetmps-each-*
1833options can be used.
1834
1835=item B<-fomit-taint>
1836
1837Omits generating code for handling perl's tainting mechanism.
1838
1839=item B<-On>
1840
1841Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1842Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1843sets B<-ffreetmps-each-loop>.
1844
1845=back
1846
1847=head1 EXAMPLES
1848
1849 perl -MO=CC,-O2,-ofoo.c foo.pl
1850 perl cc_harness -o foo foo.c
1851
1852Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1853library directory. The utility called C<perlcc> may also be used to
1854help make use of this compiler.
1855
1856 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1857 perl cc_harness -shared -c -o Foo.so Foo.c
1858
1859=head1 BUGS
1860
1861Plenty. Current status: experimental.
1862
1863=head1 DIFFERENCES
1864
1865These aren't really bugs but they are constructs which are heavily
1866tied to perl's compile-and-go implementation and with which this
1867compiler backend cannot cope.
1868
1869=head2 Loops
1870
1871Standard perl calculates the target of "next", "last", and "redo"
1872at run-time. The compiler calculates the targets at compile-time.
1873For example, the program
1874
1875 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1876 NUMBER: for ($i = 0; $i < 5; $i++) {
1877 skip_on_odd($i);
1878 print $i;
1879 }
1880
1881produces the output
1882
1883 024
1884
1885with standard perl but gives a compile-time error with the compiler.
1886
1887=head2 Context of ".."
1888
1889The context (scalar or array) of the ".." operator determines whether
1890it behaves as a range or a flip/flop. Standard perl delays until
1891runtime the decision of which context it is in but the compiler needs
1892to know the context at compile-time. For example,
1893
1894 @a = (4,6,1,0,0,1);
1895 sub range { (shift @a)..(shift @a) }
1896 print range();
1897 while (@a) { print scalar(range()) }
1898
1899generates the output
1900
1901 456123E0
1902
1903with standard Perl but gives a compile-time error with compiled Perl.
1904
1905=head2 Arithmetic
1906
1907Compiled Perl programs use native C arithemtic much more frequently
1908than standard perl. Operations on large numbers or on boundary
1909cases may produce different behaviour.
1910
1911=head2 Deprecated features
1912
1913Features of standard perl such as C<$[> which have been deprecated
1914in standard perl since Perl5 was released have not been implemented
1915in the compiler.
7f20e9dd
GS
1916
1917=head1 AUTHOR
1918
1919Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1920
1921=cut