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