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