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