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