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 mark_unused
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;
354 ($cxstack[$cxix]->{type} != CXt_LOOP ||
355 $cxstack[$cxix]->{label} ne $label)) {
358 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
364 my $file = $curcop->[0]->filegv->SV->PV;
365 my $line = $curcop->[0]->line;
368 warn sprintf("%s:%d: $format\n", $file, $line, @_);
370 warn sprintf("%s:%d: %s\n", $file, $line, $format);
375 # Load pad takes (the elements of) a PADLIST as arguments and loads
376 # up @pad with Stackobj-derived objects which represent those lexicals.
377 # If/when perl itself can generate type information (my int $foo) then
378 # we'll take advantage of that here. Until then, we'll use various hacks
379 # to tell the compiler when we want a lexical to be a particular type
380 # or to be a register.
383 my ($namelistav, $valuelistav) = @_;
385 my @namelist = $namelistav->ARRAY;
386 my @valuelist = $valuelistav->ARRAY;
389 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
390 # Temporary lexicals don't get named so it's possible for @valuelist
391 # to be strictly longer than @namelist. We count $ix up to the end of
392 # @valuelist but index into @namelist for the name. Any temporaries which
393 # run off the end of @namelist will make $namesv undefined and we treat
394 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
395 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
396 for ($ix = 1; $ix < @valuelist; $ix++) {
397 my $namesv = $namelist[$ix];
398 my $type = T_UNKNOWN;
401 my $class = class($namesv);
402 if (!defined($namesv) || $class eq "SPECIAL") {
403 # temporaries have &PL_sv_undef instead of a PVNV for a name
404 $flags = VALID_SV|TEMPORARY|REGISTER;
406 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
410 $flags = VALID_SV|VALID_INT;
411 } elsif ($2 eq "d") {
413 $flags = VALID_SV|VALID_DOUBLE;
415 $flags |= REGISTER if $3;
418 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
419 "i_$name", "d_$name");
420 declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
421 declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
422 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
429 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
437 # XXX Preserve original label name for "real" labels?
438 return sprintf("lab_%x", $$op);
443 push_runtime(sprintf(" %s:", label($op)));
448 my $opsym = $op->save;
449 runtime("PL_op = $opsym;") unless $know_op;
455 my $ppname = $op->ppaddr;
456 my $sym = loadop($op);
457 runtime("DOOP($ppname);");
464 my $flags = $op->flags;
465 return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
469 # Code generation for PP code
479 my $gimme = gimme($op);
481 # XXX Change to push a constant sv_undef Stackobj onto @stack
483 runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
491 runtime("PP_UNSTACK;");
497 my $next = $op->next;
499 unshift(@bblock_todo, $next);
501 my $bool = pop_bool();
503 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
505 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
513 my $next = $op->next;
515 unshift(@bblock_todo, $next);
517 my $bool = pop_bool @stack;
519 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
520 $bool, label($next)));
522 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
530 my $false = $op->false;
531 unshift(@bblock_todo, $false);
533 my $bool = pop_bool();
535 runtime(sprintf("if (!$bool) goto %s;", label($false)));
542 push(@stack, $pad[$ix]);
543 if ($op->flags & OPf_MOD) {
544 my $private = $op->private;
545 if ($private & OPpLVAL_INTRO) {
546 runtime("SAVECLEARSV(PL_curpad[$ix]);");
547 } elsif ($private & OPpDEREF) {
548 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
549 $ix, $private & OPpDEREF));
550 $pad[$ix]->invalidate;
559 my $obj = $constobj{$$sv};
560 if (!defined($obj)) {
561 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
571 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
572 runtime("TAINT_NOT;") unless $omit_taint;
573 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
574 if ($freetmps_each_bblock || $freetmps_each_loop) {
577 runtime("FREETMPS;");
584 $curcop->invalidate; # XXX?
585 return default_pp($op);
588 sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
589 sub pp_bless { $curcop->write_back; default_pp(@_) }
590 sub pp_repeat { $curcop->write_back; default_pp(@_) }
591 # The following subs need $curcop->write_back if we decide to support arybase:
592 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
593 sub pp_sort { $curcop->write_back; default_pp(@_) }
594 sub pp_caller { $curcop->write_back; default_pp(@_) }
595 sub pp_reset { $curcop->write_back; default_pp(@_) }
599 my $gvsym = $op->gv->save;
601 runtime("XPUSHs((SV*)$gvsym);");
607 my $gvsym = $op->gv->save;
609 if ($op->private & OPpLVAL_INTRO) {
610 runtime("XPUSHs(save_scalar($gvsym));");
612 runtime("XPUSHs(GvSV($gvsym));");
619 my $gvsym = $op->gv->save;
620 my $ix = $op->private;
621 my $flag = $op->flags & OPf_MOD;
623 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
624 "PUSHs(svp ? *svp : &PL_sv_undef);");
629 my ($op, $operator) = @_;
630 if ($op->flags & OPf_STACKED) {
631 my $right = pop_int();
633 my $left = top_int();
634 $stack[-1]->set_int(&$operator($left, $right));
636 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
639 my $targ = $pad[$op->targ];
640 my $right = new B::Pseudoreg ("IV", "riv");
641 my $left = new B::Pseudoreg ("IV", "liv");
642 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
643 $targ->set_int(&$operator($$left, $$right));
649 sub INTS_CLOSED () { 0x1 }
650 sub INT_RESULT () { 0x2 }
651 sub NUMERIC_RESULT () { 0x4 }
654 my ($op, $operator, $flags) = @_;
656 $force_int ||= ($flags & INT_RESULT);
657 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
658 && valid_int($stack[-2]) && valid_int($stack[-1]));
659 if ($op->flags & OPf_STACKED) {
660 my $right = pop_numeric();
662 my $left = top_numeric();
664 $stack[-1]->set_int(&$operator($left, $right));
666 $stack[-1]->set_numeric(&$operator($left, $right));
670 runtime(sprintf("sv_setiv(TOPs, %s);",
671 &$operator("TOPi", $right)));
673 runtime(sprintf("sv_setnv(TOPs, %s);",
674 &$operator("TOPn", $right)));
678 my $targ = $pad[$op->targ];
679 $force_int ||= ($targ->{type} == T_INT);
681 my $right = new B::Pseudoreg ("IV", "riv");
682 my $left = new B::Pseudoreg ("IV", "liv");
683 runtime(sprintf("$$right = %s; $$left = %s;",
684 pop_numeric(), pop_numeric));
685 $targ->set_int(&$operator($$left, $$right));
687 my $right = new B::Pseudoreg ("double", "rnv");
688 my $left = new B::Pseudoreg ("double", "lnv");
689 runtime(sprintf("$$right = %s; $$left = %s;",
690 pop_numeric(), pop_numeric));
691 $targ->set_numeric(&$operator($$left, $$right));
699 my ($op, $operator, $flags) = @_;
700 if ($op->flags & OPf_STACKED) {
701 my $right = pop_sv();
704 if ($flags & INT_RESULT) {
705 $stack[-1]->set_int(&$operator($left, $right));
706 } elsif ($flags & NUMERIC_RESULT) {
707 $stack[-1]->set_numeric(&$operator($left, $right));
709 # XXX Does this work?
710 runtime(sprintf("sv_setsv($left, %s);",
711 &$operator($left, $right)));
712 $stack[-1]->invalidate;
716 if ($flags & INT_RESULT) {
718 } elsif ($flags & NUMERIC_RESULT) {
723 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
726 my $targ = $pad[$op->targ];
727 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
728 if ($flags & INT_RESULT) {
729 $targ->set_int(&$operator("left", "right"));
730 } elsif ($flags & NUMERIC_RESULT) {
731 $targ->set_numeric(&$operator("left", "right"));
733 # XXX Does this work?
734 runtime(sprintf("sv_setsv(%s, %s);",
735 $targ->as_sv, &$operator("left", "right")));
744 my ($op, $operator) = @_;
745 my $right = new B::Pseudoreg ("IV", "riv");
746 my $left = new B::Pseudoreg ("IV", "liv");
747 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
748 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
749 $bool->set_int(&$operator($$left, $$right));
754 sub bool_numeric_binop {
755 my ($op, $operator) = @_;
756 my $right = new B::Pseudoreg ("double", "rnv");
757 my $left = new B::Pseudoreg ("double", "lnv");
758 runtime(sprintf("$$right = %s; $$left = %s;",
759 pop_numeric(), pop_numeric()));
760 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
761 $bool->set_numeric(&$operator($$left, $$right));
767 my ($op, $operator) = @_;
768 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
769 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
770 $bool->set_numeric(&$operator("left", "right"));
777 return sub { "$_[0] $opname $_[1]" }
782 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
786 my $plus_op = infix_op("+");
787 my $minus_op = infix_op("-");
788 my $multiply_op = infix_op("*");
789 my $divide_op = infix_op("/");
790 my $modulo_op = infix_op("%");
791 my $lshift_op = infix_op("<<");
792 my $rshift_op = infix_op(">>");
793 my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
794 my $scmp_op = prefix_op("sv_cmp");
795 my $seq_op = prefix_op("sv_eq");
796 my $sne_op = prefix_op("!sv_eq");
797 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
798 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
799 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
800 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
801 my $eq_op = infix_op("==");
802 my $ne_op = infix_op("!=");
803 my $lt_op = infix_op("<");
804 my $gt_op = infix_op(">");
805 my $le_op = infix_op("<=");
806 my $ge_op = infix_op(">=");
809 # XXX The standard perl PP code has extra handling for
810 # some special case arguments of these operators.
812 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
813 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
814 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
815 sub pp_divide { numeric_binop($_[0], $divide_op) }
816 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
817 sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
819 sub pp_left_shift { int_binop($_[0], $lshift_op) }
820 sub pp_right_shift { int_binop($_[0], $rshift_op) }
821 sub pp_i_add { int_binop($_[0], $plus_op) }
822 sub pp_i_subtract { int_binop($_[0], $minus_op) }
823 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
824 sub pp_i_divide { int_binop($_[0], $divide_op) }
825 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
827 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
828 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
829 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
830 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
831 sub pp_le { bool_numeric_binop($_[0], $le_op) }
832 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
834 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
835 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
836 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
837 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
838 sub pp_i_le { bool_int_binop($_[0], $le_op) }
839 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
841 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
842 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
843 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
844 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
845 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
846 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
847 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
853 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
858 ($src, $dst) = ($dst, $src) if $backwards;
859 my $type = $src->{type};
860 if ($type == T_INT) {
861 $dst->set_int($src->as_int);
862 } elsif ($type == T_DOUBLE) {
863 $dst->set_numeric($src->as_numeric);
865 $dst->set_sv($src->as_sv);
868 } elsif (@stack == 1) {
870 my $src = pop @stack;
871 my $type = $src->{type};
872 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
873 if ($type == T_INT) {
874 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
875 } elsif ($type == T_DOUBLE) {
876 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
878 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
880 runtime("SvSETMAGIC(TOPs);");
882 my $dst = $stack[-1];
883 my $type = $dst->{type};
884 runtime("sv = POPs;");
885 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
886 if ($type == T_INT) {
887 $dst->set_int("SvIV(sv)");
888 } elsif ($type == T_DOUBLE) {
889 $dst->set_double("SvNV(sv)");
891 runtime("SvSetSV($dst->{sv}, sv);");
897 runtime("src = POPs; dst = TOPs;");
899 runtime("dst = POPs; src = TOPs;");
901 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
902 "SvSetSV(dst, src);",
912 my $obj = $stack[-1];
913 my $type = $obj->{type};
914 if ($type == T_INT || $type == T_DOUBLE) {
915 $obj->set_int($obj->as_int . " + 1");
917 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
921 runtime sprintf("PP_PREINC(TOPs);");
929 runtime("PUSHMARK(sp);");
936 my $gimme = gimme($op);
937 if ($gimme == 1) { # sic
938 runtime("POPMARK;"); # need this even though not a "full" pp_list
940 runtime("PP_LIST($gimme);");
947 write_back_lexicals(REGISTER|TEMPORARY);
950 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
951 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
952 runtime("SPAGAIN;}");
954 invalidate_lexicals(REGISTER|TEMPORARY);
961 my $ppname = $op->ppaddr;
962 write_back_lexicals() unless $skip_lexicals{$ppname};
963 write_back_stack() unless $skip_stack{$ppname};
965 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
966 invalidate_lexicals() unless $skip_invalidate{$ppname};
976 write_back_lexicals(REGISTER|TEMPORARY);
979 # XXX Is this the right way to distinguish between it returning
980 # CvSTART(cv) (via doform) and pop_return()?
981 runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
984 invalidate_lexicals(REGISTER|TEMPORARY);
991 write_back_lexicals(REGISTER|TEMPORARY);
993 my $sym = loadop($op);
994 my $ppaddr = $op->ppaddr;
995 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
997 invalidate_lexicals(REGISTER|TEMPORARY);
1001 sub pp_entereval { doeval(@_) }
1002 sub pp_require { doeval(@_) }
1003 sub pp_dofile { doeval(@_) }
1007 $curcop->write_back;
1008 write_back_lexicals(REGISTER|TEMPORARY);
1010 my $sym = doop($op);
1011 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1012 declare("Sigjmp_buf", $jmpbuf);
1013 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1014 invalidate_lexicals(REGISTER|TEMPORARY);
1020 if ($need_freetmps && $freetmps_each_loop) {
1021 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1026 return $op->next->other;
1031 if ($need_freetmps && $freetmps_each_loop) {
1032 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1037 return $op->next->other;
1042 my $next = $op->next;
1043 unshift(@bblock_todo, $next);
1044 write_back_lexicals();
1046 my $sym = doop($op);
1047 # pp_grepwhile can return either op_next or op_other and we need to
1048 # be able to distinguish the two at runtime. Since it's possible for
1049 # both ops to be "inlined", the fields could both be zero. To get
1050 # around that, we hack op_next to be our own op (purely because we
1051 # know it's a non-NULL pointer and can't be the same as op_other).
1052 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1053 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1064 write_back_lexicals(REGISTER|TEMPORARY);
1067 runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;");
1074 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1075 return default_pp($op);
1080 my $flags = $op->flags;
1081 if (!($flags & OPf_KNOW)) {
1082 error("context of range unknown at compile-time");
1084 write_back_lexicals();
1086 if (!($flags & OPf_LIST)) {
1087 # We need to save our UNOP structure since pp_flop uses
1088 # it to find and adjust out targ. We don't need it ourselves.
1090 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1091 $op->targ, label($op->false));
1092 unshift(@bblock_todo, $op->false);
1099 my $flags = $op->flags;
1100 if (!($flags & OPf_KNOW)) {
1101 error("context of flip unknown at compile-time");
1103 if ($flags & OPf_LIST) {
1104 return $op->first->false;
1106 write_back_lexicals();
1108 # We need to save our UNOP structure since pp_flop uses
1109 # it to find and adjust out targ. We don't need it ourselves.
1112 my $rangeix = $op->first->targ;
1113 runtime(($op->private & OPpFLIP_LINENUM) ?
1114 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1115 : "if (SvTRUE(TOPs)) {");
1116 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1117 if ($op->flags & OPf_SPECIAL) {
1118 runtime("sv_setiv(PL_curpad[$ix], 1);");
1120 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1122 sprintf("\tgoto %s;", label($op->first->false)));
1125 qq{sv_setpv(PL_curpad[$ix], "");},
1126 "SETs(PL_curpad[$ix]);");
1140 my $nextop = $op->nextop;
1141 my $lastop = $op->lastop;
1142 my $redoop = $op->redoop;
1143 $curcop->write_back;
1144 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1148 "label" => $curcop->[0]->label,
1156 return default_pp($op);
1159 sub pp_enterloop { enterloop(@_) }
1160 sub pp_enteriter { enterloop(@_) }
1165 die "panic: leaveloop";
1167 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1169 return default_pp($op);
1175 if ($op->flags & OPf_SPECIAL) {
1176 $cxix = dopoptoloop();
1178 error('"next" used outside loop');
1179 return $op->next; # ignore the op
1182 $cxix = dopoptolabel($op->pv);
1184 error('Label not found at compile time for "next %s"', $op->pv);
1185 return $op->next; # ignore the op
1189 my $nextop = $cxstack[$cxix]->{nextop};
1190 push(@bblock_todo, $nextop);
1191 runtime(sprintf("goto %s;", label($nextop)));
1198 if ($op->flags & OPf_SPECIAL) {
1199 $cxix = dopoptoloop();
1201 error('"redo" used outside loop');
1202 return $op->next; # ignore the op
1205 $cxix = dopoptolabel($op->pv);
1207 error('Label not found at compile time for "redo %s"', $op->pv);
1208 return $op->next; # ignore the op
1212 my $redoop = $cxstack[$cxix]->{redoop};
1213 push(@bblock_todo, $redoop);
1214 runtime(sprintf("goto %s;", label($redoop)));
1221 if ($op->flags & OPf_SPECIAL) {
1222 $cxix = dopoptoloop();
1224 error('"last" used outside loop');
1225 return $op->next; # ignore the op
1228 $cxix = dopoptolabel($op->pv);
1230 error('Label not found at compile time for "last %s"', $op->pv);
1231 return $op->next; # ignore the op
1233 # XXX Add support for "last" to leave non-loop blocks
1234 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1235 error('Use of "last" for non-loop blocks is not yet implemented');
1236 return $op->next; # ignore the op
1240 my $lastop = $cxstack[$cxix]->{lastop}->next;
1241 push(@bblock_todo, $lastop);
1242 runtime(sprintf("goto %s;", label($lastop)));
1248 write_back_lexicals();
1250 my $sym = doop($op);
1251 my $replroot = $op->pmreplroot;
1253 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1254 $sym, label($replroot));
1255 $op->pmreplstart->save;
1256 push(@bblock_todo, $replroot);
1258 invalidate_lexicals();
1264 write_back_lexicals();
1267 my $pmop = $op->other;
1268 # warn sprintf("substcont: op = %s, pmop = %s\n",
1269 # peekop($op), peekop($pmop));#debug
1270 # my $pmopsym = objsym($pmop);
1271 my $pmopsym = $pmop->save; # XXX can this recurse?
1272 # warn "pmopsym = $pmopsym\n";#debug
1273 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1274 $pmopsym, label($pmop->pmreplstart));
1275 invalidate_lexicals();
1281 my $ppname = $op->ppaddr;
1282 write_back_lexicals() unless $skip_lexicals{$ppname};
1283 write_back_stack() unless $skip_stack{$ppname};
1285 # XXX If the only way that ops can write to a TEMPORARY lexical is
1286 # when it's named in $op->targ then we could call
1287 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1288 # the temporaries. For now, we'll play it safe and write back the lot.
1289 invalidate_lexicals() unless $skip_invalidate{$ppname};
1295 my $ppname = $op->ppaddr;
1296 if (exists $ignore_op{$ppname}) {
1299 debug peek_stack() if $debug_stack;
1301 debug sprintf("%s [%s]\n",
1303 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1306 if (defined(&$ppname)) {
1308 return &$ppname($op);
1310 return default_pp($op);
1314 sub compile_bblock {
1316 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1320 $op = compile_op($op);
1321 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1322 write_back_stack(); # boo hoo: big loss
1328 my ($name, $root, $start, @padlist) = @_;
1332 B::Pseudoreg->new_scope;
1334 if ($debug_timings) {
1335 warn sprintf("Basic block analysis at %s\n", timing_info);
1337 $leaders = find_leaders($root, $start);
1338 @bblock_todo = ($start, values %$leaders);
1339 if ($debug_timings) {
1340 warn sprintf("Compilation at %s\n", timing_info);
1342 while (@bblock_todo) {
1343 $op = shift @bblock_todo;
1344 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1345 next if !defined($op) || !$$op || $done{$$op};
1346 #warn "...compiling it\n"; # debug
1349 $op = compile_bblock($op);
1350 if ($need_freetmps && $freetmps_each_bblock) {
1351 runtime("FREETMPS;");
1354 } while defined($op) && $$op && !$done{$$op};
1355 if ($need_freetmps && $freetmps_each_loop) {
1356 runtime("FREETMPS;");
1360 runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;");
1361 } elsif ($done{$$op}) {
1362 runtime(sprintf("goto %s;", label($op)));
1365 if ($debug_timings) {
1366 warn sprintf("Saving runtime at %s\n", timing_info);
1374 $start = cc_queue(@_) if @_;
1375 while ($ccinfo = shift @cc_todo) {
1382 my ($name, $cvref) = @_;
1383 my $cv = svref_2object($cvref);
1384 my @padlist = $cv->PADLIST->ARRAY;
1385 my $curpad_sym = $padlist[1]->save;
1386 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1390 my @comppadlist = comppadlist->ARRAY;
1391 my $curpad_nam = $comppadlist[0]->save;
1392 my $curpad_sym = $comppadlist[1]->save;
1393 my $init_av = init_av->save;
1394 my $inc_hv = svref_2object(\%INC)->save;
1395 my $inc_av = svref_2object(\@INC)->save;
1396 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1401 if (!defined($module)) {
1402 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1403 "PL_main_start = $start;",
1404 "PL_curpad = AvARRAY($curpad_sym);",
1405 "PL_initav = $init_av;",
1406 "GvHV(PL_incgv) = $inc_hv;",
1407 "GvAV(PL_incgv) = $inc_av;",
1408 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1409 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1413 output_boilerplate();
1415 output_all("perl_init");
1419 if (defined($module)) {
1420 my $cmodule = $module;
1421 $cmodule =~ s/::/__/g;
1431 SAVESPTR(PL_curpad);
1433 PL_curpad = AvARRAY($curpad_sym);
1443 if ($debug_timings) {
1444 warn sprintf("Done at %s\n", timing_info);
1450 my ($option, $opt, $arg);
1452 while ($option = shift @options) {
1453 if ($option =~ /^-(.)(.*)/) {
1457 unshift @options, $option;
1460 if ($opt eq "-" && $arg eq "-") {
1463 } elsif ($opt eq "o") {
1464 $arg ||= shift @options;
1465 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1466 } elsif ($opt eq "n") {
1467 $arg ||= shift @options;
1468 $module_name = $arg;
1469 } elsif ($opt eq "u") {
1470 $arg ||= shift @options;
1471 mark_unused($arg,undef);
1472 } elsif ($opt eq "f") {
1473 $arg ||= shift @options;
1474 my $value = $arg !~ s/^no-//;
1476 my $ref = $optimise{$arg};
1477 if (defined($ref)) {
1480 warn qq(ignoring unknown optimisation option "$arg"\n);
1482 } elsif ($opt eq "O") {
1483 $arg = 1 if $arg eq "";
1485 foreach $ref (values %optimise) {
1489 $freetmps_each_loop = 1;
1492 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1494 } elsif ($opt eq "m") {
1495 $arg ||= shift @options;
1497 push(@unused_sub_packages, $arg);
1498 } elsif ($opt eq "p") {
1499 $arg ||= shift @options;
1501 } elsif ($opt eq "D") {
1502 $arg ||= shift @options;
1503 foreach $arg (split(//, $arg)) {
1506 } elsif ($arg eq "O") {
1508 } elsif ($arg eq "s") {
1510 } elsif ($arg eq "c") {
1512 } elsif ($arg eq "p") {
1514 } elsif ($arg eq "r") {
1516 } elsif ($arg eq "S") {
1518 } elsif ($arg eq "q") {
1520 } elsif ($arg eq "l") {
1522 } elsif ($arg eq "t") {
1529 $init = B::Section->get("init");
1530 $decl = B::Section->get("decl");
1534 my ($objname, $ppname);
1535 foreach $objname (@options) {
1536 $objname = "main::$objname" unless $objname =~ /::/;
1537 ($ppname = $objname) =~ s/^.*?:://;
1538 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1539 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1542 output_boilerplate();
1544 output_all($module_name || "init_module");
1548 return sub { cc_main() };
1558 B::CC - Perl compiler's optimized C translation backend
1562 perl -MO=CC[,OPTIONS] foo.pl
1566 This compiler backend takes Perl source and generates C source code
1567 corresponding to the flow of your program. In other words, this
1568 backend is somewhat a "real" compiler in the sense that many people
1569 think about compilers. Note however that, currently, it is a very
1570 poor compiler in that although it generates (mostly, or at least
1571 sometimes) correct code, it performs relatively few optimisations.
1572 This will change as the compiler develops. The result is that
1573 running an executable compiled with this backend may start up more
1574 quickly than running the original Perl program (a feature shared
1575 by the B<C> compiler backend--see F<B::C>) and may also execute
1576 slightly faster. This is by no means a good optimising compiler--yet.
1580 If there are any non-option arguments, they are taken to be
1581 names of objects to be saved (probably doesn't work properly yet).
1582 Without extra arguments, it saves the main program.
1588 Output to filename instead of STDOUT
1592 Verbose compilation (currently gives a few compilation statistics).
1596 Force end of options
1600 Force apparently unused subs from package Packname to be compiled.
1601 This allows programs to use eval "foo()" even when sub foo is never
1602 seen to be used at compile time. The down side is that any subs which
1603 really are never used also have code generated. This option is
1604 necessary, for example, if you have a signal handler foo which you
1605 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1606 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1607 options. The compiler tries to figure out which packages may possibly
1608 have subs in which need compiling but the current version doesn't do
1609 it very well. In particular, it is confused by nested packages (i.e.
1610 of the form C<A::B>) where package C<A> does not contain any subs.
1612 =item B<-mModulename>
1614 Instead of generating source for a runnable executable, generate
1615 source for an XSUB module. The boot_Modulename function (which
1616 DynaLoader can look for) does the appropriate initialisation and runs
1617 the main part of the Perl source that is being compiled.
1622 Debug options (concatenated or separate flags like C<perl -D>).
1626 Writes debugging output to STDERR just as it's about to write to the
1627 program's runtime (otherwise writes debugging info as comments in
1632 Outputs each OP as it's compiled
1636 Outputs the contents of the shadow stack at each OP
1640 Outputs the contents of the shadow pad of lexicals as it's loaded for
1641 each sub or the main program.
1645 Outputs the name of each fake PP function in the queue as it's about
1650 Output the filename and line number of each original line of Perl
1651 code as it's processed (C<pp_nextstate>).
1655 Outputs timing information of compilation stages.
1659 Force optimisations on or off one at a time.
1661 =item B<-ffreetmps-each-bblock>
1663 Delays FREETMPS from the end of each statement to the end of the each
1666 =item B<-ffreetmps-each-loop>
1668 Delays FREETMPS from the end of each statement to the end of the group
1669 of basic blocks forming a loop. At most one of the freetmps-each-*
1670 options can be used.
1672 =item B<-fomit-taint>
1674 Omits generating code for handling perl's tainting mechanism.
1678 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1679 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1680 sets B<-ffreetmps-each-loop>.
1686 perl -MO=CC,-O2,-ofoo.c foo.pl
1687 perl cc_harness -o foo foo.c
1689 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1690 library directory. The utility called C<perlcc> may also be used to
1691 help make use of this compiler.
1693 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1694 perl cc_harness -shared -c -o Foo.so Foo.c
1698 Plenty. Current status: experimental.
1702 These aren't really bugs but they are constructs which are heavily
1703 tied to perl's compile-and-go implementation and with which this
1704 compiler backend cannot cope.
1708 Standard perl calculates the target of "next", "last", and "redo"
1709 at run-time. The compiler calculates the targets at compile-time.
1710 For example, the program
1712 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1713 NUMBER: for ($i = 0; $i < 5; $i++) {
1722 with standard perl but gives a compile-time error with the compiler.
1724 =head2 Context of ".."
1726 The context (scalar or array) of the ".." operator determines whether
1727 it behaves as a range or a flip/flop. Standard perl delays until
1728 runtime the decision of which context it is in but the compiler needs
1729 to know the context at compile-time. For example,
1732 sub range { (shift @a)..(shift @a) }
1734 while (@a) { print scalar(range()) }
1736 generates the output
1740 with standard Perl but gives a compile-time error with compiled Perl.
1744 Compiled Perl programs use native C arithemtic much more frequently
1745 than standard perl. Operations on large numbers or on boundary
1746 cases may produce different behaviour.
1748 =head2 Deprecated features
1750 Features of standard perl such as C<$[> which have been deprecated
1751 in standard perl since Perl5 was released have not been implemented
1756 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>