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