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