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