ext/B/B/CC.pm

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