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