3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
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.
10 use B qw(main_start main_root class comppadlist peekop svref_2object
11 timing_info init_av sv_undef
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
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);
22 # These should probably be elsewhere
23 # Flags for $op->flags
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
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
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
57 foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
63 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
64 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
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));
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
80 my $declare_ref; # Hash ref keyed by C variable type of declarations.
82 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
83 # tuples to be written out.
87 sub init_hash { map { $_ => 1 } @_ }
90 # Initialise the hashes for the default PP functions where we can avoid
91 # either write_back_stack, write_back_lexicals or invalidate_lexicals.
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 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile pp_entertry pp_enterloop pp_enteriter );
101 runtime(map { chomp; "/* $_ */"} @_);
106 my ($type, $var) = @_;
107 push(@{$declare_ref->{$type}}, $var);
111 push(@$runtime_list_ref, @_);
112 warn join("\n", @_) . "\n" if $debug_runtime;
116 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
121 print qq(#include "cc_runtime.h"\n);
122 foreach $ppdata (@pp_list) {
123 my ($name, $runtime, $declare) = @$ppdata;
124 print "\nstatic\nPP($name)\n{\n";
125 my ($type, $varlist, $line);
126 while (($type, $varlist) = each %$declare) {
127 print "\t$type ", join(", ", @$varlist), ";\n";
129 foreach $line (@$runtime) {
139 push_runtime("\t$line");
145 $runtime_list_ref = [];
148 declare("I32", "oldsave");
149 declare("SV", "**svp");
150 map { declare("SV", "*$_") } qw(sv src dst left right);
151 declare("MAGIC", "*mg");
152 $decl->add("static OP * $ppname _((ARGSproto));");
153 debug "init_pp: $ppname\n" if $debug_queue;
156 # Initialise runtime_callback function for Stackobj class
157 BEGIN { B::Stackobj::set_callback(\&runtime) }
159 # Initialise saveoptree_callback for B::C class
161 my ($name, $root, $start, @pl) = @_;
162 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
164 if ($name eq "*ignore*") {
167 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
169 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
170 $start = $fakeop->save;
171 debug "cc_queue: name $name returns $start\n" if $debug_queue;
174 BEGIN { B::C::set_callback(\&cc_queue) }
176 sub valid_int { $_[0]->{flags} & VALID_INT }
177 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
178 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
179 sub valid_sv { $_[0]->{flags} & VALID_SV }
181 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
182 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
183 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
184 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
185 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
187 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
188 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
189 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
190 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
193 return ((pop @stack)->as_bool);
195 # Careful: POPs has an auto-decrement and SvTRUE evaluates
196 # its argument more than once.
197 runtime("sv = POPs;");
202 sub write_back_lexicals {
203 my $avoid = shift || 0;
204 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
207 foreach $lex (@pad) {
208 next unless ref($lex);
209 $lex->write_back unless $lex->{flags} & $avoid;
213 sub write_back_stack {
215 return unless @stack;
216 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
217 foreach $obj (@stack) {
218 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
223 sub invalidate_lexicals {
224 my $avoid = shift || 0;
225 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
228 foreach $lex (@pad) {
229 next unless ref($lex);
230 $lex->invalidate unless $lex->{flags} & $avoid;
234 sub reload_lexicals {
236 foreach $lex (@pad) {
237 next unless ref($lex);
238 my $type = $lex->{type};
239 if ($type == T_INT) {
241 } elsif ($type == T_DOUBLE) {
250 package B::Pseudoreg;
252 # This class allocates pseudo-registers (OK, so they're C variables).
254 my %alloc; # Keyed by variable name. A value of 1 means the
255 # variable has been declared. A value of 2 means
258 sub new_scope { %alloc = () }
261 my ($class, $type, $prefix) = @_;
262 my ($ptr, $i, $varname, $status, $obj);
263 $prefix =~ s/^(\**)//;
267 $varname = "$prefix$i";
268 $status = $alloc{$varname};
269 } while $status == 2;
272 B::CC::declare($type, "$ptr$varname");
273 $alloc{$varname} = 2; # declared and in use
275 $obj = bless \$varname, $class;
280 $alloc{$$obj} = 1; # no longer in use but still declared
286 # This class gives a standard API for a perl object to shadow a
287 # C variable and only generate reloads/write-backs when necessary.
289 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
290 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
291 # Use $obj->invalidate whenever an unknown function may have
295 my ($class, $write_back) = @_;
296 # Object fields are perl shadow variable, validity flag
297 # (for *C* variable) and callback sub for write_back
298 # (passed perl shadow variable as argument).
299 bless [undef, 1, $write_back], $class;
302 my ($obj, $newval) = @_;
303 $obj->[1] = 0; # C variable no longer valid
309 $obj->[1] = 1; # C variable will now be valid
310 &{$obj->[2]}($obj->[0]);
313 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
315 my $curcop = new B::Shadow (sub {
316 my $opsym = shift->save;
317 runtime("PL_curcop = (COP*)$opsym;");
321 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
324 my $cxix = $#cxstack;
325 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
328 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
334 my $cxix = $#cxstack;
336 ($cxstack[$cxix]->{type} != CXt_LOOP ||
337 $cxstack[$cxix]->{label} ne $label)) {
340 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
346 my $file = $curcop->[0]->filegv->SV->PV;
347 my $line = $curcop->[0]->line;
350 warn sprintf("%s:%d: $format\n", $file, $line, @_);
352 warn sprintf("%s:%d: %s\n", $file, $line, $format);
357 # Load pad takes (the elements of) a PADLIST as arguments and loads
358 # up @pad with Stackobj-derived objects which represent those lexicals.
359 # If/when perl itself can generate type information (my int $foo) then
360 # we'll take advantage of that here. Until then, we'll use various hacks
361 # to tell the compiler when we want a lexical to be a particular type
362 # or to be a register.
365 my ($namelistav, $valuelistav) = @_;
367 my @namelist = $namelistav->ARRAY;
368 my @valuelist = $valuelistav->ARRAY;
371 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
372 # Temporary lexicals don't get named so it's possible for @valuelist
373 # to be strictly longer than @namelist. We count $ix up to the end of
374 # @valuelist but index into @namelist for the name. Any temporaries which
375 # run off the end of @namelist will make $namesv undefined and we treat
376 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
377 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
378 for ($ix = 1; $ix < @valuelist; $ix++) {
379 my $namesv = $namelist[$ix];
380 my $type = T_UNKNOWN;
383 my $class = class($namesv);
384 if (!defined($namesv) || $class eq "SPECIAL") {
385 # temporaries have &PL_sv_undef instead of a PVNV for a name
386 $flags = VALID_SV|TEMPORARY|REGISTER;
388 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
392 $flags = VALID_SV|VALID_INT;
393 } elsif ($2 eq "d") {
395 $flags = VALID_SV|VALID_DOUBLE;
397 $flags |= REGISTER if $3;
400 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
401 "i_$name", "d_$name");
402 declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
403 declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
404 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
411 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
419 # XXX Preserve original label name for "real" labels?
420 return sprintf("lab_%x", $$op);
425 push_runtime(sprintf(" %s:", label($op)));
430 my $opsym = $op->save;
431 runtime("PL_op = $opsym;") unless $know_op;
437 my $ppname = $op->ppaddr;
438 my $sym = loadop($op);
439 runtime("DOOP($ppname);");
446 my $flags = $op->flags;
447 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
451 # Code generation for PP code
461 my $gimme = gimme($op);
462 if ($gimme != G_ARRAY) {
463 my $obj= new B::Stackobj::Const(sv_undef);
465 # XXX Change to push a constant sv_undef Stackobj onto @stack
467 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
475 runtime("PP_UNSTACK;");
481 my $next = $op->next;
483 unshift(@bblock_todo, $next);
485 my $bool = pop_bool();
487 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
489 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
497 my $next = $op->next;
499 unshift(@bblock_todo, $next);
501 my $bool = pop_bool @stack;
503 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
504 $bool, label($next)));
506 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
514 my $false = $op->false;
515 unshift(@bblock_todo, $false);
517 my $bool = pop_bool();
519 runtime(sprintf("if (!$bool) goto %s;", label($false)));
526 push(@stack, $pad[$ix]);
527 if ($op->flags & OPf_MOD) {
528 my $private = $op->private;
529 if ($private & OPpLVAL_INTRO) {
530 runtime("SAVECLEARSV(PL_curpad[$ix]);");
531 } elsif ($private & OPpDEREF) {
532 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
533 $ix, $private & OPpDEREF));
534 $pad[$ix]->invalidate;
543 my $obj = $constobj{$$sv};
544 if (!defined($obj)) {
545 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
555 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
556 runtime("TAINT_NOT;") unless $omit_taint;
557 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
558 if ($freetmps_each_bblock || $freetmps_each_loop) {
561 runtime("FREETMPS;");
568 $curcop->invalidate; # XXX?
569 return default_pp($op);
572 #default_pp will handle this:
573 #sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
574 #sub pp_bless { $curcop->write_back; default_pp(@_) }
575 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
576 # The following subs need $curcop->write_back if we decide to support arybase:
577 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
578 #sub pp_sort { $curcop->write_back; default_pp(@_) }
579 #sub pp_caller { $curcop->write_back; default_pp(@_) }
580 #sub pp_reset { $curcop->write_back; default_pp(@_) }
584 my $gvsym = $op->gv->save;
586 runtime("XPUSHs((SV*)$gvsym);");
592 my $gvsym = $op->gv->save;
594 if ($op->private & OPpLVAL_INTRO) {
595 runtime("XPUSHs(save_scalar($gvsym));");
597 runtime("XPUSHs(GvSV($gvsym));");
604 my $gvsym = $op->gv->save;
605 my $ix = $op->private;
606 my $flag = $op->flags & OPf_MOD;
608 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
609 "PUSHs(svp ? *svp : &PL_sv_undef);");
614 my ($op, $operator) = @_;
615 if ($op->flags & OPf_STACKED) {
616 my $right = pop_int();
618 my $left = top_int();
619 $stack[-1]->set_int(&$operator($left, $right));
621 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
624 my $targ = $pad[$op->targ];
625 my $right = new B::Pseudoreg ("IV", "riv");
626 my $left = new B::Pseudoreg ("IV", "liv");
627 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
628 $targ->set_int(&$operator($$left, $$right));
634 sub INTS_CLOSED () { 0x1 }
635 sub INT_RESULT () { 0x2 }
636 sub NUMERIC_RESULT () { 0x4 }
639 my ($op, $operator, $flags) = @_;
641 $force_int ||= ($flags & INT_RESULT);
642 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
643 && valid_int($stack[-2]) && valid_int($stack[-1]));
644 if ($op->flags & OPf_STACKED) {
645 my $right = pop_numeric();
647 my $left = top_numeric();
649 $stack[-1]->set_int(&$operator($left, $right));
651 $stack[-1]->set_numeric(&$operator($left, $right));
655 my $rightruntime = new B::Pseudoreg ("IV", "riv");
656 runtime(sprintf("$$rightruntime = %s;",$right));
657 runtime(sprintf("sv_setiv(TOPs, %s);",
658 &$operator("TOPi", $$rightruntime)));
660 my $rightruntime = new B::Pseudoreg ("double", "rnv");
661 runtime(sprintf("$$rightruntime = %s;",$right));
662 runtime(sprintf("sv_setnv(TOPs, %s);",
663 &$operator("TOPn",$$rightruntime)));
667 my $targ = $pad[$op->targ];
668 $force_int ||= ($targ->{type} == T_INT);
670 my $right = new B::Pseudoreg ("IV", "riv");
671 my $left = new B::Pseudoreg ("IV", "liv");
672 runtime(sprintf("$$right = %s; $$left = %s;",
673 pop_numeric(), pop_numeric));
674 $targ->set_int(&$operator($$left, $$right));
676 my $right = new B::Pseudoreg ("double", "rnv");
677 my $left = new B::Pseudoreg ("double", "lnv");
678 runtime(sprintf("$$right = %s; $$left = %s;",
679 pop_numeric(), pop_numeric));
680 $targ->set_numeric(&$operator($$left, $$right));
688 my ($op, $operator, $flags) = @_;
689 if ($op->flags & OPf_STACKED) {
690 my $right = pop_sv();
693 if ($flags & INT_RESULT) {
694 $stack[-1]->set_int(&$operator($left, $right));
695 } elsif ($flags & NUMERIC_RESULT) {
696 $stack[-1]->set_numeric(&$operator($left, $right));
698 # XXX Does this work?
699 runtime(sprintf("sv_setsv($left, %s);",
700 &$operator($left, $right)));
701 $stack[-1]->invalidate;
705 if ($flags & INT_RESULT) {
707 } elsif ($flags & NUMERIC_RESULT) {
712 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
715 my $targ = $pad[$op->targ];
716 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
717 if ($flags & INT_RESULT) {
718 $targ->set_int(&$operator("left", "right"));
719 } elsif ($flags & NUMERIC_RESULT) {
720 $targ->set_numeric(&$operator("left", "right"));
722 # XXX Does this work?
723 runtime(sprintf("sv_setsv(%s, %s);",
724 $targ->as_sv, &$operator("left", "right")));
733 my ($op, $operator) = @_;
734 my $right = new B::Pseudoreg ("IV", "riv");
735 my $left = new B::Pseudoreg ("IV", "liv");
736 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
737 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
738 $bool->set_int(&$operator($$left, $$right));
743 sub bool_numeric_binop {
744 my ($op, $operator) = @_;
745 my $right = new B::Pseudoreg ("double", "rnv");
746 my $left = new B::Pseudoreg ("double", "lnv");
747 runtime(sprintf("$$right = %s; $$left = %s;",
748 pop_numeric(), pop_numeric()));
749 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
750 $bool->set_numeric(&$operator($$left, $$right));
756 my ($op, $operator) = @_;
757 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
758 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
759 $bool->set_numeric(&$operator("left", "right"));
766 return sub { "$_[0] $opname $_[1]" }
771 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
775 my $plus_op = infix_op("+");
776 my $minus_op = infix_op("-");
777 my $multiply_op = infix_op("*");
778 my $divide_op = infix_op("/");
779 my $modulo_op = infix_op("%");
780 my $lshift_op = infix_op("<<");
781 my $rshift_op = infix_op(">>");
782 my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
783 my $scmp_op = prefix_op("sv_cmp");
784 my $seq_op = prefix_op("sv_eq");
785 my $sne_op = prefix_op("!sv_eq");
786 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
787 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
788 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
789 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
790 my $eq_op = infix_op("==");
791 my $ne_op = infix_op("!=");
792 my $lt_op = infix_op("<");
793 my $gt_op = infix_op(">");
794 my $le_op = infix_op("<=");
795 my $ge_op = infix_op(">=");
798 # XXX The standard perl PP code has extra handling for
799 # some special case arguments of these operators.
801 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
802 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
803 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
804 sub pp_divide { numeric_binop($_[0], $divide_op) }
805 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
806 sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
808 sub pp_left_shift { int_binop($_[0], $lshift_op) }
809 sub pp_right_shift { int_binop($_[0], $rshift_op) }
810 sub pp_i_add { int_binop($_[0], $plus_op) }
811 sub pp_i_subtract { int_binop($_[0], $minus_op) }
812 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
813 sub pp_i_divide { int_binop($_[0], $divide_op) }
814 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
816 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
817 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
818 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
819 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
820 sub pp_le { bool_numeric_binop($_[0], $le_op) }
821 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
823 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
824 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
825 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
826 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
827 sub pp_i_le { bool_int_binop($_[0], $le_op) }
828 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
830 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
831 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
832 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
833 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
834 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
835 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
836 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
842 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
847 ($src, $dst) = ($dst, $src) if $backwards;
848 my $type = $src->{type};
849 if ($type == T_INT) {
850 $dst->set_int($src->as_int);
851 } elsif ($type == T_DOUBLE) {
852 $dst->set_numeric($src->as_numeric);
854 $dst->set_sv($src->as_sv);
857 } elsif (@stack == 1) {
859 my $src = pop @stack;
860 my $type = $src->{type};
861 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
862 if ($type == T_INT) {
863 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
864 } elsif ($type == T_DOUBLE) {
865 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
867 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
869 runtime("SvSETMAGIC(TOPs);");
871 my $dst = $stack[-1];
872 my $type = $dst->{type};
873 runtime("sv = POPs;");
874 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
875 if ($type == T_INT) {
876 $dst->set_int("SvIV(sv)");
877 } elsif ($type == T_DOUBLE) {
878 $dst->set_double("SvNV(sv)");
880 runtime("SvSetMagicSV($dst->{sv}, sv);");
886 runtime("src = POPs; dst = TOPs;");
888 runtime("dst = POPs; src = TOPs;");
890 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
891 "SvSetSV(dst, src);",
901 my $obj = $stack[-1];
902 my $type = $obj->{type};
903 if ($type == T_INT || $type == T_DOUBLE) {
904 $obj->set_int($obj->as_int . " + 1");
906 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
910 runtime sprintf("PP_PREINC(TOPs);");
918 runtime("PUSHMARK(sp);");
925 my $gimme = gimme($op);
926 if ($gimme == G_ARRAY) { # sic
927 runtime("POPMARK;"); # need this even though not a "full" pp_list
929 runtime("PP_LIST($gimme);");
936 write_back_lexicals(REGISTER|TEMPORARY);
939 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
940 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
941 runtime("SPAGAIN;}");
943 invalidate_lexicals(REGISTER|TEMPORARY);
948 my $ppname = $op->ppaddr;
949 write_back_lexicals() unless $skip_lexicals{$ppname};
950 write_back_stack() unless $skip_stack{$ppname};
952 # See comment in pp_grepwhile to see why!
953 $init->add("((LISTOP*)$sym)->op_first = $sym;");
954 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
955 runtime( sprintf("goto %s;",label($op->first)));
963 my $ppname = $op->ppaddr;
964 write_back_lexicals() unless $skip_lexicals{$ppname};
965 write_back_stack() unless $skip_stack{$ppname};
967 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
968 invalidate_lexicals() unless $skip_invalidate{$ppname};
978 write_back_lexicals(REGISTER|TEMPORARY);
981 # XXX Is this the right way to distinguish between it returning
982 # CvSTART(cv) (via doform) and pop_return()?
983 runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
986 invalidate_lexicals(REGISTER|TEMPORARY);
993 write_back_lexicals(REGISTER|TEMPORARY);
995 my $sym = loadop($op);
996 my $ppaddr = $op->ppaddr;
997 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
999 invalidate_lexicals(REGISTER|TEMPORARY);
1003 sub pp_entereval { doeval(@_) }
1004 sub pp_require { doeval(@_) }
1005 sub pp_dofile { doeval(@_) }
1009 $curcop->write_back;
1010 write_back_lexicals(REGISTER|TEMPORARY);
1012 my $sym = doop($op);
1013 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1014 declare("JMPENV", $jmpbuf);
1015 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1016 invalidate_lexicals(REGISTER|TEMPORARY);
1023 runtime("PP_LEAVETRY;");
1029 if ($need_freetmps && $freetmps_each_loop) {
1030 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1037 my $nexttonext=$next->next;
1039 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1040 label($nexttonext)));
1041 return $op->next->other;
1046 if ($need_freetmps && $freetmps_each_loop) {
1047 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1051 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1052 # we need to be able to distinguish the two at runtime.
1056 my $nexttonext=$next->next;
1058 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1059 label($nexttonext)));
1060 return $op->next->other;
1065 my $next = $op->next;
1066 unshift(@bblock_todo, $next);
1067 write_back_lexicals();
1069 my $sym = doop($op);
1070 # pp_grepwhile can return either op_next or op_other and we need to
1071 # be able to distinguish the two at runtime. Since it's possible for
1072 # both ops to be "inlined", the fields could both be zero. To get
1073 # around that, we hack op_next to be our own op (purely because we
1074 # know it's a non-NULL pointer and can't be the same as op_other).
1075 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1076 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1087 write_back_lexicals(REGISTER|TEMPORARY);
1090 runtime("PUTBACK;", "return PL_op;");
1097 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1098 return default_pp($op);
1103 my $flags = $op->flags;
1104 if (!($flags & OPf_WANT)) {
1105 error("context of range unknown at compile-time");
1107 write_back_lexicals();
1109 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
1110 # We need to save our UNOP structure since pp_flop uses
1111 # it to find and adjust out targ. We don't need it ourselves.
1113 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1114 $op->targ, label($op->false));
1115 unshift(@bblock_todo, $op->false);
1122 my $flags = $op->flags;
1123 if (!($flags & OPf_WANT)) {
1124 error("context of flip unknown at compile-time");
1126 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1127 return $op->first->false;
1129 write_back_lexicals();
1131 # We need to save our UNOP structure since pp_flop uses
1132 # it to find and adjust out targ. We don't need it ourselves.
1135 my $rangeix = $op->first->targ;
1136 runtime(($op->private & OPpFLIP_LINENUM) ?
1137 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1138 : "if (SvTRUE(TOPs)) {");
1139 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1140 if ($op->flags & OPf_SPECIAL) {
1141 runtime("sv_setiv(PL_curpad[$ix], 1);");
1143 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1145 sprintf("\tgoto %s;", label($op->first->false)));
1148 qq{sv_setpv(PL_curpad[$ix], "");},
1149 "SETs(PL_curpad[$ix]);");
1163 my $nextop = $op->nextop;
1164 my $lastop = $op->lastop;
1165 my $redoop = $op->redoop;
1166 $curcop->write_back;
1167 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1171 "label" => $curcop->[0]->label,
1179 return default_pp($op);
1182 sub pp_enterloop { enterloop(@_) }
1183 sub pp_enteriter { enterloop(@_) }
1188 die "panic: leaveloop";
1190 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1192 return default_pp($op);
1198 if ($op->flags & OPf_SPECIAL) {
1199 $cxix = dopoptoloop();
1201 error('"next" used outside loop');
1202 return $op->next; # ignore the op
1205 $cxix = dopoptolabel($op->pv);
1207 error('Label not found at compile time for "next %s"', $op->pv);
1208 return $op->next; # ignore the op
1212 my $nextop = $cxstack[$cxix]->{nextop};
1213 push(@bblock_todo, $nextop);
1214 runtime(sprintf("goto %s;", label($nextop)));
1221 if ($op->flags & OPf_SPECIAL) {
1222 $cxix = dopoptoloop();
1224 error('"redo" used outside loop');
1225 return $op->next; # ignore the op
1228 $cxix = dopoptolabel($op->pv);
1230 error('Label not found at compile time for "redo %s"', $op->pv);
1231 return $op->next; # ignore the op
1235 my $redoop = $cxstack[$cxix]->{redoop};
1236 push(@bblock_todo, $redoop);
1237 runtime(sprintf("goto %s;", label($redoop)));
1244 if ($op->flags & OPf_SPECIAL) {
1245 $cxix = dopoptoloop();
1247 error('"last" used outside loop');
1248 return $op->next; # ignore the op
1251 $cxix = dopoptolabel($op->pv);
1253 error('Label not found at compile time for "last %s"', $op->pv);
1254 return $op->next; # ignore the op
1256 # XXX Add support for "last" to leave non-loop blocks
1257 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1258 error('Use of "last" for non-loop blocks is not yet implemented');
1259 return $op->next; # ignore the op
1263 my $lastop = $cxstack[$cxix]->{lastop}->next;
1264 push(@bblock_todo, $lastop);
1265 runtime(sprintf("goto %s;", label($lastop)));
1271 write_back_lexicals();
1273 my $sym = doop($op);
1274 my $replroot = $op->pmreplroot;
1276 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1277 $sym, label($replroot));
1278 $op->pmreplstart->save;
1279 push(@bblock_todo, $replroot);
1281 invalidate_lexicals();
1287 write_back_lexicals();
1290 my $pmop = $op->other;
1291 # warn sprintf("substcont: op = %s, pmop = %s\n",
1292 # peekop($op), peekop($pmop));#debug
1293 # my $pmopsym = objsym($pmop);
1294 my $pmopsym = $pmop->save; # XXX can this recurse?
1295 # warn "pmopsym = $pmopsym\n";#debug
1296 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1297 $pmopsym, label($pmop->pmreplstart));
1298 invalidate_lexicals();
1304 my $ppname = $op->ppaddr;
1305 if ($curcop and $need_curcop{$ppname}){
1306 $curcop->write_back;
1308 write_back_lexicals() unless $skip_lexicals{$ppname};
1309 write_back_stack() unless $skip_stack{$ppname};
1311 # XXX If the only way that ops can write to a TEMPORARY lexical is
1312 # when it's named in $op->targ then we could call
1313 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1314 # the temporaries. For now, we'll play it safe and write back the lot.
1315 invalidate_lexicals() unless $skip_invalidate{$ppname};
1321 my $ppname = $op->ppaddr;
1322 if (exists $ignore_op{$ppname}) {
1325 debug peek_stack() if $debug_stack;
1327 debug sprintf("%s [%s]\n",
1329 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1332 if (defined(&$ppname)) {
1334 return &$ppname($op);
1336 return default_pp($op);
1340 sub compile_bblock {
1342 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1346 $op = compile_op($op);
1347 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1348 write_back_stack(); # boo hoo: big loss
1354 my ($name, $root, $start, @padlist) = @_;
1358 B::Pseudoreg->new_scope;
1360 if ($debug_timings) {
1361 warn sprintf("Basic block analysis at %s\n", timing_info);
1363 $leaders = find_leaders($root, $start);
1364 @bblock_todo = ($start, values %$leaders);
1365 if ($debug_timings) {
1366 warn sprintf("Compilation at %s\n", timing_info);
1368 while (@bblock_todo) {
1369 $op = shift @bblock_todo;
1370 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1371 next if !defined($op) || !$$op || $done{$$op};
1372 #warn "...compiling it\n"; # debug
1375 $op = compile_bblock($op);
1376 if ($need_freetmps && $freetmps_each_bblock) {
1377 runtime("FREETMPS;");
1380 } while defined($op) && $$op && !$done{$$op};
1381 if ($need_freetmps && $freetmps_each_loop) {
1382 runtime("FREETMPS;");
1386 runtime("PUTBACK;","return PL_op;");
1387 } elsif ($done{$$op}) {
1388 runtime(sprintf("goto %s;", label($op)));
1391 if ($debug_timings) {
1392 warn sprintf("Saving runtime at %s\n", timing_info);
1400 $start = cc_queue(@_) if @_;
1401 while ($ccinfo = shift @cc_todo) {
1408 my ($name, $cvref) = @_;
1409 my $cv = svref_2object($cvref);
1410 my @padlist = $cv->PADLIST->ARRAY;
1411 my $curpad_sym = $padlist[1]->save;
1412 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1416 my @comppadlist = comppadlist->ARRAY;
1417 my $curpad_nam = $comppadlist[0]->save;
1418 my $curpad_sym = $comppadlist[1]->save;
1419 my $init_av = init_av->save;
1420 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1421 # Do save_unused_subs before saving inc_hv
1425 my $inc_hv = svref_2object(\%INC)->save;
1426 my $inc_av = svref_2object(\@INC)->save;
1428 if (!defined($module)) {
1429 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1430 "PL_main_start = $start;",
1431 "PL_curpad = AvARRAY($curpad_sym);",
1432 "PL_initav = $init_av;",
1433 "GvHV(PL_incgv) = $inc_hv;",
1434 "GvAV(PL_incgv) = $inc_av;",
1435 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1436 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1440 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
1441 output_boilerplate();
1443 output_all("perl_init");
1447 if (defined($module)) {
1448 my $cmodule = $module;
1449 $cmodule =~ s/::/__/g;
1459 SAVESPTR(PL_curpad);
1461 PL_curpad = AvARRAY($curpad_sym);
1471 if ($debug_timings) {
1472 warn sprintf("Done at %s\n", timing_info);
1478 my ($option, $opt, $arg);
1480 while ($option = shift @options) {
1481 if ($option =~ /^-(.)(.*)/) {
1485 unshift @options, $option;
1488 if ($opt eq "-" && $arg eq "-") {
1491 } elsif ($opt eq "o") {
1492 $arg ||= shift @options;
1493 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1494 } elsif ($opt eq "n") {
1495 $arg ||= shift @options;
1496 $module_name = $arg;
1497 } elsif ($opt eq "u") {
1498 $arg ||= shift @options;
1499 mark_unused($arg,undef);
1500 } elsif ($opt eq "f") {
1501 $arg ||= shift @options;
1502 my $value = $arg !~ s/^no-//;
1504 my $ref = $optimise{$arg};
1505 if (defined($ref)) {
1508 warn qq(ignoring unknown optimisation option "$arg"\n);
1510 } elsif ($opt eq "O") {
1511 $arg = 1 if $arg eq "";
1513 foreach $ref (values %optimise) {
1517 $freetmps_each_loop = 1;
1520 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1522 } elsif ($opt eq "m") {
1523 $arg ||= shift @options;
1525 mark_unused($arg,undef);
1526 } elsif ($opt eq "p") {
1527 $arg ||= shift @options;
1529 } elsif ($opt eq "D") {
1530 $arg ||= shift @options;
1531 foreach $arg (split(//, $arg)) {
1534 } elsif ($arg eq "O") {
1536 } elsif ($arg eq "s") {
1538 } elsif ($arg eq "c") {
1540 } elsif ($arg eq "p") {
1542 } elsif ($arg eq "r") {
1544 } elsif ($arg eq "S") {
1546 } elsif ($arg eq "q") {
1548 } elsif ($arg eq "l") {
1550 } elsif ($arg eq "t") {
1557 $init = B::Section->get("init");
1558 $decl = B::Section->get("decl");
1562 my ($objname, $ppname);
1563 foreach $objname (@options) {
1564 $objname = "main::$objname" unless $objname =~ /::/;
1565 ($ppname = $objname) =~ s/^.*?:://;
1566 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1567 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1570 output_boilerplate();
1572 output_all($module_name || "init_module");
1576 return sub { cc_main() };
1586 B::CC - Perl compiler's optimized C translation backend
1590 perl -MO=CC[,OPTIONS] foo.pl
1594 This compiler backend takes Perl source and generates C source code
1595 corresponding to the flow of your program. In other words, this
1596 backend is somewhat a "real" compiler in the sense that many people
1597 think about compilers. Note however that, currently, it is a very
1598 poor compiler in that although it generates (mostly, or at least
1599 sometimes) correct code, it performs relatively few optimisations.
1600 This will change as the compiler develops. The result is that
1601 running an executable compiled with this backend may start up more
1602 quickly than running the original Perl program (a feature shared
1603 by the B<C> compiler backend--see F<B::C>) and may also execute
1604 slightly faster. This is by no means a good optimising compiler--yet.
1608 If there are any non-option arguments, they are taken to be
1609 names of objects to be saved (probably doesn't work properly yet).
1610 Without extra arguments, it saves the main program.
1616 Output to filename instead of STDOUT
1620 Verbose compilation (currently gives a few compilation statistics).
1624 Force end of options
1628 Force apparently unused subs from package Packname to be compiled.
1629 This allows programs to use eval "foo()" even when sub foo is never
1630 seen to be used at compile time. The down side is that any subs which
1631 really are never used also have code generated. This option is
1632 necessary, for example, if you have a signal handler foo which you
1633 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1634 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1635 options. The compiler tries to figure out which packages may possibly
1636 have subs in which need compiling but the current version doesn't do
1637 it very well. In particular, it is confused by nested packages (i.e.
1638 of the form C<A::B>) where package C<A> does not contain any subs.
1640 =item B<-mModulename>
1642 Instead of generating source for a runnable executable, generate
1643 source for an XSUB module. The boot_Modulename function (which
1644 DynaLoader can look for) does the appropriate initialisation and runs
1645 the main part of the Perl source that is being compiled.
1650 Debug options (concatenated or separate flags like C<perl -D>).
1654 Writes debugging output to STDERR just as it's about to write to the
1655 program's runtime (otherwise writes debugging info as comments in
1660 Outputs each OP as it's compiled
1664 Outputs the contents of the shadow stack at each OP
1668 Outputs the contents of the shadow pad of lexicals as it's loaded for
1669 each sub or the main program.
1673 Outputs the name of each fake PP function in the queue as it's about
1678 Output the filename and line number of each original line of Perl
1679 code as it's processed (C<pp_nextstate>).
1683 Outputs timing information of compilation stages.
1687 Force optimisations on or off one at a time.
1689 =item B<-ffreetmps-each-bblock>
1691 Delays FREETMPS from the end of each statement to the end of the each
1694 =item B<-ffreetmps-each-loop>
1696 Delays FREETMPS from the end of each statement to the end of the group
1697 of basic blocks forming a loop. At most one of the freetmps-each-*
1698 options can be used.
1700 =item B<-fomit-taint>
1702 Omits generating code for handling perl's tainting mechanism.
1706 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1707 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1708 sets B<-ffreetmps-each-loop>.
1714 perl -MO=CC,-O2,-ofoo.c foo.pl
1715 perl cc_harness -o foo foo.c
1717 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1718 library directory. The utility called C<perlcc> may also be used to
1719 help make use of this compiler.
1721 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1722 perl cc_harness -shared -c -o Foo.so Foo.c
1726 Plenty. Current status: experimental.
1730 These aren't really bugs but they are constructs which are heavily
1731 tied to perl's compile-and-go implementation and with which this
1732 compiler backend cannot cope.
1736 Standard perl calculates the target of "next", "last", and "redo"
1737 at run-time. The compiler calculates the targets at compile-time.
1738 For example, the program
1740 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1741 NUMBER: for ($i = 0; $i < 5; $i++) {
1750 with standard perl but gives a compile-time error with the compiler.
1752 =head2 Context of ".."
1754 The context (scalar or array) of the ".." operator determines whether
1755 it behaves as a range or a flip/flop. Standard perl delays until
1756 runtime the decision of which context it is in but the compiler needs
1757 to know the context at compile-time. For example,
1760 sub range { (shift @a)..(shift @a) }
1762 while (@a) { print scalar(range()) }
1764 generates the output
1768 with standard Perl but gives a compile-time error with compiled Perl.
1772 Compiled Perl programs use native C arithemtic much more frequently
1773 than standard perl. Operations on large numbers or on boundary
1774 cases may produce different behaviour.
1776 =head2 Deprecated features
1778 Features of standard perl such as C<$[> which have been deprecated
1779 in standard perl since Perl5 was released have not been implemented
1784 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>