home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _3d72ea552da133915db0d9b8cc5bb3d5 < prev    next >
Text File  |  2000-03-15  |  58KB  |  2,003 lines
  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("djSP;");
  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
  2003.