ext/B/B/CC.pm

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