ext/B/B/CC.pm

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