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