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