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)) {
78 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
79 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
81 # Optimisation options. On the command line, use hyphens instead of
82 # underscores for compatibility with gcc-style options. We use
83 # underscores here because they are OK in (strict) barewords.
84 my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
85 my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
86 freetmps_each_loop => \$freetmps_each_loop,
87 omit_taint => \$omit_taint);
88 # perl patchlevel to generate code for (defaults to current patchlevel)
89 my $patchlevel = int(0.5 + 1000 * ($] - 5));
91 # Could rewrite push_runtime() and output_runtime() to use a
92 # temporary file if memory is at a premium.
93 my $ppname; # name of current fake PP function
95 my $declare_ref; # Hash ref keyed by C variable type of declarations.
97 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
98 # tuples to be written out.
102 sub init_hash { map { $_ => 1 } @_ }
105 # Initialise the hashes for the default PP functions where we can avoid
106 # either write_back_stack, write_back_lexicals or invalidate_lexicals.
108 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
109 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
112 if ($debug_runtime) {
115 runtime(map { chomp; "/* $_ */"} @_);
120 my ($type, $var) = @_;
121 push(@{$declare_ref->{$type}}, $var);
125 push(@$runtime_list_ref, @_);
126 warn join("\n", @_) . "\n" if $debug_runtime;
130 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
135 print qq(#include "cc_runtime.h"\n);
136 foreach $ppdata (@pp_list) {
137 my ($name, $runtime, $declare) = @$ppdata;
138 print "\nstatic\nPP($name)\n{\n";
139 my ($type, $varlist, $line);
140 while (($type, $varlist) = each %$declare) {
141 print "\t$type ", join(", ", @$varlist), ";\n";
143 foreach $line (@$runtime) {
153 push_runtime("\t$line");
159 $runtime_list_ref = [];
162 declare("I32", "oldsave");
163 declare("SV", "**svp");
164 map { declare("SV", "*$_") } qw(sv src dst left right);
165 declare("MAGIC", "*mg");
166 $decl->add("static OP * $ppname _((ARGSproto));");
167 debug "init_pp: $ppname\n" if $debug_queue;
170 # Initialise runtime_callback function for Stackobj class
171 BEGIN { B::Stackobj::set_callback(\&runtime) }
173 # Initialise saveoptree_callback for B::C class
175 my ($name, $root, $start, @pl) = @_;
176 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
178 if ($name eq "*ignore*") {
181 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
183 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
184 $start = $fakeop->save;
185 debug "cc_queue: name $name returns $start\n" if $debug_queue;
188 BEGIN { B::C::set_callback(\&cc_queue) }
190 sub valid_int { $_[0]->{flags} & VALID_INT }
191 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
192 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
193 sub valid_sv { $_[0]->{flags} & VALID_SV }
195 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
196 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
197 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
198 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
199 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
201 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
202 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
203 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
204 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
207 return ((pop @stack)->as_bool);
209 # Careful: POPs has an auto-decrement and SvTRUE evaluates
210 # its argument more than once.
211 runtime("sv = POPs;");
216 sub write_back_lexicals {
217 my $avoid = shift || 0;
218 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
221 foreach $lex (@pad) {
222 next unless ref($lex);
223 $lex->write_back unless $lex->{flags} & $avoid;
227 sub write_back_stack {
229 return unless @stack;
230 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
231 foreach $obj (@stack) {
232 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
237 sub invalidate_lexicals {
238 my $avoid = shift || 0;
239 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
242 foreach $lex (@pad) {
243 next unless ref($lex);
244 $lex->invalidate unless $lex->{flags} & $avoid;
248 sub reload_lexicals {
250 foreach $lex (@pad) {
251 next unless ref($lex);
252 my $type = $lex->{type};
253 if ($type == T_INT) {
255 } elsif ($type == T_DOUBLE) {
264 package B::Pseudoreg;
266 # This class allocates pseudo-registers (OK, so they're C variables).
268 my %alloc; # Keyed by variable name. A value of 1 means the
269 # variable has been declared. A value of 2 means
272 sub new_scope { %alloc = () }
275 my ($class, $type, $prefix) = @_;
276 my ($ptr, $i, $varname, $status, $obj);
277 $prefix =~ s/^(\**)//;
281 $varname = "$prefix$i";
282 $status = $alloc{$varname};
283 } while $status == 2;
286 B::CC::declare($type, "$ptr$varname");
287 $alloc{$varname} = 2; # declared and in use
289 $obj = bless \$varname, $class;
294 $alloc{$$obj} = 1; # no longer in use but still declared
300 # This class gives a standard API for a perl object to shadow a
301 # C variable and only generate reloads/write-backs when necessary.
303 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
304 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
305 # Use $obj->invalidate whenever an unknown function may have
309 my ($class, $write_back) = @_;
310 # Object fields are perl shadow variable, validity flag
311 # (for *C* variable) and callback sub for write_back
312 # (passed perl shadow variable as argument).
313 bless [undef, 1, $write_back], $class;
316 my ($obj, $newval) = @_;
317 $obj->[1] = 0; # C variable no longer valid
323 $obj->[1] = 1; # C variable will now be valid
324 &{$obj->[2]}($obj->[0]);
327 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
329 my $curcop = new B::Shadow (sub {
330 my $opsym = shift->save;
331 runtime("PL_curcop = (COP*)$opsym;");
335 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
338 my $cxix = $#cxstack;
339 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
342 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
348 my $cxix = $#cxstack;
349 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
350 && $cxstack[$cxix]->{label} ne $label) {
353 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
359 my $file = $curcop->[0]->filegv->SV->PV;
360 my $line = $curcop->[0]->line;
363 warn sprintf("%s:%d: $format\n", $file, $line, @_);
365 warn sprintf("%s:%d: %s\n", $file, $line, $format);
370 # Load pad takes (the elements of) a PADLIST as arguments and loads
371 # up @pad with Stackobj-derived objects which represent those lexicals.
372 # If/when perl itself can generate type information (my int $foo) then
373 # we'll take advantage of that here. Until then, we'll use various hacks
374 # to tell the compiler when we want a lexical to be a particular type
375 # or to be a register.
378 my ($namelistav, $valuelistav) = @_;
380 my @namelist = $namelistav->ARRAY;
381 my @valuelist = $valuelistav->ARRAY;
384 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
385 # Temporary lexicals don't get named so it's possible for @valuelist
386 # to be strictly longer than @namelist. We count $ix up to the end of
387 # @valuelist but index into @namelist for the name. Any temporaries which
388 # run off the end of @namelist will make $namesv undefined and we treat
389 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
390 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
391 for ($ix = 1; $ix < @valuelist; $ix++) {
392 my $namesv = $namelist[$ix];
393 my $type = T_UNKNOWN;
396 my $class = class($namesv);
397 if (!defined($namesv) || $class eq "SPECIAL") {
398 # temporaries have &PL_sv_undef instead of a PVNV for a name
399 $flags = VALID_SV|TEMPORARY|REGISTER;
401 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
405 $flags = VALID_SV|VALID_INT;
406 } elsif ($2 eq "d") {
408 $flags = VALID_SV|VALID_DOUBLE;
410 $flags |= REGISTER if $3;
413 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
414 "i_$name", "d_$name");
415 declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
416 declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
417 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
424 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
432 # XXX Preserve original label name for "real" labels?
433 return sprintf("lab_%x", $$op);
438 push_runtime(sprintf(" %s:", label($op)));
443 my $opsym = $op->save;
444 runtime("PL_op = $opsym;") unless $know_op;
450 my $ppname = $op->ppaddr;
451 my $sym = loadop($op);
452 runtime("DOOP($ppname);");
459 my $flags = $op->flags;
460 return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
464 # Code generation for PP code
474 my $gimme = gimme($op);
476 # XXX Change to push a constant sv_undef Stackobj onto @stack
478 runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
486 runtime("PP_UNSTACK;");
492 my $next = $op->next;
494 unshift(@bblock_todo, $next);
496 my $bool = pop_bool();
498 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
500 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
508 my $next = $op->next;
510 unshift(@bblock_todo, $next);
512 my $bool = pop_bool @stack;
514 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
515 $bool, label($next)));
517 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
525 my $false = $op->false;
526 unshift(@bblock_todo, $false);
528 my $bool = pop_bool();
530 runtime(sprintf("if (!$bool) goto %s;", label($false)));
537 push(@stack, $pad[$ix]);
538 if ($op->flags & OPf_MOD) {
539 my $private = $op->private;
540 if ($private & OPpLVAL_INTRO) {
541 runtime("SAVECLEARSV(PL_curpad[$ix]);");
542 } elsif ($private & OPpDEREF) {
543 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
544 $ix, $private & OPpDEREF));
545 $pad[$ix]->invalidate;
554 my $obj = $constobj{$$sv};
555 if (!defined($obj)) {
556 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
566 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
567 runtime("TAINT_NOT;") unless $omit_taint;
568 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
569 if ($freetmps_each_bblock || $freetmps_each_loop) {
572 runtime("FREETMPS;");
579 $curcop->invalidate; # XXX?
580 return default_pp($op);
583 sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
584 sub pp_bless { $curcop->write_back; default_pp(@_) }
585 sub pp_repeat { $curcop->write_back; default_pp(@_) }
586 # The following subs need $curcop->write_back if we decide to support arybase:
587 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
588 sub pp_sort { $curcop->write_back; default_pp(@_) }
589 sub pp_caller { $curcop->write_back; default_pp(@_) }
590 sub pp_reset { $curcop->write_back; default_pp(@_) }
594 my $gvsym = $op->gv->save;
596 runtime("XPUSHs((SV*)$gvsym);");
602 my $gvsym = $op->gv->save;
604 if ($op->private & OPpLVAL_INTRO) {
605 runtime("XPUSHs(save_scalar($gvsym));");
607 runtime("XPUSHs(GvSV($gvsym));");
614 my $gvsym = $op->gv->save;
615 my $ix = $op->private;
616 my $flag = $op->flags & OPf_MOD;
618 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
619 "PUSHs(svp ? *svp : &PL_sv_undef);");
624 my ($op, $operator) = @_;
625 if ($op->flags & OPf_STACKED) {
626 my $right = pop_int();
628 my $left = top_int();
629 $stack[-1]->set_int(&$operator($left, $right));
631 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
634 my $targ = $pad[$op->targ];
635 my $right = new B::Pseudoreg ("IV", "riv");
636 my $left = new B::Pseudoreg ("IV", "liv");
637 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
638 $targ->set_int(&$operator($$left, $$right));
644 sub INTS_CLOSED () { 0x1 }
645 sub INT_RESULT () { 0x2 }
646 sub NUMERIC_RESULT () { 0x4 }
649 my ($op, $operator, $flags) = @_;
651 $force_int ||= ($flags & INT_RESULT);
652 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
653 && valid_int($stack[-2]) && valid_int($stack[-1]));
654 if ($op->flags & OPf_STACKED) {
655 my $right = pop_numeric();
657 my $left = top_numeric();
659 $stack[-1]->set_int(&$operator($left, $right));
661 $stack[-1]->set_numeric(&$operator($left, $right));
665 runtime(sprintf("sv_setiv(TOPs, %s);",
666 &$operator("TOPi", $right)));
668 runtime(sprintf("sv_setnv(TOPs, %s);",
669 &$operator("TOPn", $right)));
673 my $targ = $pad[$op->targ];
674 $force_int ||= ($targ->{type} == T_INT);
676 my $right = new B::Pseudoreg ("IV", "riv");
677 my $left = new B::Pseudoreg ("IV", "liv");
678 runtime(sprintf("$$right = %s; $$left = %s;",
679 pop_numeric(), pop_numeric));
680 $targ->set_int(&$operator($$left, $$right));
682 my $right = new B::Pseudoreg ("double", "rnv");
683 my $left = new B::Pseudoreg ("double", "lnv");
684 runtime(sprintf("$$right = %s; $$left = %s;",
685 pop_numeric(), pop_numeric));
686 $targ->set_numeric(&$operator($$left, $$right));
694 my ($op, $operator, $flags) = @_;
695 if ($op->flags & OPf_STACKED) {
696 my $right = pop_sv();
699 if ($flags & INT_RESULT) {
700 $stack[-1]->set_int(&$operator($left, $right));
701 } elsif ($flags & NUMERIC_RESULT) {
702 $stack[-1]->set_numeric(&$operator($left, $right));
704 # XXX Does this work?
705 runtime(sprintf("sv_setsv($left, %s);",
706 &$operator($left, $right)));
707 $stack[-1]->invalidate;
711 if ($flags & INT_RESULT) {
713 } elsif ($flags & NUMERIC_RESULT) {
718 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
721 my $targ = $pad[$op->targ];
722 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
723 if ($flags & INT_RESULT) {
724 $targ->set_int(&$operator("left", "right"));
725 } elsif ($flags & NUMERIC_RESULT) {
726 $targ->set_numeric(&$operator("left", "right"));
728 # XXX Does this work?
729 runtime(sprintf("sv_setsv(%s, %s);",
730 $targ->as_sv, &$operator("left", "right")));
739 my ($op, $operator) = @_;
740 my $right = new B::Pseudoreg ("IV", "riv");
741 my $left = new B::Pseudoreg ("IV", "liv");
742 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
743 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
744 $bool->set_int(&$operator($$left, $$right));
749 sub bool_numeric_binop {
750 my ($op, $operator) = @_;
751 my $right = new B::Pseudoreg ("double", "rnv");
752 my $left = new B::Pseudoreg ("double", "lnv");
753 runtime(sprintf("$$right = %s; $$left = %s;",
754 pop_numeric(), pop_numeric()));
755 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
756 $bool->set_numeric(&$operator($$left, $$right));
762 my ($op, $operator) = @_;
763 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
764 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
765 $bool->set_numeric(&$operator("left", "right"));
772 return sub { "$_[0] $opname $_[1]" }
777 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
781 my $plus_op = infix_op("+");
782 my $minus_op = infix_op("-");
783 my $multiply_op = infix_op("*");
784 my $divide_op = infix_op("/");
785 my $modulo_op = infix_op("%");
786 my $lshift_op = infix_op("<<");
787 my $rshift_op = infix_op(">>");
788 my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
789 my $scmp_op = prefix_op("sv_cmp");
790 my $seq_op = prefix_op("sv_eq");
791 my $sne_op = prefix_op("!sv_eq");
792 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
793 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
794 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
795 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
796 my $eq_op = infix_op("==");
797 my $ne_op = infix_op("!=");
798 my $lt_op = infix_op("<");
799 my $gt_op = infix_op(">");
800 my $le_op = infix_op("<=");
801 my $ge_op = infix_op(">=");
804 # XXX The standard perl PP code has extra handling for
805 # some special case arguments of these operators.
807 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
808 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
809 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
810 sub pp_divide { numeric_binop($_[0], $divide_op) }
811 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
812 sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
814 sub pp_left_shift { int_binop($_[0], $lshift_op) }
815 sub pp_right_shift { int_binop($_[0], $rshift_op) }
816 sub pp_i_add { int_binop($_[0], $plus_op) }
817 sub pp_i_subtract { int_binop($_[0], $minus_op) }
818 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
819 sub pp_i_divide { int_binop($_[0], $divide_op) }
820 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
822 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
823 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
824 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
825 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
826 sub pp_le { bool_numeric_binop($_[0], $le_op) }
827 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
829 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
830 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
831 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
832 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
833 sub pp_i_le { bool_int_binop($_[0], $le_op) }
834 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
836 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
837 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
838 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
839 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
840 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
841 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
842 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
848 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
853 ($src, $dst) = ($dst, $src) if $backwards;
854 my $type = $src->{type};
855 if ($type == T_INT) {
856 $dst->set_int($src->as_int);
857 } elsif ($type == T_DOUBLE) {
858 $dst->set_numeric($src->as_numeric);
860 $dst->set_sv($src->as_sv);
863 } elsif (@stack == 1) {
865 my $src = pop @stack;
866 my $type = $src->{type};
867 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
868 if ($type == T_INT) {
869 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
870 } elsif ($type == T_DOUBLE) {
871 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
873 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
875 runtime("SvSETMAGIC(TOPs);");
877 my $dst = $stack[-1];
878 my $type = $dst->{type};
879 runtime("sv = POPs;");
880 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
881 if ($type == T_INT) {
882 $dst->set_int("SvIV(sv)");
883 } elsif ($type == T_DOUBLE) {
884 $dst->set_double("SvNV(sv)");
886 runtime("SvSetSV($dst->{sv}, sv);");
892 runtime("src = POPs; dst = TOPs;");
894 runtime("dst = POPs; src = TOPs;");
896 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
897 "SvSetSV(dst, src);",
907 my $obj = $stack[-1];
908 my $type = $obj->{type};
909 if ($type == T_INT || $type == T_DOUBLE) {
910 $obj->set_int($obj->as_int . " + 1");
912 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
916 runtime sprintf("PP_PREINC(TOPs);");
924 runtime("PUSHMARK(sp);");
931 my $gimme = gimme($op);
932 if ($gimme == 1) { # sic
933 runtime("POPMARK;"); # need this even though not a "full" pp_list
935 runtime("PP_LIST($gimme);");
942 write_back_lexicals(REGISTER|TEMPORARY);
945 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
946 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
947 runtime("SPAGAIN;}");
949 invalidate_lexicals(REGISTER|TEMPORARY);
956 my $ppname = $op->ppaddr;
957 write_back_lexicals() unless $skip_lexicals{$ppname};
958 write_back_stack() unless $skip_stack{$ppname};
960 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
961 invalidate_lexicals() unless $skip_invalidate{$ppname};
971 write_back_lexicals(REGISTER|TEMPORARY);
974 # XXX Is this the right way to distinguish between it returning
975 # CvSTART(cv) (via doform) and pop_return()?
976 runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
979 invalidate_lexicals(REGISTER|TEMPORARY);
986 write_back_lexicals(REGISTER|TEMPORARY);
988 my $sym = loadop($op);
989 my $ppaddr = $op->ppaddr;
990 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
992 invalidate_lexicals(REGISTER|TEMPORARY);
996 sub pp_entereval { doeval(@_) }
997 sub pp_require { doeval(@_) }
998 sub pp_dofile { doeval(@_) }
1002 $curcop->write_back;
1003 write_back_lexicals(REGISTER|TEMPORARY);
1005 my $sym = doop($op);
1006 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1007 declare("Sigjmp_buf", $jmpbuf);
1008 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1009 invalidate_lexicals(REGISTER|TEMPORARY);
1015 if ($need_freetmps && $freetmps_each_loop) {
1016 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1021 return $op->next->other;
1026 if ($need_freetmps && $freetmps_each_loop) {
1027 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1032 return $op->next->other;
1037 my $next = $op->next;
1038 unshift(@bblock_todo, $next);
1039 write_back_lexicals();
1041 my $sym = doop($op);
1042 # pp_grepwhile can return either op_next or op_other and we need to
1043 # be able to distinguish the two at runtime. Since it's possible for
1044 # both ops to be "inlined", the fields could both be zero. To get
1045 # around that, we hack op_next to be our own op (purely because we
1046 # know it's a non-NULL pointer and can't be the same as op_other).
1047 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1048 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1059 write_back_lexicals(REGISTER|TEMPORARY);
1062 runtime("PUTBACK;", "return PL_op;");
1069 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1070 return default_pp($op);
1075 my $flags = $op->flags;
1076 if (!($flags & OPf_KNOW)) {
1077 error("context of range unknown at compile-time");
1079 write_back_lexicals();
1081 if (!($flags & OPf_LIST)) {
1082 # We need to save our UNOP structure since pp_flop uses
1083 # it to find and adjust out targ. We don't need it ourselves.
1085 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1086 $op->targ, label($op->false));
1087 unshift(@bblock_todo, $op->false);
1094 my $flags = $op->flags;
1095 if (!($flags & OPf_KNOW)) {
1096 error("context of flip unknown at compile-time");
1098 if ($flags & OPf_LIST) {
1099 return $op->first->false;
1101 write_back_lexicals();
1103 # We need to save our UNOP structure since pp_flop uses
1104 # it to find and adjust out targ. We don't need it ourselves.
1107 my $rangeix = $op->first->targ;
1108 runtime(($op->private & OPpFLIP_LINENUM) ?
1109 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1110 : "if (SvTRUE(TOPs)) {");
1111 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1112 if ($op->flags & OPf_SPECIAL) {
1113 runtime("sv_setiv(PL_curpad[$ix], 1);");
1115 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1117 sprintf("\tgoto %s;", label($op->first->false)));
1120 qq{sv_setpv(PL_curpad[$ix], "");},
1121 "SETs(PL_curpad[$ix]);");
1135 my $nextop = $op->nextop;
1136 my $lastop = $op->lastop;
1137 my $redoop = $op->redoop;
1138 $curcop->write_back;
1139 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1143 "label" => $curcop->[0]->label,
1151 return default_pp($op);
1154 sub pp_enterloop { enterloop(@_) }
1155 sub pp_enteriter { enterloop(@_) }
1160 die "panic: leaveloop";
1162 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1164 return default_pp($op);
1170 if ($op->flags & OPf_SPECIAL) {
1171 $cxix = dopoptoloop();
1173 error('"next" used outside loop');
1174 return $op->next; # ignore the op
1177 $cxix = dopoptolabel($op->pv);
1179 error('Label not found at compile time for "next %s"', $op->pv);
1180 return $op->next; # ignore the op
1184 my $nextop = $cxstack[$cxix]->{nextop};
1185 push(@bblock_todo, $nextop);
1186 runtime(sprintf("goto %s;", label($nextop)));
1193 if ($op->flags & OPf_SPECIAL) {
1194 $cxix = dopoptoloop();
1196 error('"redo" used outside loop');
1197 return $op->next; # ignore the op
1200 $cxix = dopoptolabel($op->pv);
1202 error('Label not found at compile time for "redo %s"', $op->pv);
1203 return $op->next; # ignore the op
1207 my $redoop = $cxstack[$cxix]->{redoop};
1208 push(@bblock_todo, $redoop);
1209 runtime(sprintf("goto %s;", label($redoop)));
1216 if ($op->flags & OPf_SPECIAL) {
1217 $cxix = dopoptoloop();
1219 error('"last" used outside loop');
1220 return $op->next; # ignore the op
1223 $cxix = dopoptolabel($op->pv);
1225 error('Label not found at compile time for "last %s"', $op->pv);
1226 return $op->next; # ignore the op
1228 # XXX Add support for "last" to leave non-loop blocks
1229 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1230 error('Use of "last" for non-loop blocks is not yet implemented');
1231 return $op->next; # ignore the op
1235 my $lastop = $cxstack[$cxix]->{lastop}->next;
1236 push(@bblock_todo, $lastop);
1237 runtime(sprintf("goto %s;", label($lastop)));
1243 write_back_lexicals();
1245 my $sym = doop($op);
1246 my $replroot = $op->pmreplroot;
1248 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1249 $sym, label($replroot));
1250 $op->pmreplstart->save;
1251 push(@bblock_todo, $replroot);
1253 invalidate_lexicals();
1259 write_back_lexicals();
1262 my $pmop = $op->other;
1263 # warn sprintf("substcont: op = %s, pmop = %s\n",
1264 # peekop($op), peekop($pmop));#debug
1265 # my $pmopsym = objsym($pmop);
1266 my $pmopsym = $pmop->save; # XXX can this recurse?
1267 # warn "pmopsym = $pmopsym\n";#debug
1268 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1269 $pmopsym, label($pmop->pmreplstart));
1270 invalidate_lexicals();
1276 my $ppname = $op->ppaddr;
1277 write_back_lexicals() unless $skip_lexicals{$ppname};
1278 write_back_stack() unless $skip_stack{$ppname};
1280 # XXX If the only way that ops can write to a TEMPORARY lexical is
1281 # when it's named in $op->targ then we could call
1282 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1283 # the temporaries. For now, we'll play it safe and write back the lot.
1284 invalidate_lexicals() unless $skip_invalidate{$ppname};
1290 my $ppname = $op->ppaddr;
1291 if (exists $ignore_op{$ppname}) {
1294 debug peek_stack() if $debug_stack;
1296 debug sprintf("%s [%s]\n",
1298 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1301 if (defined(&$ppname)) {
1303 return &$ppname($op);
1305 return default_pp($op);
1309 sub compile_bblock {
1311 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1315 $op = compile_op($op);
1316 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1317 write_back_stack(); # boo hoo: big loss
1323 my ($name, $root, $start, @padlist) = @_;
1327 B::Pseudoreg->new_scope;
1329 if ($debug_timings) {
1330 warn sprintf("Basic block analysis at %s\n", timing_info);
1332 $leaders = find_leaders($root, $start);
1333 @bblock_todo = ($start, values %$leaders);
1334 if ($debug_timings) {
1335 warn sprintf("Compilation at %s\n", timing_info);
1337 while (@bblock_todo) {
1338 $op = shift @bblock_todo;
1339 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1340 next if !defined($op) || !$$op || $done{$$op};
1341 #warn "...compiling it\n"; # debug
1344 $op = compile_bblock($op);
1345 if ($need_freetmps && $freetmps_each_bblock) {
1346 runtime("FREETMPS;");
1349 } while defined($op) && $$op && !$done{$$op};
1350 if ($need_freetmps && $freetmps_each_loop) {
1351 runtime("FREETMPS;");
1355 runtime("PUTBACK;","return PL_op;");
1356 } elsif ($done{$$op}) {
1357 runtime(sprintf("goto %s;", label($op)));
1360 if ($debug_timings) {
1361 warn sprintf("Saving runtime at %s\n", timing_info);
1369 $start = cc_queue(@_) if @_;
1370 while ($ccinfo = shift @cc_todo) {
1377 my ($name, $cvref) = @_;
1378 my $cv = svref_2object($cvref);
1379 my @padlist = $cv->PADLIST->ARRAY;
1380 my $curpad_sym = $padlist[1]->save;
1381 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1385 my @comppadlist = comppadlist->ARRAY;
1386 my $curpad_nam = $comppadlist[0]->save;
1387 my $curpad_sym = $comppadlist[1]->save;
1388 my $init_av = init_av->save;
1389 my $inc_hv = svref_2object(\%INC)->save;
1390 my $inc_av = svref_2object(\@INC)->save;
1391 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1396 if (!defined($module)) {
1397 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1398 "PL_main_start = $start;",
1399 "PL_curpad = AvARRAY($curpad_sym);",
1400 "PL_initav = $init_av;",
1401 "GvHV(PL_incgv) = $inc_hv;",
1402 "GvAV(PL_incgv) = $inc_av;",
1403 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1404 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1408 output_boilerplate();
1410 output_all("perl_init");
1414 if (defined($module)) {
1415 my $cmodule = $module;
1416 $cmodule =~ s/::/__/g;
1426 SAVESPTR(PL_curpad);
1428 PL_curpad = AvARRAY($curpad_sym);
1438 if ($debug_timings) {
1439 warn sprintf("Done at %s\n", timing_info);
1445 my ($option, $opt, $arg);
1447 while ($option = shift @options) {
1448 if ($option =~ /^-(.)(.*)/) {
1452 unshift @options, $option;
1455 if ($opt eq "-" && $arg eq "-") {
1458 } elsif ($opt eq "o") {
1459 $arg ||= shift @options;
1460 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1461 } elsif ($opt eq "n") {
1462 $arg ||= shift @options;
1463 $module_name = $arg;
1464 } elsif ($opt eq "u") {
1465 $arg ||= shift @options;
1466 mark_unused($arg,undef);
1467 } elsif ($opt eq "f") {
1468 $arg ||= shift @options;
1469 my $value = $arg !~ s/^no-//;
1471 my $ref = $optimise{$arg};
1472 if (defined($ref)) {
1475 warn qq(ignoring unknown optimisation option "$arg"\n);
1477 } elsif ($opt eq "O") {
1478 $arg = 1 if $arg eq "";
1480 foreach $ref (values %optimise) {
1484 $freetmps_each_loop = 1;
1487 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1489 } elsif ($opt eq "m") {
1490 $arg ||= shift @options;
1492 mark_unused($arg,undef);
1493 } elsif ($opt eq "p") {
1494 $arg ||= shift @options;
1496 } elsif ($opt eq "D") {
1497 $arg ||= shift @options;
1498 foreach $arg (split(//, $arg)) {
1501 } elsif ($arg eq "O") {
1503 } elsif ($arg eq "s") {
1505 } elsif ($arg eq "c") {
1507 } elsif ($arg eq "p") {
1509 } elsif ($arg eq "r") {
1511 } elsif ($arg eq "S") {
1513 } elsif ($arg eq "q") {
1515 } elsif ($arg eq "l") {
1517 } elsif ($arg eq "t") {
1524 $init = B::Section->get("init");
1525 $decl = B::Section->get("decl");
1529 my ($objname, $ppname);
1530 foreach $objname (@options) {
1531 $objname = "main::$objname" unless $objname =~ /::/;
1532 ($ppname = $objname) =~ s/^.*?:://;
1533 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1534 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1537 output_boilerplate();
1539 output_all($module_name || "init_module");
1543 return sub { cc_main() };
1553 B::CC - Perl compiler's optimized C translation backend
1557 perl -MO=CC[,OPTIONS] foo.pl
1561 This compiler backend takes Perl source and generates C source code
1562 corresponding to the flow of your program. In other words, this
1563 backend is somewhat a "real" compiler in the sense that many people
1564 think about compilers. Note however that, currently, it is a very
1565 poor compiler in that although it generates (mostly, or at least
1566 sometimes) correct code, it performs relatively few optimisations.
1567 This will change as the compiler develops. The result is that
1568 running an executable compiled with this backend may start up more
1569 quickly than running the original Perl program (a feature shared
1570 by the B<C> compiler backend--see F<B::C>) and may also execute
1571 slightly faster. This is by no means a good optimising compiler--yet.
1575 If there are any non-option arguments, they are taken to be
1576 names of objects to be saved (probably doesn't work properly yet).
1577 Without extra arguments, it saves the main program.
1583 Output to filename instead of STDOUT
1587 Verbose compilation (currently gives a few compilation statistics).
1591 Force end of options
1595 Force apparently unused subs from package Packname to be compiled.
1596 This allows programs to use eval "foo()" even when sub foo is never
1597 seen to be used at compile time. The down side is that any subs which
1598 really are never used also have code generated. This option is
1599 necessary, for example, if you have a signal handler foo which you
1600 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1601 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1602 options. The compiler tries to figure out which packages may possibly
1603 have subs in which need compiling but the current version doesn't do
1604 it very well. In particular, it is confused by nested packages (i.e.
1605 of the form C<A::B>) where package C<A> does not contain any subs.
1607 =item B<-mModulename>
1609 Instead of generating source for a runnable executable, generate
1610 source for an XSUB module. The boot_Modulename function (which
1611 DynaLoader can look for) does the appropriate initialisation and runs
1612 the main part of the Perl source that is being compiled.
1617 Debug options (concatenated or separate flags like C<perl -D>).
1621 Writes debugging output to STDERR just as it's about to write to the
1622 program's runtime (otherwise writes debugging info as comments in
1627 Outputs each OP as it's compiled
1631 Outputs the contents of the shadow stack at each OP
1635 Outputs the contents of the shadow pad of lexicals as it's loaded for
1636 each sub or the main program.
1640 Outputs the name of each fake PP function in the queue as it's about
1645 Output the filename and line number of each original line of Perl
1646 code as it's processed (C<pp_nextstate>).
1650 Outputs timing information of compilation stages.
1654 Force optimisations on or off one at a time.
1656 =item B<-ffreetmps-each-bblock>
1658 Delays FREETMPS from the end of each statement to the end of the each
1661 =item B<-ffreetmps-each-loop>
1663 Delays FREETMPS from the end of each statement to the end of the group
1664 of basic blocks forming a loop. At most one of the freetmps-each-*
1665 options can be used.
1667 =item B<-fomit-taint>
1669 Omits generating code for handling perl's tainting mechanism.
1673 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1674 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1675 sets B<-ffreetmps-each-loop>.
1681 perl -MO=CC,-O2,-ofoo.c foo.pl
1682 perl cc_harness -o foo foo.c
1684 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1685 library directory. The utility called C<perlcc> may also be used to
1686 help make use of this compiler.
1688 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1689 perl cc_harness -shared -c -o Foo.so Foo.c
1693 Plenty. Current status: experimental.
1697 These aren't really bugs but they are constructs which are heavily
1698 tied to perl's compile-and-go implementation and with which this
1699 compiler backend cannot cope.
1703 Standard perl calculates the target of "next", "last", and "redo"
1704 at run-time. The compiler calculates the targets at compile-time.
1705 For example, the program
1707 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1708 NUMBER: for ($i = 0; $i < 5; $i++) {
1717 with standard perl but gives a compile-time error with the compiler.
1719 =head2 Context of ".."
1721 The context (scalar or array) of the ".." operator determines whether
1722 it behaves as a range or a flip/flop. Standard perl delays until
1723 runtime the decision of which context it is in but the compiler needs
1724 to know the context at compile-time. For example,
1727 sub range { (shift @a)..(shift @a) }
1729 while (@a) { print scalar(range()) }
1731 generates the output
1735 with standard Perl but gives a compile-time error with compiled Perl.
1739 Compiled Perl programs use native C arithemtic much more frequently
1740 than standard perl. Operations on large numbers or on boundary
1741 cases may produce different behaviour.
1743 =head2 Deprecated features
1745 Features of standard perl such as C<$[> which have been deprecated
1746 in standard perl since Perl5 was released have not been implemented
1751 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>