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