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 pp_method);
  99
 100 sub debug {
 101     if ($debug_runtime) {
 102         warn(@_);
 103     } else {
 104         my @tmp=@_;
 105         runtime(map { chomp; "/* $_ */"} @tmp);
 106     }
 107 }
 108
 109 sub declare {
 110     my ($type, $var) = @_;
 111     push(@{$declare_ref->{$type}}, $var);
 112 }
 113
 114 sub push_runtime {
 115     push(@$runtime_list_ref, @_);
 116     warn join("\n", @_) . "\n" if $debug_runtime;
 117 }
 118
 119 sub save_runtime {
 120     push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
 121 }
 122
 123 sub output_runtime {
 124     my $ppdata;
 125     print qq(#include "cc_runtime.h"\n);
 126     foreach $ppdata (@pp_list) {
 127         my ($name, $runtime, $declare) = @$ppdata;
 128         print "\nstatic\nCCPP($name)\n{\n";
 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
 140 sub runtime {
 141     my $line;
 142     foreach $line (@_) {
 143         push_runtime("\t$line");
 144     }
 145 }
 146
 147 sub 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");
 156     $decl->add("static OP * $ppname (pTHX);");
 157     debug "init_pp: $ppname\n" if $debug_queue;
 158 }
 159
 160 # Initialise runtime_callback function for Stackobj class
 161 BEGIN { B::Stackobj::set_callback(\&runtime) }
 162
 163 # Initialise saveoptree_callback for B::C class
 164 sub 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 }
 178 BEGIN { B::C::set_callback(\&cc_queue) }
 179
 180 sub valid_int { $_[0]->{flags} & VALID_INT }
 181 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
 182 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
 183 sub valid_sv { $_[0]->{flags} & VALID_SV }
 184
 185 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
 186 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
 187 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
 188 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
 189 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
 190
 191 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
 192 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
 193 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
 194 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
 195 sub pop_bool {
 196     if (@stack) {
 197         return ((pop @stack)->as_bool);
 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
 206 sub 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
 217 sub 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
 227 sub 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
 238 sub 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 }
 319 my $curcop = new B::Shadow (sub {
 320     my $opsym = shift->save;
 321     runtime("PL_curcop = (COP*)$opsym;");
 322 });
 323
 324 #
 325 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
 326 #
 327 sub 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
 336 sub dopoptolabel {
 337     my $label = shift;
 338     my $cxix = $#cxstack;
 339     while ($cxix >= 0 &&
 340            ($cxstack[$cxix]->{type} != CXt_LOOP ||
 341             $cxstack[$cxix]->{label} ne $label)) {
 342         $cxix--;
 343     }
 344     debug "dopoptolabel: returning $cxix" if $debug_cxstack;
 345     return $cxix;
 346 }
 347
 348 sub 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 #
 368 sub 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") {
 389             # temporaries have &PL_sv_undef instead of a PVNV for a name
 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");
 406
 407         debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
 408     }
 409 }
 410
 411 sub 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 }
 422 #
 423 # Debugging stuff
 424 #
 425 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
 426
 427 #
 428 # OP stuff
 429 #
 430
 431 sub label {
 432     my $op = shift;
 433     # XXX Preserve original label name for "real" labels?
 434     return sprintf("lab_%x", $$op);
 435 }
 436
 437 sub write_label {
 438     my $op = shift;
 439     push_runtime(sprintf("  %s:", label($op)));
 440 }
 441
 442 sub loadop {
 443     my $op = shift;
 444     my $opsym = $op->save;
 445     runtime("PL_op = $opsym;") unless $know_op;
 446     return $opsym;
 447 }
 448
 449 sub 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
 458 sub gimme {
 459     my $op = shift;
 460     my $flags = $op->flags;
 461     return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
 462 }
 463
 464 #
 465 # Code generation for PP code
 466 #
 467
 468 sub pp_null {
 469     my $op = shift;
 470     return $op->next;
 471 }
 472
 473 sub pp_stub {
 474     my $op = shift;
 475     my $gimme = gimme($op);
 476     if ($gimme != G_ARRAY) {
 477         my $obj= new B::Stackobj::Const(sv_undef);
 478         push(@stack, $obj);
 479         # XXX Change to push a constant sv_undef Stackobj onto @stack
 480         #write_back_stack();
 481         #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
 482     }
 483     return $op->next;
 484 }
 485
 486 sub pp_unstack {
 487     my $op = shift;
 488     @stack = ();
 489     runtime("PP_UNSTACK;");
 490     return $op->next;
 491 }
 492
 493 sub 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();
 501         runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
 502     } else {
 503         runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
 504                 "*sp--;");
 505     }
 506     return $op->other;
 507 }
 508
 509 sub pp_or {
 510     my $op = shift;
 511     my $next = $op->next;
 512     reload_lexicals();
 513     unshift(@bblock_todo, $next);
 514     if (@stack >= 1) {
 515         my $bool = pop_bool @stack;
 516         write_back_stack();
 517         runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
 518                         $bool, label($next)));
 519     } else {
 520         runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
 521                 "*sp--;");
 522     }
 523     return $op->other;
 524 }
 525
 526 sub pp_cond_expr {
 527     my $op = shift;
 528     my $false = $op->next;
 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)));
 534     return $op->other;
 535 }
 536
 537 sub 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) {
 544             runtime("SAVECLEARSV(PL_curpad[$ix]);");
 545         } elsif ($private & OPpDEREF) {
 546             runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
 547                             $ix, $private & OPpDEREF));
 548             $pad[$ix]->invalidate;
 549         }
 550     }
 551     return $op->next;
 552 }
 553
 554 sub 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
 565 sub 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;
 571     runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
 572     if ($freetmps_each_bblock || $freetmps_each_loop) {
 573         $need_freetmps = 1;
 574     } else {
 575         runtime("FREETMPS;");
 576     }
 577     return $op->next;
 578 }
 579
 580 sub pp_dbstate {
 581     my $op = shift;
 582     $curcop->invalidate; # XXX?
 583     return default_pp($op);
 584 }
 585
 586 #default_pp will handle this:
 587 #sub pp_bless { $curcop->write_back; default_pp(@_) }
 588 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
 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
 591 #sub pp_caller { $curcop->write_back; default_pp(@_) }
 592 #sub pp_reset { $curcop->write_back; default_pp(@_) }
 593
 594 sub 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 }
 607 sub pp_sort {
 608     my $op = shift;
 609     my $ppname = $op->ppaddr;
 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;
 615         $op->first->save;
 616         $op->first->sibling->save;
 617         $root->save;
 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     }
 622     $curcop->write_back;
 623     write_back_lexicals();
 624     write_back_stack();
 625     doop($op);
 626     return $op->next;
 627 }
 628 sub 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
 636 sub 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
 648 sub 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);",
 655             "PUSHs(svp ? *svp : &PL_sv_undef);");
 656     return $op->next;
 657 }
 658
 659 sub 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
 680 sub INTS_CLOSED () { 0x1 }
 681 sub INT_RESULT () { 0x2 }
 682 sub NUMERIC_RESULT () { 0x4 }
 683
 684 sub 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) {
 701                 my $rightruntime = new B::Pseudoreg ("IV", "riv");
 702                 runtime(sprintf("$$rightruntime = %s;",$right));
 703                 runtime(sprintf("sv_setiv(TOPs, %s);",
 704                                 &$operator("TOPi", $$rightruntime)));
 705             } else {
 706                 my $rightruntime = new B::Pseudoreg ("double", "rnv");
 707                 runtime(sprintf("$$rightruntime = %s;",$right));
 708                 runtime(sprintf("sv_setnv(TOPs, %s);",
 709                                 &$operator("TOPn",$$rightruntime)));
 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
 733 sub 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
 787 sub 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
 832 sub 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
 843 sub 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
 855 sub 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
 864 sub infix_op {
 865     my $opname = shift;
 866     return sub { "$_[0] $opname $_[1]" }
 867 }
 868
 869 sub prefix_op {
 870     my $opname = shift;
 871     return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
 872 }
 873
 874 BEGIN {
 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("<<");
 881     my $rshift_op = infix_op(">>");
 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     #
 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) }
 903     sub pp_divide { numeric_binop($_[0], $divide_op) }
 904     sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
 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
 938 sub 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) {
 948             $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
 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};
 959             runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
 960             if ($type == T_INT) {
 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                 }
 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 {
 973             my $dst = $stack[-1];
 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 {
 982                 runtime("SvSetMagicSV($dst->{sv}, sv);");
 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
1000 sub 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
1017 sub pp_pushmark {
1018     my $op = shift;
1019     write_back_stack();
1020     runtime("PUSHMARK(sp);");
1021     return $op->next;
1022 }
1023
1024 sub pp_list {
1025     my $op = shift;
1026     write_back_stack();
1027     my $gimme = gimme($op);
1028     if ($gimme == G_ARRAY) { # sic
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
1036 sub pp_entersub {
1037     my $op = shift;
1038     $curcop->write_back;
1039     write_back_lexicals(REGISTER|TEMPORARY);
1040     write_back_stack();
1041     my $sym = doop($op);
1042     runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1043     runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
1044     runtime("SPAGAIN;}");
1045     $know_op = 0;
1046     invalidate_lexicals(REGISTER|TEMPORARY);
1047     return $op->next;
1048 }
1049 sub pp_formline {
1050     my $op = shift;
1051     my $ppname = $op->ppaddr;
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;");
1057     runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1058     runtime( sprintf("goto %s;",label($op->first)));
1059     runtime("}");
1060     return $op->next;
1061 }
1062
1063 sub 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 }
1074 sub pp_enterwrite {
1075     my $op = shift;
1076     pp_entersub($op);
1077 }
1078 sub 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 }
1088 sub 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()?
1095     #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
1096     runtime("SPAGAIN;");
1097     $know_op = 0;
1098     invalidate_lexicals(REGISTER|TEMPORARY);
1099     return $op->next;
1100 }
1101
1102 sub 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;
1109     #runtime(qq/printf("$ppaddr type eval\n");/);
1110     runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1111     $know_op = 1;
1112     invalidate_lexicals(REGISTER|TEMPORARY);
1113     return $op->next;
1114 }
1115
1116 sub pp_entereval { doeval(@_) }
1117 sub pp_dofile { doeval(@_) }
1118
1119 #pp_require is protected by pp_entertry, so no protection for it.
1120 sub 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
1135 sub 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++);
1142     declare("JMPENV", $jmpbuf);
1143     runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1144     invalidate_lexicals(REGISTER|TEMPORARY);
1145     return $op->next;
1146 }
1147
1148 sub pp_leavetry{
1149         my $op=shift;
1150         default_pp($op);
1151         runtime("PP_LEAVETRY;");
1152         return $op->next;
1153 }
1154
1155 sub 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();
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)));
1169     return $op->next->other;
1170 }
1171
1172 sub 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();
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;
1186     runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1187                     label($nexttonext)));
1188     return $op->next->other;
1189 }
1190
1191 sub 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;");
1204     runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1205     $know_op = 0;
1206     return $op->other;
1207 }
1208
1209 sub pp_mapwhile {
1210     pp_grepwhile(@_);
1211 }
1212
1213 sub pp_return {
1214     my $op = shift;
1215     write_back_lexicals(REGISTER|TEMPORARY);
1216     write_back_stack();
1217     doop($op);
1218     runtime("PUTBACK;", "return PL_op;");
1219     $know_op = 0;
1220     return $op->next;
1221 }
1222
1223 sub nyi {
1224     my $op = shift;
1225     warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1226     return default_pp($op);
1227 }
1228
1229 sub pp_range {
1230     my $op = shift;
1231     my $flags = $op->flags;
1232     if (!($flags & OPf_WANT)) {
1233         error("context of range unknown at compile-time");
1234     }
1235     write_back_lexicals();
1236     write_back_stack();
1237     unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
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;
1241         runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1242                         $op->targ, label($op->other));
1243         unshift(@bblock_todo, $op->other);
1244     }
1245     return $op->next;
1246 }
1247
1248 sub pp_flip {
1249     my $op = shift;
1250     my $flags = $op->flags;
1251     if (!($flags & OPf_WANT)) {
1252         error("context of flip unknown at compile-time");
1253     }
1254     if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1255         return $op->first->other;
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) ?
1265             "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1266           : "if (SvTRUE(TOPs)) {");
1267     runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1268     if ($op->flags & OPf_SPECIAL) {
1269         runtime("sv_setiv(PL_curpad[$ix], 1);");
1270     } else {
1271         runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1272                 "\tsp--;",
1273                 sprintf("\tgoto %s;", label($op->first->other)));
1274     }
1275     runtime("}",
1276           qq{sv_setpv(PL_curpad[$ix], "");},
1277             "SETs(PL_curpad[$ix]);");
1278     $know_op = 0;
1279     return $op->next;
1280 }
1281
1282 sub pp_flop {
1283     my $op = shift;
1284     default_pp($op);
1285     $know_op = 0;
1286     return $op->next;
1287 }
1288
1289 sub 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
1310 sub pp_enterloop { enterloop(@_) }
1311 sub pp_enteriter { enterloop(@_) }
1312
1313 sub 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
1323 sub 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
1346 sub 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
1369 sub 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
1397 sub 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) {
1404         runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1405                         $sym, label($replroot));
1406         $op->pmreplstart->save;
1407         push(@bblock_todo, $replroot);
1408     }
1409     invalidate_lexicals();
1410     return $op->next;
1411 }
1412
1413 sub pp_substcont {
1414     my $op = shift;
1415     write_back_lexicals();
1416     write_back_stack();
1417     doop($op);
1418     my $pmop = $op->other;
1419     # warn sprintf("substcont: op = %s, pmop = %s\n",
1420     #            peekop($op), peekop($pmop));#debug
1421 #   my $pmopsym = objsym($pmop);
1422     my $pmopsym = $pmop->save; # XXX can this recurse?
1423 #   warn "pmopsym = $pmopsym\n";#debug
1424     runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1425                     $pmopsym, label($pmop->pmreplstart));
1426     invalidate_lexicals();
1427     return $pmop->next;
1428 }
1429
1430 sub default_pp {
1431     my $op = shift;
1432     my $ppname = "pp_" . $op->name;
1433     if ($curcop and $need_curcop{$ppname}){
1434         $curcop->write_back;
1435     }
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
1447 sub compile_op {
1448     my $op = shift;
1449     my $ppname = "pp_" . $op->name;
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
1468 sub 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
1481 sub cc {
1482     my ($name, $root, $start, @padlist) = @_;
1483     my $op;
1484     if($done{$$start}){
1485         #warn "repeat=>".ref($start)."$name,\n";#debug
1486         $decl->add(sprintf("#define $name  %s",$done{$$start}));
1487         return;
1488     }
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);
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     }
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 {
1512             $done{$$op} = $name;
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) {
1524             runtime("PUTBACK;","return PL_op;");
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     }
1532     declare_pad(@padlist) ;
1533     save_runtime();
1534 }
1535
1536 sub 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
1546 sub 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
1554 sub cc_main {
1555     my @comppadlist = comppadlist->ARRAY;
1556     my $curpad_nam  = $comppadlist[0]->save;
1557     my $curpad_sym  = $comppadlist[1]->save;
1558     my $init_av     = init_av->save;
1559     my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1560     # Do save_unused_subs before saving inc_hv
1561     save_unused_subs();
1562     cc_recurse();
1563
1564     my $inc_hv      = svref_2object(\%INC)->save;
1565     my $inc_av      = svref_2object(\@INC)->save;
1566     my $amagic_generate= amagic_generation;
1567     return if $errors;
1568     if (!defined($module)) {
1569         $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1570                    "PL_main_start = $start;",
1571                    "PL_curpad = AvARRAY($curpad_sym);",
1572                    "PL_initav = (AV *) $init_av;",
1573                    "GvHV(PL_incgv) = $inc_hv;",
1574                    "GvAV(PL_incgv) = $inc_av;",
1575                    "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1576                    "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1577                    "PL_amagic_generation= $amagic_generate;",
1578                      );
1579
1580     }
1581     seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
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"
1594 XS(boot_$cmodule)
1595 {
1596     dXSARGS;
1597     perl_init();
1598     ENTER;
1599     SAVETMPS;
1600     SAVESPTR(PL_curpad);
1601     SAVESPTR(PL_op);
1602     PL_curpad = AvARRAY($curpad_sym);
1603     PL_op = $start;
1604     pp_main(aTHX);
1605     FREETMPS;
1606     LEAVE;
1607     ST(0) = &PL_sv_yes;
1608     XSRETURN(1);
1609 }
1610 EOT
1611     }
1612     if ($debug_timings) {
1613         warn sprintf("Done at %s\n", timing_info);
1614     }
1615 }
1616
1617 sub 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;
1634             open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1635         } elsif ($opt eq "n") {
1636             $arg ||= shift @options;
1637             $module_name = $arg;
1638         } elsif ($opt eq "u") {
1639             $arg ||= shift @options;
1640             mark_unused($arg,undef);
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;
1666             mark_unused($arg,undef);
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
1721 1;
1722
1723 __END__
1724
1725 =head1 NAME
1726
1727 B::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
1735 This compiler backend takes Perl source and generates C source code
1736 corresponding to the flow of your program. In other words, this
1737 backend is somewhat a "real" compiler in the sense that many people
1738 think about compilers. Note however that, currently, it is a very
1739 poor compiler in that although it generates (mostly, or at least
1740 sometimes) correct code, it performs relatively few optimisations.
1741 This will change as the compiler develops. The result is that
1742 running an executable compiled with this backend may start up more
1743 quickly than running the original Perl program (a feature shared
1744 by the B<C> compiler backend--see F<B::C>) and may also execute
1745 slightly faster. This is by no means a good optimising compiler--yet.
1746
1747 =head1 OPTIONS
1748
1749 If there are any non-option arguments, they are taken to be
1750 names of objects to be saved (probably doesn't work properly yet).
1751 Without extra arguments, it saves the main program.
1752
1753 =over 4
1754
1755 =item B<-ofilename>
1756
1757 Output to filename instead of STDOUT
1758
1759 =item B<-v>
1760
1761 Verbose compilation (currently gives a few compilation statistics).
1762
1763 =item B<-->
1764
1765 Force end of options
1766
1767 =item B<-uPackname>
1768
1769 Force apparently unused subs from package Packname to be compiled.
1770 This allows programs to use eval "foo()" even when sub foo is never
1771 seen to be used at compile time. The down side is that any subs which
1772 really are never used also have code generated. This option is
1773 necessary, for example, if you have a signal handler foo which you
1774 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1775 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1776 options. The compiler tries to figure out which packages may possibly
1777 have subs in which need compiling but the current version doesn't do
1778 it very well. In particular, it is confused by nested packages (i.e.
1779 of the form C<A::B>) where package C<A> does not contain any subs.
1780
1781 =item B<-mModulename>
1782
1783 Instead of generating source for a runnable executable, generate
1784 source for an XSUB module. The boot_Modulename function (which
1785 DynaLoader can look for) does the appropriate initialisation and runs
1786 the main part of the Perl source that is being compiled.
1787
1788
1789 =item B<-D>
1790
1791 Debug options (concatenated or separate flags like C<perl -D>).
1792
1793 =item B<-Dr>
1794
1795 Writes debugging output to STDERR just as it's about to write to the
1796 program's runtime (otherwise writes debugging info as comments in
1797 its C output).
1798
1799 =item B<-DO>
1800
1801 Outputs each OP as it's compiled
1802
1803 =item B<-Ds>
1804
1805 Outputs the contents of the shadow stack at each OP
1806
1807 =item B<-Dp>
1808
1809 Outputs the contents of the shadow pad of lexicals as it's loaded for
1810 each sub or the main program.
1811
1812 =item B<-Dq>
1813
1814 Outputs the name of each fake PP function in the queue as it's about
1815 to process it.
1816
1817 =item B<-Dl>
1818
1819 Output the filename and line number of each original line of Perl
1820 code as it's processed (C<pp_nextstate>).
1821
1822 =item B<-Dt>
1823
1824 Outputs timing information of compilation stages.
1825
1826 =item B<-f>
1827
1828 Force optimisations on or off one at a time.
1829
1830 =item B<-ffreetmps-each-bblock>
1831
1832 Delays FREETMPS from the end of each statement to the end of the each
1833 basic block.
1834
1835 =item B<-ffreetmps-each-loop>
1836
1837 Delays FREETMPS from the end of each statement to the end of the group
1838 of basic blocks forming a loop. At most one of the freetmps-each-*
1839 options can be used.
1840
1841 =item B<-fomit-taint>
1842
1843 Omits generating code for handling perl's tainting mechanism.
1844
1845 =item B<-On>
1846
1847 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1848 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1849 sets 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
1858 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1859 library directory. The utility called C<perlcc> may also be used to
1860 help 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
1867 Plenty. Current status: experimental.
1868
1869 =head1 DIFFERENCES
1870
1871 These aren't really bugs but they are constructs which are heavily
1872 tied to perl's compile-and-go implementation and with which this
1873 compiler backend cannot cope.
1874
1875 =head2 Loops
1876
1877 Standard perl calculates the target of "next", "last", and "redo"
1878 at run-time. The compiler calculates the targets at compile-time.
1879 For 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
1887 produces the output
1888
1889     024
1890
1891 with standard perl but gives a compile-time error with the compiler.
1892
1893 =head2 Context of ".."
1894
1895 The context (scalar or array) of the ".." operator determines whether
1896 it behaves as a range or a flip/flop. Standard perl delays until
1897 runtime the decision of which context it is in but the compiler needs
1898 to 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
1905 generates the output
1906
1907     456123E0
1908
1909 with standard Perl but gives a compile-time error with compiled Perl.
1910
1911 =head2 Arithmetic
1912
1913 Compiled Perl programs use native C arithemtic much more frequently
1914 than standard perl. Operations on large numbers or on boundary
1915 cases may produce different behaviour.
1916
1917 =head2 Deprecated features
1918
1919 Features of standard perl such as C<$[> which have been deprecated
1920 in standard perl since Perl5 was released have not been implemented
1921 in the compiler.
1922
1923 =head1 AUTHOR
1924
1925 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1926
1927 =cut