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
12 use B::C qw(save_unused_subs objsym init_sections
13 output_all output_boilerplate output_main);
14 use B::Bblock qw(find_leaders);
15 use B::Stackobj qw(:types :flags);
17 # These should probably be elsewhere
18 # Flags for $op->flags
22 sub OPf_STACKED () { 64 }
23 sub OPf_SPECIAL () { 128 }
24 # op-specific flags for $op->private
25 sub OPpASSIGN_BACKWARDS () { 64 }
26 sub OPpLVAL_INTRO () { 128 }
27 sub OPpDEREF_AV () { 32 }
28 sub OPpDEREF_HV () { 64 }
29 sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV }
30 sub OPpFLIP_LINENUM () { 64 }
37 sub CXt_SUBST () { 4 }
38 sub CXt_BLOCK () { 5 }
40 my $module; # module name (when compiled with -m)
41 my %done; # hash keyed by $$op of leaders of basic blocks
42 # which have already been done.
43 my $leaders; # ref to hash of basic block leaders. Keys are $$op
44 # addresses, values are the $op objects themselves.
45 my @bblock_todo; # list of leaders of basic blocks that need visiting
47 my @cc_todo; # list of tuples defining what PP code needs to be
48 # saved (e.g. CV, main or PMOP repl code). Each tuple
49 # is [$name, $root, $start, @padlist]. PMOP repl code
50 # tuples inherit padlist.
51 my @stack; # shadows perl's stack when contents are known.
52 # Values are objects derived from class B::Stackobj
53 my @pad; # Lexicals in current pad as Stackobj-derived objects
54 my @padlist; # Copy of current padlist so PMOP repl code can find it
55 my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
56 my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
57 my %constobj; # OP_CONST constants as Stackobj-derived objects
59 my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
60 # block or even to the end of each loop of blocks,
61 # depending on optimisation options.
62 my $know_op = 0; # Set when C variable op already holds the right op
63 # (from an immediately preceding DOOP(ppname)).
64 my $errors = 0; # Number of errors encountered
65 my %skip_stack; # Hash of PP names which don't need write_back_stack
66 my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
67 my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
68 my %ignore_op; # Hash of ops which do nothing except returning op_next
71 foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
76 my @unused_sub_packages; # list of packages (given by -u options) to search
77 # explicitly and save every sub we find there, even
78 # if apparently unused (could be only referenced from
79 # an eval "" or from a $SIG{FOO} = "bar").
82 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
83 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
85 # Optimisation options. On the command line, use hyphens instead of
86 # underscores for compatibility with gcc-style options. We use
87 # underscores here because they are OK in (strict) barewords.
88 my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
89 my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
90 freetmps_each_loop => \$freetmps_each_loop,
91 omit_taint => \$omit_taint);
92 # perl patchlevel to generate code for (defaults to current patchlevel)
93 my $patchlevel = int(0.5 + 1000 * ($] - 5));
95 # Could rewrite push_runtime() and output_runtime() to use a
96 # temporary file if memory is at a premium.
97 my $ppname; # name of current fake PP function
99 my $declare_ref; # Hash ref keyed by C variable type of declarations.
101 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
102 # tuples to be written out.
106 sub init_hash { map { $_ => 1 } @_ }
109 # Initialise the hashes for the default PP functions where we can avoid
110 # either write_back_stack, write_back_lexicals or invalidate_lexicals.
112 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
113 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
116 if ($debug_runtime) {
119 runtime(map { chomp; "/* $_ */"} @_);
124 my ($type, $var) = @_;
125 push(@{$declare_ref->{$type}}, $var);
129 push(@$runtime_list_ref, @_);
130 warn join("\n", @_) . "\n" if $debug_runtime;
134 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
139 print qq(#include "cc_runtime.h"\n);
140 foreach $ppdata (@pp_list) {
141 my ($name, $runtime, $declare) = @$ppdata;
142 print "\nstatic\nPP($name)\n{\n";
143 my ($type, $varlist, $line);
144 while (($type, $varlist) = each %$declare) {
145 print "\t$type ", join(", ", @$varlist), ";\n";
147 foreach $line (@$runtime) {
157 push_runtime("\t$line");
163 $runtime_list_ref = [];
166 declare("I32", "oldsave");
167 declare("SV", "**svp");
168 map { declare("SV", "*$_") } qw(sv src dst left right);
169 declare("MAGIC", "*mg");
170 $decl->add("static OP * $ppname _((ARGSproto));");
171 debug "init_pp: $ppname\n" if $debug_queue;
174 # Initialise runtime_callback function for Stackobj class
175 BEGIN { B::Stackobj::set_callback(\&runtime) }
177 # Initialise saveoptree_callback for B::C class
179 my ($name, $root, $start, @pl) = @_;
180 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
182 if ($name eq "*ignore*") {
185 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
187 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
188 $start = $fakeop->save;
189 debug "cc_queue: name $name returns $start\n" if $debug_queue;
192 BEGIN { B::C::set_callback(\&cc_queue) }
194 sub valid_int { $_[0]->{flags} & VALID_INT }
195 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
196 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
197 sub valid_sv { $_[0]->{flags} & VALID_SV }
199 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
200 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
201 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
202 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
203 sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
205 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
206 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
207 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
208 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
211 return ((pop @stack)->as_numeric);
213 # Careful: POPs has an auto-decrement and SvTRUE evaluates
214 # its argument more than once.
215 runtime("sv = POPs;");
220 sub write_back_lexicals {
221 my $avoid = shift || 0;
222 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
225 foreach $lex (@pad) {
226 next unless ref($lex);
227 $lex->write_back unless $lex->{flags} & $avoid;
231 sub write_back_stack {
233 return unless @stack;
234 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
235 foreach $obj (@stack) {
236 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
241 sub invalidate_lexicals {
242 my $avoid = shift || 0;
243 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
246 foreach $lex (@pad) {
247 next unless ref($lex);
248 $lex->invalidate unless $lex->{flags} & $avoid;
252 sub reload_lexicals {
254 foreach $lex (@pad) {
255 next unless ref($lex);
256 my $type = $lex->{type};
257 if ($type == T_INT) {
259 } elsif ($type == T_DOUBLE) {
268 package B::Pseudoreg;
270 # This class allocates pseudo-registers (OK, so they're C variables).
272 my %alloc; # Keyed by variable name. A value of 1 means the
273 # variable has been declared. A value of 2 means
276 sub new_scope { %alloc = () }
279 my ($class, $type, $prefix) = @_;
280 my ($ptr, $i, $varname, $status, $obj);
281 $prefix =~ s/^(\**)//;
285 $varname = "$prefix$i";
286 $status = $alloc{$varname};
287 } while $status == 2;
290 B::CC::declare($type, "$ptr$varname");
291 $alloc{$varname} = 2; # declared and in use
293 $obj = bless \$varname, $class;
298 $alloc{$$obj} = 1; # no longer in use but still declared
304 # This class gives a standard API for a perl object to shadow a
305 # C variable and only generate reloads/write-backs when necessary.
307 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
308 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
309 # Use $obj->invalidate whenever an unknown function may have
313 my ($class, $write_back) = @_;
314 # Object fields are perl shadow variable, validity flag
315 # (for *C* variable) and callback sub for write_back
316 # (passed perl shadow variable as argument).
317 bless [undef, 1, $write_back], $class;
320 my ($obj, $newval) = @_;
321 $obj->[1] = 0; # C variable no longer valid
327 $obj->[1] = 1; # C variable will now be valid
328 &{$obj->[2]}($obj->[0]);
331 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
333 my $curcop = new B::Shadow (sub {
334 my $opsym = shift->save;
335 runtime("PL_curcop = (COP*)$opsym;");
339 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
342 my $cxix = $#cxstack;
343 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
346 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
352 my $cxix = $#cxstack;
353 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
354 && $cxstack[$cxix]->{label} ne $label) {
357 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
363 my $file = $curcop->[0]->filegv->SV->PV;
364 my $line = $curcop->[0]->line;
367 warn sprintf("%s:%d: $format\n", $file, $line, @_);
369 warn sprintf("%s:%d: %s\n", $file, $line, $format);
374 # Load pad takes (the elements of) a PADLIST as arguments and loads
375 # up @pad with Stackobj-derived objects which represent those lexicals.
376 # If/when perl itself can generate type information (my int $foo) then
377 # we'll take advantage of that here. Until then, we'll use various hacks
378 # to tell the compiler when we want a lexical to be a particular type
379 # or to be a register.
382 my ($namelistav, $valuelistav) = @_;
384 my @namelist = $namelistav->ARRAY;
385 my @valuelist = $valuelistav->ARRAY;
388 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
389 # Temporary lexicals don't get named so it's possible for @valuelist
390 # to be strictly longer than @namelist. We count $ix up to the end of
391 # @valuelist but index into @namelist for the name. Any temporaries which
392 # run off the end of @namelist will make $namesv undefined and we treat
393 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
394 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
395 for ($ix = 1; $ix < @valuelist; $ix++) {
396 my $namesv = $namelist[$ix];
397 my $type = T_UNKNOWN;
400 my $class = class($namesv);
401 if (!defined($namesv) || $class eq "SPECIAL") {
402 # temporaries have &PL_sv_undef instead of a PVNV for a name
403 $flags = VALID_SV|TEMPORARY|REGISTER;
405 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
409 $flags = VALID_SV|VALID_INT;
410 } elsif ($2 eq "d") {
412 $flags = VALID_SV|VALID_DOUBLE;
414 $flags |= REGISTER if $3;
417 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
418 "i_$name", "d_$name");
419 declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
420 declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
421 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
428 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
436 # XXX Preserve original label name for "real" labels?
437 return sprintf("lab_%x", $$op);
442 push_runtime(sprintf(" %s:", label($op)));
447 my $opsym = $op->save;
448 runtime("PL_op = $opsym;") unless $know_op;
454 my $ppname = $op->ppaddr;
455 my $sym = loadop($op);
456 runtime("DOOP($ppname);");
463 my $flags = $op->flags;
464 return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
468 # Code generation for PP code
478 my $gimme = gimme($op);
480 # XXX Change to push a constant sv_undef Stackobj onto @stack
482 runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
490 runtime("PP_UNSTACK;");
496 my $next = $op->next;
498 unshift(@bblock_todo, $next);
500 my $bool = pop_bool();
502 runtime(sprintf("if (!$bool) goto %s;", label($next)));
504 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
512 my $next = $op->next;
514 unshift(@bblock_todo, $next);
516 my $obj = pop @stack;
518 runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
519 $obj->as_numeric, $obj->as_sv, label($next)));
521 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
529 my $false = $op->false;
530 unshift(@bblock_todo, $false);
532 my $bool = pop_bool();
534 runtime(sprintf("if (!$bool) goto %s;", label($false)));
541 push(@stack, $pad[$ix]);
542 if ($op->flags & OPf_MOD) {
543 my $private = $op->private;
544 if ($private & OPpLVAL_INTRO) {
545 runtime("SAVECLEARSV(PL_curpad[$ix]);");
546 } elsif ($private & OPpDEREF) {
547 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
548 $ix, $private & OPpDEREF));
549 $pad[$ix]->invalidate;
558 my $obj = $constobj{$$sv};
559 if (!defined($obj)) {
560 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
570 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
571 runtime("TAINT_NOT;") unless $omit_taint;
572 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
573 if ($freetmps_each_bblock || $freetmps_each_loop) {
576 runtime("FREETMPS;");
583 $curcop->invalidate; # XXX?
584 return default_pp($op);
587 sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
588 sub pp_bless { $curcop->write_back; default_pp(@_) }
589 sub pp_repeat { $curcop->write_back; default_pp(@_) }
590 # The following subs need $curcop->write_back if we decide to support arybase:
591 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
592 sub pp_sort { $curcop->write_back; default_pp(@_) }
593 sub pp_caller { $curcop->write_back; default_pp(@_) }
594 sub pp_reset { $curcop->write_back; default_pp(@_) }
598 my $gvsym = $op->gv->save;
600 runtime("XPUSHs((SV*)$gvsym);");
606 my $gvsym = $op->gv->save;
608 if ($op->private & OPpLVAL_INTRO) {
609 runtime("XPUSHs(save_scalar($gvsym));");
611 runtime("XPUSHs(GvSV($gvsym));");
618 my $gvsym = $op->gv->save;
619 my $ix = $op->private;
620 my $flag = $op->flags & OPf_MOD;
622 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
623 "PUSHs(svp ? *svp : &PL_sv_undef);");
628 my ($op, $operator) = @_;
629 if ($op->flags & OPf_STACKED) {
630 my $right = pop_int();
632 my $left = top_int();
633 $stack[-1]->set_int(&$operator($left, $right));
635 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
638 my $targ = $pad[$op->targ];
639 my $right = new B::Pseudoreg ("IV", "riv");
640 my $left = new B::Pseudoreg ("IV", "liv");
641 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
642 $targ->set_int(&$operator($$left, $$right));
648 sub INTS_CLOSED () { 0x1 }
649 sub INT_RESULT () { 0x2 }
650 sub NUMERIC_RESULT () { 0x4 }
653 my ($op, $operator, $flags) = @_;
655 $force_int ||= ($flags & INT_RESULT);
656 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
657 && valid_int($stack[-2]) && valid_int($stack[-1]));
658 if ($op->flags & OPf_STACKED) {
659 my $right = pop_numeric();
661 my $left = top_numeric();
663 $stack[-1]->set_int(&$operator($left, $right));
665 $stack[-1]->set_numeric(&$operator($left, $right));
669 runtime(sprintf("sv_setiv(TOPs, %s);",
670 &$operator("TOPi", $right)));
672 runtime(sprintf("sv_setnv(TOPs, %s);",
673 &$operator("TOPn", $right)));
677 my $targ = $pad[$op->targ];
678 $force_int ||= ($targ->{type} == T_INT);
680 my $right = new B::Pseudoreg ("IV", "riv");
681 my $left = new B::Pseudoreg ("IV", "liv");
682 runtime(sprintf("$$right = %s; $$left = %s;",
683 pop_numeric(), pop_numeric));
684 $targ->set_int(&$operator($$left, $$right));
686 my $right = new B::Pseudoreg ("double", "rnv");
687 my $left = new B::Pseudoreg ("double", "lnv");
688 runtime(sprintf("$$right = %s; $$left = %s;",
689 pop_numeric(), pop_numeric));
690 $targ->set_numeric(&$operator($$left, $$right));
698 my ($op, $operator, $flags) = @_;
699 if ($op->flags & OPf_STACKED) {
700 my $right = pop_sv();
703 if ($flags & INT_RESULT) {
704 $stack[-1]->set_int(&$operator($left, $right));
705 } elsif ($flags & NUMERIC_RESULT) {
706 $stack[-1]->set_numeric(&$operator($left, $right));
708 # XXX Does this work?
709 runtime(sprintf("sv_setsv($left, %s);",
710 &$operator($left, $right)));
711 $stack[-1]->invalidate;
715 if ($flags & INT_RESULT) {
717 } elsif ($flags & NUMERIC_RESULT) {
722 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
725 my $targ = $pad[$op->targ];
726 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
727 if ($flags & INT_RESULT) {
728 $targ->set_int(&$operator("left", "right"));
729 } elsif ($flags & NUMERIC_RESULT) {
730 $targ->set_numeric(&$operator("left", "right"));
732 # XXX Does this work?
733 runtime(sprintf("sv_setsv(%s, %s);",
734 $targ->as_sv, &$operator("left", "right")));
743 my ($op, $operator) = @_;
744 my $right = new B::Pseudoreg ("IV", "riv");
745 my $left = new B::Pseudoreg ("IV", "liv");
746 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
747 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
748 $bool->set_int(&$operator($$left, $$right));
753 sub bool_numeric_binop {
754 my ($op, $operator) = @_;
755 my $right = new B::Pseudoreg ("double", "rnv");
756 my $left = new B::Pseudoreg ("double", "lnv");
757 runtime(sprintf("$$right = %s; $$left = %s;",
758 pop_numeric(), pop_numeric()));
759 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
760 $bool->set_numeric(&$operator($$left, $$right));
766 my ($op, $operator) = @_;
767 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
768 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
769 $bool->set_numeric(&$operator("left", "right"));
776 return sub { "$_[0] $opname $_[1]" }
781 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
785 my $plus_op = infix_op("+");
786 my $minus_op = infix_op("-");
787 my $multiply_op = infix_op("*");
788 my $divide_op = infix_op("/");
789 my $modulo_op = infix_op("%");
790 my $lshift_op = infix_op("<<");
791 my $rshift_op = infix_op(">>");
792 my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
793 my $scmp_op = prefix_op("sv_cmp");
794 my $seq_op = prefix_op("sv_eq");
795 my $sne_op = prefix_op("!sv_eq");
796 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
797 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
798 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
799 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
800 my $eq_op = infix_op("==");
801 my $ne_op = infix_op("!=");
802 my $lt_op = infix_op("<");
803 my $gt_op = infix_op(">");
804 my $le_op = infix_op("<=");
805 my $ge_op = infix_op(">=");
808 # XXX The standard perl PP code has extra handling for
809 # some special case arguments of these operators.
811 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
812 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
813 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
814 sub pp_divide { numeric_binop($_[0], $divide_op) }
815 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
816 sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
818 sub pp_left_shift { int_binop($_[0], $lshift_op) }
819 sub pp_right_shift { int_binop($_[0], $rshift_op) }
820 sub pp_i_add { int_binop($_[0], $plus_op) }
821 sub pp_i_subtract { int_binop($_[0], $minus_op) }
822 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
823 sub pp_i_divide { int_binop($_[0], $divide_op) }
824 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
826 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
827 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
828 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
829 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
830 sub pp_le { bool_numeric_binop($_[0], $le_op) }
831 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
833 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
834 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
835 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
836 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
837 sub pp_i_le { bool_int_binop($_[0], $le_op) }
838 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
840 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
841 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
842 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
843 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
844 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
845 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
846 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
852 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
857 ($src, $dst) = ($dst, $src) if $backwards;
858 my $type = $src->{type};
859 if ($type == T_INT) {
860 $dst->set_int($src->as_int);
861 } elsif ($type == T_DOUBLE) {
862 $dst->set_numeric($src->as_numeric);
864 $dst->set_sv($src->as_sv);
867 } elsif (@stack == 1) {
869 my $src = pop @stack;
870 my $type = $src->{type};
871 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
872 if ($type == T_INT) {
873 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
874 } elsif ($type == T_DOUBLE) {
875 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
877 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
879 runtime("SvSETMAGIC(TOPs);");
881 my $dst = pop @stack;
882 my $type = $dst->{type};
883 runtime("sv = POPs;");
884 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
885 if ($type == T_INT) {
886 $dst->set_int("SvIV(sv)");
887 } elsif ($type == T_DOUBLE) {
888 $dst->set_double("SvNV(sv)");
890 runtime("SvSetSV($dst->{sv}, sv);");
896 runtime("src = POPs; dst = TOPs;");
898 runtime("dst = POPs; src = TOPs;");
900 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
901 "SvSetSV(dst, src);",
911 my $obj = $stack[-1];
912 my $type = $obj->{type};
913 if ($type == T_INT || $type == T_DOUBLE) {
914 $obj->set_int($obj->as_int . " + 1");
916 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
920 runtime sprintf("PP_PREINC(TOPs);");
928 runtime("PUSHMARK(sp);");
935 my $gimme = gimme($op);
936 if ($gimme == 1) { # sic
937 runtime("POPMARK;"); # need this even though not a "full" pp_list
939 runtime("PP_LIST($gimme);");
946 write_back_lexicals(REGISTER|TEMPORARY);
949 runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);");
952 invalidate_lexicals(REGISTER|TEMPORARY);
963 write_back_lexicals(REGISTER|TEMPORARY);
966 # XXX Is this the right way to distinguish between it returning
967 # CvSTART(cv) (via doform) and pop_return()?
968 runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
971 invalidate_lexicals(REGISTER|TEMPORARY);
978 write_back_lexicals(REGISTER|TEMPORARY);
980 my $sym = loadop($op);
981 my $ppaddr = $op->ppaddr;
982 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
984 invalidate_lexicals(REGISTER|TEMPORARY);
988 sub pp_entereval { doeval(@_) }
989 sub pp_require { doeval(@_) }
990 sub pp_dofile { doeval(@_) }
995 write_back_lexicals(REGISTER|TEMPORARY);
998 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
999 declare("Sigjmp_buf", $jmpbuf);
1000 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1001 invalidate_lexicals(REGISTER|TEMPORARY);
1007 if ($need_freetmps && $freetmps_each_loop) {
1008 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1013 return $op->next->other;
1018 if ($need_freetmps && $freetmps_each_loop) {
1019 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1024 return $op->next->other;
1029 my $next = $op->next;
1030 unshift(@bblock_todo, $next);
1031 write_back_lexicals();
1033 my $sym = doop($op);
1034 # pp_grepwhile can return either op_next or op_other and we need to
1035 # be able to distinguish the two at runtime. Since it's possible for
1036 # both ops to be "inlined", the fields could both be zero. To get
1037 # around that, we hack op_next to be our own op (purely because we
1038 # know it's a non-NULL pointer and can't be the same as op_other).
1039 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1040 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1051 write_back_lexicals(REGISTER|TEMPORARY);
1054 runtime("PUTBACK;", "return 0;");
1061 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1062 return default_pp($op);
1067 my $flags = $op->flags;
1068 if (!($flags & OPf_KNOW)) {
1069 error("context of range unknown at compile-time");
1071 write_back_lexicals();
1073 if (!($flags & OPf_LIST)) {
1074 # We need to save our UNOP structure since pp_flop uses
1075 # it to find and adjust out targ. We don't need it ourselves.
1077 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1078 $op->targ, label($op->false));
1079 unshift(@bblock_todo, $op->false);
1086 my $flags = $op->flags;
1087 if (!($flags & OPf_KNOW)) {
1088 error("context of flip unknown at compile-time");
1090 if ($flags & OPf_LIST) {
1091 return $op->first->false;
1093 write_back_lexicals();
1095 # We need to save our UNOP structure since pp_flop uses
1096 # it to find and adjust out targ. We don't need it ourselves.
1099 my $rangeix = $op->first->targ;
1100 runtime(($op->private & OPpFLIP_LINENUM) ?
1101 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1102 : "if (SvTRUE(TOPs)) {");
1103 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1104 if ($op->flags & OPf_SPECIAL) {
1105 runtime("sv_setiv(PL_curpad[$ix], 1);");
1107 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1109 sprintf("\tgoto %s;", label($op->first->false)));
1112 qq{sv_setpv(PL_curpad[$ix], "");},
1113 "SETs(PL_curpad[$ix]);");
1127 my $nextop = $op->nextop;
1128 my $lastop = $op->lastop;
1129 my $redoop = $op->redoop;
1130 $curcop->write_back;
1131 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1135 "label" => $curcop->[0]->label,
1143 return default_pp($op);
1146 sub pp_enterloop { enterloop(@_) }
1147 sub pp_enteriter { enterloop(@_) }
1152 die "panic: leaveloop";
1154 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1156 return default_pp($op);
1162 if ($op->flags & OPf_SPECIAL) {
1163 $cxix = dopoptoloop();
1165 error('"next" used outside loop');
1166 return $op->next; # ignore the op
1169 $cxix = dopoptolabel($op->pv);
1171 error('Label not found at compile time for "next %s"', $op->pv);
1172 return $op->next; # ignore the op
1176 my $nextop = $cxstack[$cxix]->{nextop};
1177 push(@bblock_todo, $nextop);
1178 runtime(sprintf("goto %s;", label($nextop)));
1185 if ($op->flags & OPf_SPECIAL) {
1186 $cxix = dopoptoloop();
1188 error('"redo" used outside loop');
1189 return $op->next; # ignore the op
1192 $cxix = dopoptolabel($op->pv);
1194 error('Label not found at compile time for "redo %s"', $op->pv);
1195 return $op->next; # ignore the op
1199 my $redoop = $cxstack[$cxix]->{redoop};
1200 push(@bblock_todo, $redoop);
1201 runtime(sprintf("goto %s;", label($redoop)));
1208 if ($op->flags & OPf_SPECIAL) {
1209 $cxix = dopoptoloop();
1211 error('"last" used outside loop');
1212 return $op->next; # ignore the op
1215 $cxix = dopoptolabel($op->pv);
1217 error('Label not found at compile time for "last %s"', $op->pv);
1218 return $op->next; # ignore the op
1220 # XXX Add support for "last" to leave non-loop blocks
1221 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1222 error('Use of "last" for non-loop blocks is not yet implemented');
1223 return $op->next; # ignore the op
1227 my $lastop = $cxstack[$cxix]->{lastop}->next;
1228 push(@bblock_todo, $lastop);
1229 runtime(sprintf("goto %s;", label($lastop)));
1235 write_back_lexicals();
1237 my $sym = doop($op);
1238 my $replroot = $op->pmreplroot;
1240 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1241 $sym, label($replroot));
1242 $op->pmreplstart->save;
1243 push(@bblock_todo, $replroot);
1245 invalidate_lexicals();
1251 write_back_lexicals();
1254 my $pmop = $op->other;
1255 warn sprintf("substcont: op = %s, pmop = %s\n",
1256 peekop($op), peekop($pmop));#debug
1257 # my $pmopsym = objsym($pmop);
1258 my $pmopsym = $pmop->save; # XXX can this recurse?
1259 warn "pmopsym = $pmopsym\n";#debug
1260 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1261 $pmopsym, label($pmop->pmreplstart));
1262 invalidate_lexicals();
1268 my $ppname = $op->ppaddr;
1269 write_back_lexicals() unless $skip_lexicals{$ppname};
1270 write_back_stack() unless $skip_stack{$ppname};
1272 # XXX If the only way that ops can write to a TEMPORARY lexical is
1273 # when it's named in $op->targ then we could call
1274 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1275 # the temporaries. For now, we'll play it safe and write back the lot.
1276 invalidate_lexicals() unless $skip_invalidate{$ppname};
1282 my $ppname = $op->ppaddr;
1283 if (exists $ignore_op{$ppname}) {
1286 debug peek_stack() if $debug_stack;
1288 debug sprintf("%s [%s]\n",
1290 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1293 if (defined(&$ppname)) {
1295 return &$ppname($op);
1297 return default_pp($op);
1301 sub compile_bblock {
1303 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1307 $op = compile_op($op);
1308 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1309 write_back_stack(); # boo hoo: big loss
1315 my ($name, $root, $start, @padlist) = @_;
1319 B::Pseudoreg->new_scope;
1321 if ($debug_timings) {
1322 warn sprintf("Basic block analysis at %s\n", timing_info);
1324 $leaders = find_leaders($root, $start);
1325 @bblock_todo = ($start, values %$leaders);
1326 if ($debug_timings) {
1327 warn sprintf("Compilation at %s\n", timing_info);
1329 while (@bblock_todo) {
1330 $op = shift @bblock_todo;
1331 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1332 next if !defined($op) || !$$op || $done{$$op};
1333 #warn "...compiling it\n"; # debug
1336 $op = compile_bblock($op);
1337 if ($need_freetmps && $freetmps_each_bblock) {
1338 runtime("FREETMPS;");
1341 } while defined($op) && $$op && !$done{$$op};
1342 if ($need_freetmps && $freetmps_each_loop) {
1343 runtime("FREETMPS;");
1347 runtime("PUTBACK;", "return 0;");
1348 } elsif ($done{$$op}) {
1349 runtime(sprintf("goto %s;", label($op)));
1352 if ($debug_timings) {
1353 warn sprintf("Saving runtime at %s\n", timing_info);
1361 $start = cc_queue(@_) if @_;
1362 while ($ccinfo = shift @cc_todo) {
1369 my ($name, $cvref) = @_;
1370 my $cv = svref_2object($cvref);
1371 my @padlist = $cv->PADLIST->ARRAY;
1372 my $curpad_sym = $padlist[1]->save;
1373 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1377 my @comppadlist = comppadlist->ARRAY;
1378 my $curpad_sym = $comppadlist[1]->save;
1379 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1380 save_unused_subs(@unused_sub_packages);
1384 if (!defined($module)) {
1385 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1386 "PL_main_start = $start;",
1387 "PL_curpad = AvARRAY($curpad_sym);");
1389 output_boilerplate();
1391 output_all("perl_init");
1395 if (defined($module)) {
1396 my $cmodule = $module;
1397 $cmodule =~ s/::/__/g;
1407 SAVESPTR(PL_curpad);
1409 PL_curpad = AvARRAY($curpad_sym);
1419 if ($debug_timings) {
1420 warn sprintf("Done at %s\n", timing_info);
1426 my ($option, $opt, $arg);
1428 while ($option = shift @options) {
1429 if ($option =~ /^-(.)(.*)/) {
1433 unshift @options, $option;
1436 if ($opt eq "-" && $arg eq "-") {
1439 } elsif ($opt eq "o") {
1440 $arg ||= shift @options;
1441 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1442 } elsif ($opt eq "n") {
1443 $arg ||= shift @options;
1444 $module_name = $arg;
1445 } elsif ($opt eq "u") {
1446 $arg ||= shift @options;
1447 push(@unused_sub_packages, $arg);
1448 } elsif ($opt eq "f") {
1449 $arg ||= shift @options;
1450 my $value = $arg !~ s/^no-//;
1452 my $ref = $optimise{$arg};
1453 if (defined($ref)) {
1456 warn qq(ignoring unknown optimisation option "$arg"\n);
1458 } elsif ($opt eq "O") {
1459 $arg = 1 if $arg eq "";
1461 foreach $ref (values %optimise) {
1465 $freetmps_each_loop = 1;
1468 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1470 } elsif ($opt eq "m") {
1471 $arg ||= shift @options;
1473 push(@unused_sub_packages, $arg);
1474 } elsif ($opt eq "p") {
1475 $arg ||= shift @options;
1477 } elsif ($opt eq "D") {
1478 $arg ||= shift @options;
1479 foreach $arg (split(//, $arg)) {
1482 } elsif ($arg eq "O") {
1484 } elsif ($arg eq "s") {
1486 } elsif ($arg eq "c") {
1488 } elsif ($arg eq "p") {
1490 } elsif ($arg eq "r") {
1492 } elsif ($arg eq "S") {
1494 } elsif ($arg eq "q") {
1496 } elsif ($arg eq "l") {
1498 } elsif ($arg eq "t") {
1505 $init = B::Section->get("init");
1506 $decl = B::Section->get("decl");
1510 my ($objname, $ppname);
1511 foreach $objname (@options) {
1512 $objname = "main::$objname" unless $objname =~ /::/;
1513 ($ppname = $objname) =~ s/^.*?:://;
1514 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1515 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1518 output_boilerplate();
1520 output_all($module_name || "init_module");
1524 return sub { cc_main() };
1534 B::CC - Perl compiler's optimized C translation backend
1538 perl -MO=CC[,OPTIONS] foo.pl
1542 This compiler backend takes Perl source and generates C source code
1543 corresponding to the flow of your program. In other words, this
1544 backend is somewhat a "real" compiler in the sense that many people
1545 think about compilers. Note however that, currently, it is a very
1546 poor compiler in that although it generates (mostly, or at least
1547 sometimes) correct code, it performs relatively few optimisations.
1548 This will change as the compiler develops. The result is that
1549 running an executable compiled with this backend may start up more
1550 quickly than running the original Perl program (a feature shared
1551 by the B<C> compiler backend--see F<B::C>) and may also execute
1552 slightly faster. This is by no means a good optimising compiler--yet.
1556 If there are any non-option arguments, they are taken to be
1557 names of objects to be saved (probably doesn't work properly yet).
1558 Without extra arguments, it saves the main program.
1564 Output to filename instead of STDOUT
1568 Verbose compilation (currently gives a few compilation statistics).
1572 Force end of options
1576 Force apparently unused subs from package Packname to be compiled.
1577 This allows programs to use eval "foo()" even when sub foo is never
1578 seen to be used at compile time. The down side is that any subs which
1579 really are never used also have code generated. This option is
1580 necessary, for example, if you have a signal handler foo which you
1581 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1582 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1583 options. The compiler tries to figure out which packages may possibly
1584 have subs in which need compiling but the current version doesn't do
1585 it very well. In particular, it is confused by nested packages (i.e.
1586 of the form C<A::B>) where package C<A> does not contain any subs.
1588 =item B<-mModulename>
1590 Instead of generating source for a runnable executable, generate
1591 source for an XSUB module. The boot_Modulename function (which
1592 DynaLoader can look for) does the appropriate initialisation and runs
1593 the main part of the Perl source that is being compiled.
1598 Debug options (concatenated or separate flags like C<perl -D>).
1602 Writes debugging output to STDERR just as it's about to write to the
1603 program's runtime (otherwise writes debugging info as comments in
1608 Outputs each OP as it's compiled
1612 Outputs the contents of the shadow stack at each OP
1616 Outputs the contents of the shadow pad of lexicals as it's loaded for
1617 each sub or the main program.
1621 Outputs the name of each fake PP function in the queue as it's about
1626 Output the filename and line number of each original line of Perl
1627 code as it's processed (C<pp_nextstate>).
1631 Outputs timing information of compilation stages.
1635 Force optimisations on or off one at a time.
1637 =item B<-ffreetmps-each-bblock>
1639 Delays FREETMPS from the end of each statement to the end of the each
1642 =item B<-ffreetmps-each-loop>
1644 Delays FREETMPS from the end of each statement to the end of the group
1645 of basic blocks forming a loop. At most one of the freetmps-each-*
1646 options can be used.
1648 =item B<-fomit-taint>
1650 Omits generating code for handling perl's tainting mechanism.
1654 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1655 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1656 sets B<-ffreetmps-each-loop>.
1662 perl -MO=CC,-O2,-ofoo.c foo.pl
1663 perl cc_harness -o foo foo.c
1665 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1666 library directory. The utility called C<perlcc> may also be used to
1667 help make use of this compiler.
1669 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1670 perl cc_harness -shared -c -o Foo.so Foo.c
1674 Plenty. Current status: experimental.
1678 These aren't really bugs but they are constructs which are heavily
1679 tied to perl's compile-and-go implementation and with which this
1680 compiler backend cannot cope.
1684 Standard perl calculates the target of "next", "last", and "redo"
1685 at run-time. The compiler calculates the targets at compile-time.
1686 For example, the program
1688 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1689 NUMBER: for ($i = 0; $i < 5; $i++) {
1698 with standard perl but gives a compile-time error with the compiler.
1700 =head2 Context of ".."
1702 The context (scalar or array) of the ".." operator determines whether
1703 it behaves as a range or a flip/flop. Standard perl delays until
1704 runtime the decision of which context it is in but the compiler needs
1705 to know the context at compile-time. For example,
1708 sub range { (shift @a)..(shift @a) }
1710 while (@a) { print scalar(range()) }
1712 generates the output
1716 with standard Perl but gives a compile-time error with compiled Perl.
1720 Compiled Perl programs use native C arithemtic much more frequently
1721 than standard perl. Operations on large numbers or on boundary
1722 cases may produce different behaviour.
1724 =head2 Deprecated features
1726 Features of standard perl such as C<$[> which have been deprecated
1727 in standard perl since Perl5 was released have not been implemented
1732 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>