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