ext/B/B/CC.pm

   1 #      CC.pm
   2 #
   3 #      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
   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 #
   8 package B::CC;
   9 use strict;
  10 use B qw(main_start main_root class comppadlist peekop svref_2object
  11         timing_info init_av sv_undef amagic_generation
  12         OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
  13         OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
  14         OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
  15         CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
  16         );
  17 use B::C qw(save_unused_subs objsym init_sections mark_unused
  18             output_all output_boilerplate output_main);
  19 use B::Bblock qw(find_leaders);
  20 use B::Stackobj qw(:types :flags);
  21
  22 # These should probably be elsewhere
  23 # Flags for $op->flags
  24
  25 my $module;             # module name (when compiled with -m)
  26 my %done;               # hash keyed by $$op of leaders of basic blocks
  27                         # which have already been done.
  28 my $leaders;            # ref to hash of basic block leaders. Keys are $$op
  29                         # addresses, values are the $op objects themselves.
  30 my @bblock_todo;        # list of leaders of basic blocks that need visiting
  31                         # sometime.
  32 my @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.
  36 my @stack;              # shadows perl's stack when contents are known.
  37                         # Values are objects derived from class B::Stackobj
  38 my @pad;                # Lexicals in current pad as Stackobj-derived objects
  39 my @padlist;            # Copy of current padlist so PMOP repl code can find it
  40 my @cxstack;            # Shadows the (compile-time) cxstack for next,last,redo
  41 my $jmpbuf_ix = 0;      # Next free index for dynamically allocated jmpbufs
  42 my %constobj;           # OP_CONST constants as Stackobj-derived objects
  43                         # keyed by $$sv.
  44 my $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.
  47 my $know_op = 0;        # Set when C variable op already holds the right op
  48                         # (from an immediately preceding DOOP(ppname)).
  49 my $errors = 0;         # Number of errors encountered
  50 my %skip_stack;         # Hash of PP names which don't need write_back_stack
  51 my %skip_lexicals;      # Hash of PP names which don't need write_back_lexicals
  52 my %skip_invalidate;    # Hash of PP names which don't need invalidate_lexicals
  53 my %ignore_op;          # Hash of ops which do nothing except returning op_next
  54 my %need_curcop;        # Hash of ops which need PL_curcop
  55
  56 BEGIN {
  57     foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
  58         $ignore_op{$_} = 1;
  59     }
  60 }
  61
  62 my ($module_name);
  63 my ($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.
  69 my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
  70 my %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)
  74 my $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.
  78 my $ppname;             # name of current fake PP function
  79 my $runtime_list_ref;
  80 my $declare_ref;        # Hash ref keyed by C variable type of declarations.
  81
  82 my @pp_list;            # list of [$ppname, $runtime_list_ref, $declare_ref]
  83                         # tuples to be written out.
  84
  85 my ($init, $decl);
  86
  87 sub 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);
  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
  98                         pp_enter);
  99
 100 sub debug {
 101     if ($debug_runtime) {
 102         warn(@_);
 103     } else {
 104         runtime(map { chomp; "/* $_ */"} @_);
 105     }
 106 }
 107
 108 sub declare {
 109     my ($type, $var) = @_;
 110     push(@{$declare_ref->{$type}}, $var);
 111 }
 112
 113 sub push_runtime {
 114     push(@$runtime_list_ref, @_);
 115     warn join("\n", @_) . "\n" if $debug_runtime;
 116 }
 117
 118 sub save_runtime {
 119     push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
 120 }
 121
 122 sub output_runtime {
 123     my $ppdata;
 124     print qq(#include "cc_runtime.h"\n);
 125     foreach $ppdata (@pp_list) {
 126         my ($name, $runtime, $declare) = @$ppdata;
 127         print "\nstatic\nPP($name)\n{\n";
 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
 139 sub runtime {
 140     my $line;
 141     foreach $line (@_) {
 142         push_runtime("\t$line");
 143     }
 144 }
 145
 146 sub 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");
 155     $decl->add("static OP * $ppname (pTHX);");
 156     debug "init_pp: $ppname\n" if $debug_queue;
 157 }
 158
 159 # Initialise runtime_callback function for Stackobj class
 160 BEGIN { B::Stackobj::set_callback(\&runtime) }
 161
 162 # Initialise saveoptree_callback for B::C class
 163 sub 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 }
 177 BEGIN { B::C::set_callback(\&cc_queue) }
 178
 179 sub valid_int { $_[0]->{flags} & VALID_INT }
 180 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
 181 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
 182 sub valid_sv { $_[0]->{flags} & VALID_SV }
 183
 184 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
 185 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
 186 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
 187 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
 188 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
 189
 190 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
 191 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
 192 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
 193 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
 194 sub pop_bool {
 195     if (@stack) {
 196         return ((pop @stack)->as_bool);
 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
 205 sub 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
 216 sub 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
 226 sub 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
 237 sub 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 }
 318 my $curcop = new B::Shadow (sub {
 319     my $opsym = shift->save;
 320     runtime("PL_curcop = (COP*)$opsym;");
 321 });
 322
 323 #
 324 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
 325 #
 326 sub 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
 335 sub dopoptolabel {
 336     my $label = shift;
 337     my $cxix = $#cxstack;
 338     while ($cxix >= 0 &&
 339            ($cxstack[$cxix]->{type} != CXt_LOOP ||
 340             $cxstack[$cxix]->{label} ne $label)) {
 341         $cxix--;
 342     }
 343     debug "dopoptolabel: returning $cxix" if $debug_cxstack;
 344     return $cxix;
 345 }
 346
 347 sub 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 #
 367 sub 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") {
 388             # temporaries have &PL_sv_undef instead of a PVNV for a name
 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");
 405
 406         debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
 407     }
 408 }
 409
 410 sub 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 }
 421 #
 422 # Debugging stuff
 423 #
 424 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
 425
 426 #
 427 # OP stuff
 428 #
 429
 430 sub label {
 431     my $op = shift;
 432     # XXX Preserve original label name for "real" labels?
 433     return sprintf("lab_%x", $$op);
 434 }
 435
 436 sub write_label {
 437     my $op = shift;
 438     push_runtime(sprintf("  %s:", label($op)));
 439 }
 440
 441 sub loadop {
 442     my $op = shift;
 443     my $opsym = $op->save;
 444     runtime("PL_op = $opsym;") unless $know_op;
 445     return $opsym;
 446 }
 447
 448 sub 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
 457 sub gimme {
 458     my $op = shift;
 459     my $flags = $op->flags;
 460     return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
 461 }
 462
 463 #
 464 # Code generation for PP code
 465 #
 466
 467 sub pp_null {
 468     my $op = shift;
 469     return $op->next;
 470 }
 471
 472 sub pp_stub {
 473     my $op = shift;
 474     my $gimme = gimme($op);
 475     if ($gimme != G_ARRAY) {
 476         my $obj= new B::Stackobj::Const(sv_undef);
 477         push(@stack, $obj);
 478         # XXX Change to push a constant sv_undef Stackobj onto @stack
 479         #write_back_stack();
 480         #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
 481     }
 482     return $op->next;
 483 }
 484
 485 sub pp_unstack {
 486     my $op = shift;
 487     @stack = ();
 488     runtime("PP_UNSTACK;");
 489     return $op->next;
 490 }
 491
 492 sub 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();
 500         runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
 501     } else {
 502         runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
 503                 "*sp--;");
 504     }
 505     return $op->other;
 506 }
 507
 508 sub pp_or {
 509     my $op = shift;
 510     my $next = $op->next;
 511     reload_lexicals();
 512     unshift(@bblock_todo, $next);
 513     if (@stack >= 1) {
 514         my $bool = pop_bool @stack;
 515         write_back_stack();
 516         runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
 517                         $bool, label($next)));
 518     } else {
 519         runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
 520                 "*sp--;");
 521     }
 522     return $op->other;
 523 }
 524
 525 sub pp_cond_expr {
 526     my $op = shift;
 527     my $false = $op->next;
 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)));
 533     return $op->other;
 534 }
 535
 536 sub 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) {
 543             runtime("SAVECLEARSV(PL_curpad[$ix]);");
 544         } elsif ($private & OPpDEREF) {
 545             runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
 546                             $ix, $private & OPpDEREF));
 547             $pad[$ix]->invalidate;
 548         }
 549     }
 550     return $op->next;
 551 }
 552
 553 sub 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
 564 sub 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;
 570     runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
 571     if ($freetmps_each_bblock || $freetmps_each_loop) {
 572         $need_freetmps = 1;
 573     } else {
 574         runtime("FREETMPS;");
 575     }
 576     return $op->next;
 577 }
 578
 579 sub pp_dbstate {
 580     my $op = shift;
 581     $curcop->invalidate; # XXX?
 582     return default_pp($op);
 583 }
 584
 585 #default_pp will handle this:
 586 #sub pp_bless { $curcop->write_back; default_pp(@_) }
 587 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
 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
 590 #sub pp_caller { $curcop->write_back; default_pp(@_) }
 591 #sub pp_reset { $curcop->write_back; default_pp(@_) }
 592
 593 sub 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 }
 606 sub pp_sort {
 607     my $op = shift;
 608     my $ppname = $op->ppaddr;
 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;
 614         $op->first->save;
 615         $op->first->sibling->save;
 616         $root->save;
 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     }
 621     $curcop->write_back;
 622     write_back_lexicals();
 623     write_back_stack();
 624     doop($op);
 625     return $op->next;
 626 }
 627 sub 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
 635 sub 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
 647 sub 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);",
 654             "PUSHs(svp ? *svp : &PL_sv_undef);");
 655     return $op->next;
 656 }
 657
 658 sub 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
 679 sub INTS_CLOSED () { 0x1 }
 680 sub INT_RESULT () { 0x2 }
 681 sub NUMERIC_RESULT () { 0x4 }
 682
 683 sub 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) {
 700                 my $rightruntime = new B::Pseudoreg ("IV", "riv");
 701                 runtime(sprintf("$$rightruntime = %s;",$right));
 702                 runtime(sprintf("sv_setiv(TOPs, %s);",
 703                                 &$operator("TOPi", $$rightruntime)));
 704             } else {
 705                 my $rightruntime = new B::Pseudoreg ("double", "rnv");
 706                 runtime(sprintf("$$rightruntime = %s;",$right));
 707                 runtime(sprintf("sv_setnv(TOPs, %s);",
 708                                 &$operator("TOPn",$$rightruntime)));
 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
 732 sub 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
 786 sub 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
 831 sub 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
 842 sub 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
 854 sub 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
 863 sub infix_op {
 864     my $opname = shift;
 865     return sub { "$_[0] $opname $_[1]" }
 866 }
 867
 868 sub prefix_op {
 869     my $opname = shift;
 870     return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
 871 }
 872
 873 BEGIN {
 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("<<");
 880     my $rshift_op = infix_op(">>");
 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     #
 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) }
 902     sub pp_divide { numeric_binop($_[0], $divide_op) }
 903     sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
 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
 937 sub 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) {
 947             $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
 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};
 958             runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
 959             if ($type == T_INT) {
 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                 }
 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 {
 972             my $dst = $stack[-1];
 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 {
 981                 runtime("SvSetMagicSV($dst->{sv}, sv);");
 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
 999 sub 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
1016 sub pp_pushmark {
1017     my $op = shift;
1018     write_back_stack();
1019     runtime("PUSHMARK(sp);");
1020     return $op->next;
1021 }
1022
1023 sub pp_list {
1024     my $op = shift;
1025     write_back_stack();
1026     my $gimme = gimme($op);
1027     if ($gimme == G_ARRAY) { # sic
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
1035 sub pp_entersub {
1036     my $op = shift;
1037     $curcop->write_back;
1038     write_back_lexicals(REGISTER|TEMPORARY);
1039     write_back_stack();
1040     my $sym = doop($op);
1041     runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1042     runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
1043     runtime("SPAGAIN;}");
1044     $know_op = 0;
1045     invalidate_lexicals(REGISTER|TEMPORARY);
1046     return $op->next;
1047 }
1048 sub pp_formline {
1049     my $op = shift;
1050     my $ppname = $op->ppaddr;
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;");
1056     runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1057     runtime( sprintf("goto %s;",label($op->first)));
1058     runtime("}");
1059     return $op->next;
1060 }
1061
1062 sub 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 }
1073 sub pp_enterwrite {
1074     my $op = shift;
1075     pp_entersub($op);
1076 }
1077 sub 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 }
1087 sub 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()?
1094     #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
1095     runtime("SPAGAIN;");
1096     $know_op = 0;
1097     invalidate_lexicals(REGISTER|TEMPORARY);
1098     return $op->next;
1099 }
1100
1101 sub 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;
1108     #runtime(qq/printf("$ppaddr type eval\n");/);
1109     runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1110     $know_op = 1;
1111     invalidate_lexicals(REGISTER|TEMPORARY);
1112     return $op->next;
1113 }
1114
1115 sub pp_entereval { doeval(@_) }
1116 sub pp_dofile { doeval(@_) }
1117
1118 #pp_require is protected by pp_entertry, so no protection for it.
1119 sub 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
1134 sub 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++);
1141     declare("JMPENV", $jmpbuf);
1142     runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1143     invalidate_lexicals(REGISTER|TEMPORARY);
1144     return $op->next;
1145 }
1146
1147 sub pp_leavetry{
1148         my $op=shift;
1149         default_pp($op);
1150         runtime("PP_LEAVETRY;");
1151         return $op->next;
1152 }
1153
1154 sub 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();
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)));
1168     return $op->next->other;
1169 }
1170
1171 sub 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();
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;
1185     runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1186                     label($nexttonext)));
1187     return $op->next->other;
1188 }
1189
1190 sub 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;");
1203     runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1204     $know_op = 0;
1205     return $op->other;
1206 }
1207
1208 sub pp_mapwhile {
1209     pp_grepwhile(@_);
1210 }
1211
1212 sub pp_return {
1213     my $op = shift;
1214     write_back_lexicals(REGISTER|TEMPORARY);
1215     write_back_stack();
1216     doop($op);
1217     runtime("PUTBACK;", "return PL_op;");
1218     $know_op = 0;
1219     return $op->next;
1220 }
1221
1222 sub nyi {
1223     my $op = shift;
1224     warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1225     return default_pp($op);
1226 }
1227
1228 sub pp_range {
1229     my $op = shift;
1230     my $flags = $op->flags;
1231     if (!($flags & OPf_WANT)) {
1232         error("context of range unknown at compile-time");
1233     }
1234     write_back_lexicals();
1235     write_back_stack();
1236     unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
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;
1240         runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1241                         $op->targ, label($op->other));
1242         unshift(@bblock_todo, $op->other);
1243     }
1244     return $op->next;
1245 }
1246
1247 sub pp_flip {
1248     my $op = shift;
1249     my $flags = $op->flags;
1250     if (!($flags & OPf_WANT)) {
1251         error("context of flip unknown at compile-time");
1252     }
1253     if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1254         return $op->first->other;
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) ?
1264             "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1265           : "if (SvTRUE(TOPs)) {");
1266     runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1267     if ($op->flags & OPf_SPECIAL) {
1268         runtime("sv_setiv(PL_curpad[$ix], 1);");
1269     } else {
1270         runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1271                 "\tsp--;",
1272                 sprintf("\tgoto %s;", label($op->first->other)));
1273     }
1274     runtime("}",
1275           qq{sv_setpv(PL_curpad[$ix], "");},
1276             "SETs(PL_curpad[$ix]);");
1277     $know_op = 0;
1278     return $op->next;
1279 }
1280
1281 sub pp_flop {
1282     my $op = shift;
1283     default_pp($op);
1284     $know_op = 0;
1285     return $op->next;
1286 }
1287
1288 sub 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
1309 sub pp_enterloop { enterloop(@_) }
1310 sub pp_enteriter { enterloop(@_) }
1311
1312 sub 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
1322 sub 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
1345 sub 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
1368 sub 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
1396 sub 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) {
1403         runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1404                         $sym, label($replroot));
1405         $op->pmreplstart->save;
1406         push(@bblock_todo, $replroot);
1407     }
1408     invalidate_lexicals();
1409     return $op->next;
1410 }
1411
1412 sub pp_substcont {
1413     my $op = shift;
1414     write_back_lexicals();
1415     write_back_stack();
1416     doop($op);
1417     my $pmop = $op->other;
1418     # warn sprintf("substcont: op = %s, pmop = %s\n",
1419     #            peekop($op), peekop($pmop));#debug
1420 #   my $pmopsym = objsym($pmop);
1421     my $pmopsym = $pmop->save; # XXX can this recurse?
1422 #   warn "pmopsym = $pmopsym\n";#debug
1423     runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1424                     $pmopsym, label($pmop->pmreplstart));
1425     invalidate_lexicals();
1426     return $pmop->next;
1427 }
1428
1429 sub default_pp {
1430     my $op = shift;
1431     my $ppname = $op->ppaddr;
1432     if ($curcop and $need_curcop{$ppname}){
1433         $curcop->write_back;
1434     }
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
1446 sub compile_op {
1447     my $op = shift;
1448     my $ppname = $op->ppaddr;
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
1467 sub 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
1480 sub 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);
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     }
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) {
1518             runtime("PUTBACK;","return PL_op;");
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     }
1526     declare_pad(@padlist) ;
1527     save_runtime();
1528 }
1529
1530 sub 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
1540 sub 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
1548 sub cc_main {
1549     my @comppadlist = comppadlist->ARRAY;
1550     my $curpad_nam  = $comppadlist[0]->save;
1551     my $curpad_sym  = $comppadlist[1]->save;
1552     my $init_av     = init_av->save;
1553     my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1554     # Do save_unused_subs before saving inc_hv
1555     save_unused_subs();
1556     cc_recurse();
1557
1558     my $inc_hv      = svref_2object(\%INC)->save;
1559     my $inc_av      = svref_2object(\@INC)->save;
1560     my $amagic_generate= amagic_generation;
1561     return if $errors;
1562     if (!defined($module)) {
1563         $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1564                    "PL_main_start = $start;",
1565                    "PL_curpad = AvARRAY($curpad_sym);",
1566                    "PL_initav = (AV *) $init_av;",
1567                    "GvHV(PL_incgv) = $inc_hv;",
1568                    "GvAV(PL_incgv) = $inc_av;",
1569                    "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1570                    "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1571                    "PL_amagic_generation= $amagic_generate;",
1572                      );
1573
1574     }
1575     seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
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"
1588 XS(boot_$cmodule)
1589 {
1590     dXSARGS;
1591     perl_init();
1592     ENTER;
1593     SAVETMPS;
1594     SAVESPTR(PL_curpad);
1595     SAVESPTR(PL_op);
1596     PL_curpad = AvARRAY($curpad_sym);
1597     PL_op = $start;
1598     pp_main(aTHX);
1599     FREETMPS;
1600     LEAVE;
1601     ST(0) = &PL_sv_yes;
1602     XSRETURN(1);
1603 }
1604 EOT
1605     }
1606     if ($debug_timings) {
1607         warn sprintf("Done at %s\n", timing_info);
1608     }
1609 }
1610
1611 sub 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;
1628             open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1629         } elsif ($opt eq "n") {
1630             $arg ||= shift @options;
1631             $module_name = $arg;
1632         } elsif ($opt eq "u") {
1633             $arg ||= shift @options;
1634             mark_unused($arg,undef);
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;
1660             mark_unused($arg,undef);
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
1715 1;
1716
1717 __END__
1718
1719 =head1 NAME
1720
1721 B::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
1729 This compiler backend takes Perl source and generates C source code
1730 corresponding to the flow of your program. In other words, this
1731 backend is somewhat a "real" compiler in the sense that many people
1732 think about compilers. Note however that, currently, it is a very
1733 poor compiler in that although it generates (mostly, or at least
1734 sometimes) correct code, it performs relatively few optimisations.
1735 This will change as the compiler develops. The result is that
1736 running an executable compiled with this backend may start up more
1737 quickly than running the original Perl program (a feature shared
1738 by the B<C> compiler backend--see F<B::C>) and may also execute
1739 slightly faster. This is by no means a good optimising compiler--yet.
1740
1741 =head1 OPTIONS
1742
1743 If there are any non-option arguments, they are taken to be
1744 names of objects to be saved (probably doesn't work properly yet).
1745 Without extra arguments, it saves the main program.
1746
1747 =over 4
1748
1749 =item B<-ofilename>
1750
1751 Output to filename instead of STDOUT
1752
1753 =item B<-v>
1754
1755 Verbose compilation (currently gives a few compilation statistics).
1756
1757 =item B<-->
1758
1759 Force end of options
1760
1761 =item B<-uPackname>
1762
1763 Force apparently unused subs from package Packname to be compiled.
1764 This allows programs to use eval "foo()" even when sub foo is never
1765 seen to be used at compile time. The down side is that any subs which
1766 really are never used also have code generated. This option is
1767 necessary, for example, if you have a signal handler foo which you
1768 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1769 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1770 options. The compiler tries to figure out which packages may possibly
1771 have subs in which need compiling but the current version doesn't do
1772 it very well. In particular, it is confused by nested packages (i.e.
1773 of the form C<A::B>) where package C<A> does not contain any subs.
1774
1775 =item B<-mModulename>
1776
1777 Instead of generating source for a runnable executable, generate
1778 source for an XSUB module. The boot_Modulename function (which
1779 DynaLoader can look for) does the appropriate initialisation and runs
1780 the main part of the Perl source that is being compiled.
1781
1782
1783 =item B<-D>
1784
1785 Debug options (concatenated or separate flags like C<perl -D>).
1786
1787 =item B<-Dr>
1788
1789 Writes debugging output to STDERR just as it's about to write to the
1790 program's runtime (otherwise writes debugging info as comments in
1791 its C output).
1792
1793 =item B<-DO>
1794
1795 Outputs each OP as it's compiled
1796
1797 =item B<-Ds>
1798
1799 Outputs the contents of the shadow stack at each OP
1800
1801 =item B<-Dp>
1802
1803 Outputs the contents of the shadow pad of lexicals as it's loaded for
1804 each sub or the main program.
1805
1806 =item B<-Dq>
1807
1808 Outputs the name of each fake PP function in the queue as it's about
1809 to process it.
1810
1811 =item B<-Dl>
1812
1813 Output the filename and line number of each original line of Perl
1814 code as it's processed (C<pp_nextstate>).
1815
1816 =item B<-Dt>
1817
1818 Outputs timing information of compilation stages.
1819
1820 =item B<-f>
1821
1822 Force optimisations on or off one at a time.
1823
1824 =item B<-ffreetmps-each-bblock>
1825
1826 Delays FREETMPS from the end of each statement to the end of the each
1827 basic block.
1828
1829 =item B<-ffreetmps-each-loop>
1830
1831 Delays FREETMPS from the end of each statement to the end of the group
1832 of basic blocks forming a loop. At most one of the freetmps-each-*
1833 options can be used.
1834
1835 =item B<-fomit-taint>
1836
1837 Omits generating code for handling perl's tainting mechanism.
1838
1839 =item B<-On>
1840
1841 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1842 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1843 sets 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
1852 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1853 library directory. The utility called C<perlcc> may also be used to
1854 help 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
1861 Plenty. Current status: experimental.
1862
1863 =head1 DIFFERENCES
1864
1865 These aren't really bugs but they are constructs which are heavily
1866 tied to perl's compile-and-go implementation and with which this
1867 compiler backend cannot cope.
1868
1869 =head2 Loops
1870
1871 Standard perl calculates the target of "next", "last", and "redo"
1872 at run-time. The compiler calculates the targets at compile-time.
1873 For 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
1881 produces the output
1882
1883     024
1884
1885 with standard perl but gives a compile-time error with the compiler.
1886
1887 =head2 Context of ".."
1888
1889 The context (scalar or array) of the ".." operator determines whether
1890 it behaves as a range or a flip/flop. Standard perl delays until
1891 runtime the decision of which context it is in but the compiler needs
1892 to 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
1899 generates the output
1900
1901     456123E0
1902
1903 with standard Perl but gives a compile-time error with compiled Perl.
1904
1905 =head2 Arithmetic
1906
1907 Compiled Perl programs use native C arithemtic much more frequently
1908 than standard perl. Operations on large numbers or on boundary
1909 cases may produce different behaviour.
1910
1911 =head2 Deprecated features
1912
1913 Features of standard perl such as C<$[> which have been deprecated
1914 in standard perl since Perl5 was released have not been implemented
1915 in the compiler.
1916
1917 =head1 AUTHOR
1918
1919 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1920
1921 =cut