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
69 my %need_curcop; # Hash of ops which need PL_curcop
72 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);
110 %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller pp_reset pp_rv2cv pp_entereval pp_require pp_dofile pp_entertry pp_enterloop pp_enteriter );
113 if ($debug_runtime) {
116 runtime(map { chomp; "/* $_ */"} @_);
121 my ($type, $var) = @_;
122 push(@{$declare_ref->{$type}}, $var);
126 push(@$runtime_list_ref, @_);
127 warn join("\n", @_) . "\n" if $debug_runtime;
131 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
136 print qq(#include "cc_runtime.h"\n);
137 foreach $ppdata (@pp_list) {
138 my ($name, $runtime, $declare) = @$ppdata;
139 print "\nstatic\nPP($name)\n{\n";
140 my ($type, $varlist, $line);
141 while (($type, $varlist) = each %$declare) {
142 print "\t$type ", join(", ", @$varlist), ";\n";
144 foreach $line (@$runtime) {
154 push_runtime("\t$line");
160 $runtime_list_ref = [];
163 declare("I32", "oldsave");
164 declare("SV", "**svp");
165 map { declare("SV", "*$_") } qw(sv src dst left right);
166 declare("MAGIC", "*mg");
167 $decl->add("static OP * $ppname _((ARGSproto));");
168 debug "init_pp: $ppname\n" if $debug_queue;
171 # Initialise runtime_callback function for Stackobj class
172 BEGIN { B::Stackobj::set_callback(\&runtime) }
174 # Initialise saveoptree_callback for B::C class
176 my ($name, $root, $start, @pl) = @_;
177 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
179 if ($name eq "*ignore*") {
182 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
184 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
185 $start = $fakeop->save;
186 debug "cc_queue: name $name returns $start\n" if $debug_queue;
189 BEGIN { B::C::set_callback(\&cc_queue) }
191 sub valid_int { $_[0]->{flags} & VALID_INT }
192 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
193 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
194 sub valid_sv { $_[0]->{flags} & VALID_SV }
196 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
197 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
198 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
199 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
200 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
202 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
203 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
204 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
205 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
208 return ((pop @stack)->as_bool);
210 # Careful: POPs has an auto-decrement and SvTRUE evaluates
211 # its argument more than once.
212 runtime("sv = POPs;");
217 sub write_back_lexicals {
218 my $avoid = shift || 0;
219 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
222 foreach $lex (@pad) {
223 next unless ref($lex);
224 $lex->write_back unless $lex->{flags} & $avoid;
228 sub write_back_stack {
230 return unless @stack;
231 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
232 foreach $obj (@stack) {
233 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
238 sub invalidate_lexicals {
239 my $avoid = shift || 0;
240 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
243 foreach $lex (@pad) {
244 next unless ref($lex);
245 $lex->invalidate unless $lex->{flags} & $avoid;
249 sub reload_lexicals {
251 foreach $lex (@pad) {
252 next unless ref($lex);
253 my $type = $lex->{type};
254 if ($type == T_INT) {
256 } elsif ($type == T_DOUBLE) {
265 package B::Pseudoreg;
267 # This class allocates pseudo-registers (OK, so they're C variables).
269 my %alloc; # Keyed by variable name. A value of 1 means the
270 # variable has been declared. A value of 2 means
273 sub new_scope { %alloc = () }
276 my ($class, $type, $prefix) = @_;
277 my ($ptr, $i, $varname, $status, $obj);
278 $prefix =~ s/^(\**)//;
282 $varname = "$prefix$i";
283 $status = $alloc{$varname};
284 } while $status == 2;
287 B::CC::declare($type, "$ptr$varname");
288 $alloc{$varname} = 2; # declared and in use
290 $obj = bless \$varname, $class;
295 $alloc{$$obj} = 1; # no longer in use but still declared
301 # This class gives a standard API for a perl object to shadow a
302 # C variable and only generate reloads/write-backs when necessary.
304 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
305 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
306 # Use $obj->invalidate whenever an unknown function may have
310 my ($class, $write_back) = @_;
311 # Object fields are perl shadow variable, validity flag
312 # (for *C* variable) and callback sub for write_back
313 # (passed perl shadow variable as argument).
314 bless [undef, 1, $write_back], $class;
317 my ($obj, $newval) = @_;
318 $obj->[1] = 0; # C variable no longer valid
324 $obj->[1] = 1; # C variable will now be valid
325 &{$obj->[2]}($obj->[0]);
328 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
330 my $curcop = new B::Shadow (sub {
331 my $opsym = shift->save;
332 runtime("PL_curcop = (COP*)$opsym;");
336 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
339 my $cxix = $#cxstack;
340 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
343 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
349 my $cxix = $#cxstack;
351 ($cxstack[$cxix]->{type} != CXt_LOOP ||
352 $cxstack[$cxix]->{label} ne $label)) {
355 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
361 my $file = $curcop->[0]->filegv->SV->PV;
362 my $line = $curcop->[0]->line;
365 warn sprintf("%s:%d: $format\n", $file, $line, @_);
367 warn sprintf("%s:%d: %s\n", $file, $line, $format);
372 # Load pad takes (the elements of) a PADLIST as arguments and loads
373 # up @pad with Stackobj-derived objects which represent those lexicals.
374 # If/when perl itself can generate type information (my int $foo) then
375 # we'll take advantage of that here. Until then, we'll use various hacks
376 # to tell the compiler when we want a lexical to be a particular type
377 # or to be a register.
380 my ($namelistav, $valuelistav) = @_;
382 my @namelist = $namelistav->ARRAY;
383 my @valuelist = $valuelistav->ARRAY;
386 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
387 # Temporary lexicals don't get named so it's possible for @valuelist
388 # to be strictly longer than @namelist. We count $ix up to the end of
389 # @valuelist but index into @namelist for the name. Any temporaries which
390 # run off the end of @namelist will make $namesv undefined and we treat
391 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
392 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
393 for ($ix = 1; $ix < @valuelist; $ix++) {
394 my $namesv = $namelist[$ix];
395 my $type = T_UNKNOWN;
398 my $class = class($namesv);
399 if (!defined($namesv) || $class eq "SPECIAL") {
400 # temporaries have &PL_sv_undef instead of a PVNV for a name
401 $flags = VALID_SV|TEMPORARY|REGISTER;
403 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
407 $flags = VALID_SV|VALID_INT;
408 } elsif ($2 eq "d") {
410 $flags = VALID_SV|VALID_DOUBLE;
412 $flags |= REGISTER if $3;
415 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
416 "i_$name", "d_$name");
417 declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
418 declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
419 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
426 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
434 # XXX Preserve original label name for "real" labels?
435 return sprintf("lab_%x", $$op);
440 push_runtime(sprintf(" %s:", label($op)));
445 my $opsym = $op->save;
446 runtime("PL_op = $opsym;") unless $know_op;
452 my $ppname = $op->ppaddr;
453 my $sym = loadop($op);
454 runtime("DOOP($ppname);");
461 my $flags = $op->flags;
462 return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
466 # Code generation for PP code
476 my $gimme = gimme($op);
478 # XXX Change to push a constant sv_undef Stackobj onto @stack
480 runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
488 runtime("PP_UNSTACK;");
494 my $next = $op->next;
496 unshift(@bblock_todo, $next);
498 my $bool = pop_bool();
500 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
502 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
510 my $next = $op->next;
512 unshift(@bblock_todo, $next);
514 my $bool = pop_bool @stack;
516 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
517 $bool, label($next)));
519 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
527 my $false = $op->false;
528 unshift(@bblock_todo, $false);
530 my $bool = pop_bool();
532 runtime(sprintf("if (!$bool) goto %s;", label($false)));
539 push(@stack, $pad[$ix]);
540 if ($op->flags & OPf_MOD) {
541 my $private = $op->private;
542 if ($private & OPpLVAL_INTRO) {
543 runtime("SAVECLEARSV(PL_curpad[$ix]);");
544 } elsif ($private & OPpDEREF) {
545 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
546 $ix, $private & OPpDEREF));
547 $pad[$ix]->invalidate;
556 my $obj = $constobj{$$sv};
557 if (!defined($obj)) {
558 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
568 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
569 runtime("TAINT_NOT;") unless $omit_taint;
570 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
571 if ($freetmps_each_bblock || $freetmps_each_loop) {
574 runtime("FREETMPS;");
581 $curcop->invalidate; # XXX?
582 return default_pp($op);
585 #default_pp will handle this:
586 #sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
587 #sub pp_bless { $curcop->write_back; default_pp(@_) }
588 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
589 # The following subs need $curcop->write_back if we decide to support arybase:
590 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
591 #sub pp_sort { $curcop->write_back; default_pp(@_) }
592 #sub pp_caller { $curcop->write_back; default_pp(@_) }
593 #sub pp_reset { $curcop->write_back; default_pp(@_) }
597 my $gvsym = $op->gv->save;
599 runtime("XPUSHs((SV*)$gvsym);");
605 my $gvsym = $op->gv->save;
607 if ($op->private & OPpLVAL_INTRO) {
608 runtime("XPUSHs(save_scalar($gvsym));");
610 runtime("XPUSHs(GvSV($gvsym));");
617 my $gvsym = $op->gv->save;
618 my $ix = $op->private;
619 my $flag = $op->flags & OPf_MOD;
621 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
622 "PUSHs(svp ? *svp : &PL_sv_undef);");
627 my ($op, $operator) = @_;
628 if ($op->flags & OPf_STACKED) {
629 my $right = pop_int();
631 my $left = top_int();
632 $stack[-1]->set_int(&$operator($left, $right));
634 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
637 my $targ = $pad[$op->targ];
638 my $right = new B::Pseudoreg ("IV", "riv");
639 my $left = new B::Pseudoreg ("IV", "liv");
640 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
641 $targ->set_int(&$operator($$left, $$right));
647 sub INTS_CLOSED () { 0x1 }
648 sub INT_RESULT () { 0x2 }
649 sub NUMERIC_RESULT () { 0x4 }
652 my ($op, $operator, $flags) = @_;
654 $force_int ||= ($flags & INT_RESULT);
655 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
656 && valid_int($stack[-2]) && valid_int($stack[-1]));
657 if ($op->flags & OPf_STACKED) {
658 my $right = pop_numeric();
660 my $left = top_numeric();
662 $stack[-1]->set_int(&$operator($left, $right));
664 $stack[-1]->set_numeric(&$operator($left, $right));
668 my $rightruntime = new B::Pseudoreg ("IV", "riv");
669 runtime(sprintf("$$rightruntime = %s;",$right));
670 runtime(sprintf("sv_setiv(TOPs, %s);",
671 &$operator("TOPi", $$rightruntime)));
673 my $rightruntime = new B::Pseudoreg ("double", "rnv");
674 runtime(sprintf("$$rightruntime = %s;",$right));
675 runtime(sprintf("sv_setnv(TOPs, %s);",
676 &$operator("TOPn",$$rightruntime)));
680 my $targ = $pad[$op->targ];
681 $force_int ||= ($targ->{type} == T_INT);
683 my $right = new B::Pseudoreg ("IV", "riv");
684 my $left = new B::Pseudoreg ("IV", "liv");
685 runtime(sprintf("$$right = %s; $$left = %s;",
686 pop_numeric(), pop_numeric));
687 $targ->set_int(&$operator($$left, $$right));
689 my $right = new B::Pseudoreg ("double", "rnv");
690 my $left = new B::Pseudoreg ("double", "lnv");
691 runtime(sprintf("$$right = %s; $$left = %s;",
692 pop_numeric(), pop_numeric));
693 $targ->set_numeric(&$operator($$left, $$right));
701 my ($op, $operator, $flags) = @_;
702 if ($op->flags & OPf_STACKED) {
703 my $right = pop_sv();
706 if ($flags & INT_RESULT) {
707 $stack[-1]->set_int(&$operator($left, $right));
708 } elsif ($flags & NUMERIC_RESULT) {
709 $stack[-1]->set_numeric(&$operator($left, $right));
711 # XXX Does this work?
712 runtime(sprintf("sv_setsv($left, %s);",
713 &$operator($left, $right)));
714 $stack[-1]->invalidate;
718 if ($flags & INT_RESULT) {
720 } elsif ($flags & NUMERIC_RESULT) {
725 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
728 my $targ = $pad[$op->targ];
729 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
730 if ($flags & INT_RESULT) {
731 $targ->set_int(&$operator("left", "right"));
732 } elsif ($flags & NUMERIC_RESULT) {
733 $targ->set_numeric(&$operator("left", "right"));
735 # XXX Does this work?
736 runtime(sprintf("sv_setsv(%s, %s);",
737 $targ->as_sv, &$operator("left", "right")));
746 my ($op, $operator) = @_;
747 my $right = new B::Pseudoreg ("IV", "riv");
748 my $left = new B::Pseudoreg ("IV", "liv");
749 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
750 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
751 $bool->set_int(&$operator($$left, $$right));
756 sub bool_numeric_binop {
757 my ($op, $operator) = @_;
758 my $right = new B::Pseudoreg ("double", "rnv");
759 my $left = new B::Pseudoreg ("double", "lnv");
760 runtime(sprintf("$$right = %s; $$left = %s;",
761 pop_numeric(), pop_numeric()));
762 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
763 $bool->set_numeric(&$operator($$left, $$right));
769 my ($op, $operator) = @_;
770 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
771 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
772 $bool->set_numeric(&$operator("left", "right"));
779 return sub { "$_[0] $opname $_[1]" }
784 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
788 my $plus_op = infix_op("+");
789 my $minus_op = infix_op("-");
790 my $multiply_op = infix_op("*");
791 my $divide_op = infix_op("/");
792 my $modulo_op = infix_op("%");
793 my $lshift_op = infix_op("<<");
794 my $rshift_op = infix_op(">>");
795 my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
796 my $scmp_op = prefix_op("sv_cmp");
797 my $seq_op = prefix_op("sv_eq");
798 my $sne_op = prefix_op("!sv_eq");
799 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
800 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
801 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
802 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
803 my $eq_op = infix_op("==");
804 my $ne_op = infix_op("!=");
805 my $lt_op = infix_op("<");
806 my $gt_op = infix_op(">");
807 my $le_op = infix_op("<=");
808 my $ge_op = infix_op(">=");
811 # XXX The standard perl PP code has extra handling for
812 # some special case arguments of these operators.
814 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
815 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
816 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
817 sub pp_divide { numeric_binop($_[0], $divide_op) }
818 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
819 sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
821 sub pp_left_shift { int_binop($_[0], $lshift_op) }
822 sub pp_right_shift { int_binop($_[0], $rshift_op) }
823 sub pp_i_add { int_binop($_[0], $plus_op) }
824 sub pp_i_subtract { int_binop($_[0], $minus_op) }
825 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
826 sub pp_i_divide { int_binop($_[0], $divide_op) }
827 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
829 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
830 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
831 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
832 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
833 sub pp_le { bool_numeric_binop($_[0], $le_op) }
834 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
836 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
837 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
838 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
839 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
840 sub pp_i_le { bool_int_binop($_[0], $le_op) }
841 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
843 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
844 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
845 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
846 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
847 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
848 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
849 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
855 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
860 ($src, $dst) = ($dst, $src) if $backwards;
861 my $type = $src->{type};
862 if ($type == T_INT) {
863 $dst->set_int($src->as_int);
864 } elsif ($type == T_DOUBLE) {
865 $dst->set_numeric($src->as_numeric);
867 $dst->set_sv($src->as_sv);
870 } elsif (@stack == 1) {
872 my $src = pop @stack;
873 my $type = $src->{type};
874 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
875 if ($type == T_INT) {
876 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
877 } elsif ($type == T_DOUBLE) {
878 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
880 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
882 runtime("SvSETMAGIC(TOPs);");
884 my $dst = $stack[-1];
885 my $type = $dst->{type};
886 runtime("sv = POPs;");
887 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
888 if ($type == T_INT) {
889 $dst->set_int("SvIV(sv)");
890 } elsif ($type == T_DOUBLE) {
891 $dst->set_double("SvNV(sv)");
893 runtime("SvSetSV($dst->{sv}, sv);");
899 runtime("src = POPs; dst = TOPs;");
901 runtime("dst = POPs; src = TOPs;");
903 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
904 "SvSetSV(dst, src);",
914 my $obj = $stack[-1];
915 my $type = $obj->{type};
916 if ($type == T_INT || $type == T_DOUBLE) {
917 $obj->set_int($obj->as_int . " + 1");
919 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
923 runtime sprintf("PP_PREINC(TOPs);");
931 runtime("PUSHMARK(sp);");
938 my $gimme = gimme($op);
939 if ($gimme == 1) { # sic
940 runtime("POPMARK;"); # need this even though not a "full" pp_list
942 runtime("PP_LIST($gimme);");
949 write_back_lexicals(REGISTER|TEMPORARY);
952 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
953 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
954 runtime("SPAGAIN;}");
956 invalidate_lexicals(REGISTER|TEMPORARY);
963 my $ppname = $op->ppaddr;
964 write_back_lexicals() unless $skip_lexicals{$ppname};
965 write_back_stack() unless $skip_stack{$ppname};
967 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
968 invalidate_lexicals() unless $skip_invalidate{$ppname};
978 write_back_lexicals(REGISTER|TEMPORARY);
981 # XXX Is this the right way to distinguish between it returning
982 # CvSTART(cv) (via doform) and pop_return()?
983 runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
986 invalidate_lexicals(REGISTER|TEMPORARY);
993 write_back_lexicals(REGISTER|TEMPORARY);
995 my $sym = loadop($op);
996 my $ppaddr = $op->ppaddr;
997 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
999 invalidate_lexicals(REGISTER|TEMPORARY);
1003 sub pp_entereval { doeval(@_) }
1004 sub pp_require { doeval(@_) }
1005 sub pp_dofile { doeval(@_) }
1009 $curcop->write_back;
1010 write_back_lexicals(REGISTER|TEMPORARY);
1012 my $sym = doop($op);
1013 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1014 declare("Sigjmp_buf", $jmpbuf);
1015 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1016 invalidate_lexicals(REGISTER|TEMPORARY);
1022 if ($need_freetmps && $freetmps_each_loop) {
1023 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1028 return $op->next->other;
1033 if ($need_freetmps && $freetmps_each_loop) {
1034 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1039 return $op->next->other;
1044 my $next = $op->next;
1045 unshift(@bblock_todo, $next);
1046 write_back_lexicals();
1048 my $sym = doop($op);
1049 # pp_grepwhile can return either op_next or op_other and we need to
1050 # be able to distinguish the two at runtime. Since it's possible for
1051 # both ops to be "inlined", the fields could both be zero. To get
1052 # around that, we hack op_next to be our own op (purely because we
1053 # know it's a non-NULL pointer and can't be the same as op_other).
1054 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1055 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1066 write_back_lexicals(REGISTER|TEMPORARY);
1069 runtime("PUTBACK;", "return PL_op;");
1076 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1077 return default_pp($op);
1082 my $flags = $op->flags;
1083 if (!($flags & OPf_KNOW)) {
1084 error("context of range unknown at compile-time");
1086 write_back_lexicals();
1088 if (!($flags & OPf_LIST)) {
1089 # We need to save our UNOP structure since pp_flop uses
1090 # it to find and adjust out targ. We don't need it ourselves.
1092 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1093 $op->targ, label($op->false));
1094 unshift(@bblock_todo, $op->false);
1101 my $flags = $op->flags;
1102 if (!($flags & OPf_KNOW)) {
1103 error("context of flip unknown at compile-time");
1105 if ($flags & OPf_LIST) {
1106 return $op->first->false;
1108 write_back_lexicals();
1110 # We need to save our UNOP structure since pp_flop uses
1111 # it to find and adjust out targ. We don't need it ourselves.
1114 my $rangeix = $op->first->targ;
1115 runtime(($op->private & OPpFLIP_LINENUM) ?
1116 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1117 : "if (SvTRUE(TOPs)) {");
1118 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1119 if ($op->flags & OPf_SPECIAL) {
1120 runtime("sv_setiv(PL_curpad[$ix], 1);");
1122 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1124 sprintf("\tgoto %s;", label($op->first->false)));
1127 qq{sv_setpv(PL_curpad[$ix], "");},
1128 "SETs(PL_curpad[$ix]);");
1142 my $nextop = $op->nextop;
1143 my $lastop = $op->lastop;
1144 my $redoop = $op->redoop;
1145 $curcop->write_back;
1146 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1150 "label" => $curcop->[0]->label,
1158 return default_pp($op);
1161 sub pp_enterloop { enterloop(@_) }
1162 sub pp_enteriter { enterloop(@_) }
1167 die "panic: leaveloop";
1169 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1171 return default_pp($op);
1177 if ($op->flags & OPf_SPECIAL) {
1178 $cxix = dopoptoloop();
1180 error('"next" used outside loop');
1181 return $op->next; # ignore the op
1184 $cxix = dopoptolabel($op->pv);
1186 error('Label not found at compile time for "next %s"', $op->pv);
1187 return $op->next; # ignore the op
1191 my $nextop = $cxstack[$cxix]->{nextop};
1192 push(@bblock_todo, $nextop);
1193 runtime(sprintf("goto %s;", label($nextop)));
1200 if ($op->flags & OPf_SPECIAL) {
1201 $cxix = dopoptoloop();
1203 error('"redo" used outside loop');
1204 return $op->next; # ignore the op
1207 $cxix = dopoptolabel($op->pv);
1209 error('Label not found at compile time for "redo %s"', $op->pv);
1210 return $op->next; # ignore the op
1214 my $redoop = $cxstack[$cxix]->{redoop};
1215 push(@bblock_todo, $redoop);
1216 runtime(sprintf("goto %s;", label($redoop)));
1223 if ($op->flags & OPf_SPECIAL) {
1224 $cxix = dopoptoloop();
1226 error('"last" used outside loop');
1227 return $op->next; # ignore the op
1230 $cxix = dopoptolabel($op->pv);
1232 error('Label not found at compile time for "last %s"', $op->pv);
1233 return $op->next; # ignore the op
1235 # XXX Add support for "last" to leave non-loop blocks
1236 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1237 error('Use of "last" for non-loop blocks is not yet implemented');
1238 return $op->next; # ignore the op
1242 my $lastop = $cxstack[$cxix]->{lastop}->next;
1243 push(@bblock_todo, $lastop);
1244 runtime(sprintf("goto %s;", label($lastop)));
1250 write_back_lexicals();
1252 my $sym = doop($op);
1253 my $replroot = $op->pmreplroot;
1255 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1256 $sym, label($replroot));
1257 $op->pmreplstart->save;
1258 push(@bblock_todo, $replroot);
1260 invalidate_lexicals();
1266 write_back_lexicals();
1269 my $pmop = $op->other;
1270 # warn sprintf("substcont: op = %s, pmop = %s\n",
1271 # peekop($op), peekop($pmop));#debug
1272 # my $pmopsym = objsym($pmop);
1273 my $pmopsym = $pmop->save; # XXX can this recurse?
1274 # warn "pmopsym = $pmopsym\n";#debug
1275 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1276 $pmopsym, label($pmop->pmreplstart));
1277 invalidate_lexicals();
1283 my $ppname = $op->ppaddr;
1284 if ($curcop and $need_curcop{$ppname}){
1285 $curcop->write_back;
1287 write_back_lexicals() unless $skip_lexicals{$ppname};
1288 write_back_stack() unless $skip_stack{$ppname};
1290 # XXX If the only way that ops can write to a TEMPORARY lexical is
1291 # when it's named in $op->targ then we could call
1292 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1293 # the temporaries. For now, we'll play it safe and write back the lot.
1294 invalidate_lexicals() unless $skip_invalidate{$ppname};
1300 my $ppname = $op->ppaddr;
1301 if (exists $ignore_op{$ppname}) {
1304 debug peek_stack() if $debug_stack;
1306 debug sprintf("%s [%s]\n",
1308 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1311 if (defined(&$ppname)) {
1313 return &$ppname($op);
1315 return default_pp($op);
1319 sub compile_bblock {
1321 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1325 $op = compile_op($op);
1326 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1327 write_back_stack(); # boo hoo: big loss
1333 my ($name, $root, $start, @padlist) = @_;
1337 B::Pseudoreg->new_scope;
1339 if ($debug_timings) {
1340 warn sprintf("Basic block analysis at %s\n", timing_info);
1342 $leaders = find_leaders($root, $start);
1343 @bblock_todo = ($start, values %$leaders);
1344 if ($debug_timings) {
1345 warn sprintf("Compilation at %s\n", timing_info);
1347 while (@bblock_todo) {
1348 $op = shift @bblock_todo;
1349 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1350 next if !defined($op) || !$$op || $done{$$op};
1351 #warn "...compiling it\n"; # debug
1354 $op = compile_bblock($op);
1355 if ($need_freetmps && $freetmps_each_bblock) {
1356 runtime("FREETMPS;");
1359 } while defined($op) && $$op && !$done{$$op};
1360 if ($need_freetmps && $freetmps_each_loop) {
1361 runtime("FREETMPS;");
1365 runtime("PUTBACK;","return PL_op;");
1366 } elsif ($done{$$op}) {
1367 runtime(sprintf("goto %s;", label($op)));
1370 if ($debug_timings) {
1371 warn sprintf("Saving runtime at %s\n", timing_info);
1379 $start = cc_queue(@_) if @_;
1380 while ($ccinfo = shift @cc_todo) {
1387 my ($name, $cvref) = @_;
1388 my $cv = svref_2object($cvref);
1389 my @padlist = $cv->PADLIST->ARRAY;
1390 my $curpad_sym = $padlist[1]->save;
1391 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1395 my @comppadlist = comppadlist->ARRAY;
1396 my $curpad_nam = $comppadlist[0]->save;
1397 my $curpad_sym = $comppadlist[1]->save;
1398 my $init_av = init_av->save;
1399 my $inc_hv = svref_2object(\%INC)->save;
1400 my $inc_av = svref_2object(\@INC)->save;
1401 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1406 if (!defined($module)) {
1407 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1408 "PL_main_start = $start;",
1409 "PL_curpad = AvARRAY($curpad_sym);",
1410 "PL_initav = $init_av;",
1411 "GvHV(PL_incgv) = $inc_hv;",
1412 "GvAV(PL_incgv) = $inc_av;",
1413 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1414 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1418 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
1419 output_boilerplate();
1421 output_all("perl_init");
1425 if (defined($module)) {
1426 my $cmodule = $module;
1427 $cmodule =~ s/::/__/g;
1437 SAVESPTR(PL_curpad);
1439 PL_curpad = AvARRAY($curpad_sym);
1449 if ($debug_timings) {
1450 warn sprintf("Done at %s\n", timing_info);
1456 my ($option, $opt, $arg);
1458 while ($option = shift @options) {
1459 if ($option =~ /^-(.)(.*)/) {
1463 unshift @options, $option;
1466 if ($opt eq "-" && $arg eq "-") {
1469 } elsif ($opt eq "o") {
1470 $arg ||= shift @options;
1471 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1472 } elsif ($opt eq "n") {
1473 $arg ||= shift @options;
1474 $module_name = $arg;
1475 } elsif ($opt eq "u") {
1476 $arg ||= shift @options;
1477 mark_unused($arg,undef);
1478 } elsif ($opt eq "f") {
1479 $arg ||= shift @options;
1480 my $value = $arg !~ s/^no-//;
1482 my $ref = $optimise{$arg};
1483 if (defined($ref)) {
1486 warn qq(ignoring unknown optimisation option "$arg"\n);
1488 } elsif ($opt eq "O") {
1489 $arg = 1 if $arg eq "";
1491 foreach $ref (values %optimise) {
1495 $freetmps_each_loop = 1;
1498 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1500 } elsif ($opt eq "m") {
1501 $arg ||= shift @options;
1503 mark_unused($arg,undef);
1504 } elsif ($opt eq "p") {
1505 $arg ||= shift @options;
1507 } elsif ($opt eq "D") {
1508 $arg ||= shift @options;
1509 foreach $arg (split(//, $arg)) {
1512 } elsif ($arg eq "O") {
1514 } elsif ($arg eq "s") {
1516 } elsif ($arg eq "c") {
1518 } elsif ($arg eq "p") {
1520 } elsif ($arg eq "r") {
1522 } elsif ($arg eq "S") {
1524 } elsif ($arg eq "q") {
1526 } elsif ($arg eq "l") {
1528 } elsif ($arg eq "t") {
1535 $init = B::Section->get("init");
1536 $decl = B::Section->get("decl");
1540 my ($objname, $ppname);
1541 foreach $objname (@options) {
1542 $objname = "main::$objname" unless $objname =~ /::/;
1543 ($ppname = $objname) =~ s/^.*?:://;
1544 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1545 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1548 output_boilerplate();
1550 output_all($module_name || "init_module");
1554 return sub { cc_main() };
1564 B::CC - Perl compiler's optimized C translation backend
1568 perl -MO=CC[,OPTIONS] foo.pl
1572 This compiler backend takes Perl source and generates C source code
1573 corresponding to the flow of your program. In other words, this
1574 backend is somewhat a "real" compiler in the sense that many people
1575 think about compilers. Note however that, currently, it is a very
1576 poor compiler in that although it generates (mostly, or at least
1577 sometimes) correct code, it performs relatively few optimisations.
1578 This will change as the compiler develops. The result is that
1579 running an executable compiled with this backend may start up more
1580 quickly than running the original Perl program (a feature shared
1581 by the B<C> compiler backend--see F<B::C>) and may also execute
1582 slightly faster. This is by no means a good optimising compiler--yet.
1586 If there are any non-option arguments, they are taken to be
1587 names of objects to be saved (probably doesn't work properly yet).
1588 Without extra arguments, it saves the main program.
1594 Output to filename instead of STDOUT
1598 Verbose compilation (currently gives a few compilation statistics).
1602 Force end of options
1606 Force apparently unused subs from package Packname to be compiled.
1607 This allows programs to use eval "foo()" even when sub foo is never
1608 seen to be used at compile time. The down side is that any subs which
1609 really are never used also have code generated. This option is
1610 necessary, for example, if you have a signal handler foo which you
1611 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1612 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1613 options. The compiler tries to figure out which packages may possibly
1614 have subs in which need compiling but the current version doesn't do
1615 it very well. In particular, it is confused by nested packages (i.e.
1616 of the form C<A::B>) where package C<A> does not contain any subs.
1618 =item B<-mModulename>
1620 Instead of generating source for a runnable executable, generate
1621 source for an XSUB module. The boot_Modulename function (which
1622 DynaLoader can look for) does the appropriate initialisation and runs
1623 the main part of the Perl source that is being compiled.
1628 Debug options (concatenated or separate flags like C<perl -D>).
1632 Writes debugging output to STDERR just as it's about to write to the
1633 program's runtime (otherwise writes debugging info as comments in
1638 Outputs each OP as it's compiled
1642 Outputs the contents of the shadow stack at each OP
1646 Outputs the contents of the shadow pad of lexicals as it's loaded for
1647 each sub or the main program.
1651 Outputs the name of each fake PP function in the queue as it's about
1656 Output the filename and line number of each original line of Perl
1657 code as it's processed (C<pp_nextstate>).
1661 Outputs timing information of compilation stages.
1665 Force optimisations on or off one at a time.
1667 =item B<-ffreetmps-each-bblock>
1669 Delays FREETMPS from the end of each statement to the end of the each
1672 =item B<-ffreetmps-each-loop>
1674 Delays FREETMPS from the end of each statement to the end of the group
1675 of basic blocks forming a loop. At most one of the freetmps-each-*
1676 options can be used.
1678 =item B<-fomit-taint>
1680 Omits generating code for handling perl's tainting mechanism.
1684 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1685 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1686 sets B<-ffreetmps-each-loop>.
1692 perl -MO=CC,-O2,-ofoo.c foo.pl
1693 perl cc_harness -o foo foo.c
1695 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1696 library directory. The utility called C<perlcc> may also be used to
1697 help make use of this compiler.
1699 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1700 perl cc_harness -shared -c -o Foo.so Foo.c
1704 Plenty. Current status: experimental.
1708 These aren't really bugs but they are constructs which are heavily
1709 tied to perl's compile-and-go implementation and with which this
1710 compiler backend cannot cope.
1714 Standard perl calculates the target of "next", "last", and "redo"
1715 at run-time. The compiler calculates the targets at compile-time.
1716 For example, the program
1718 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1719 NUMBER: for ($i = 0; $i < 5; $i++) {
1728 with standard perl but gives a compile-time error with the compiler.
1730 =head2 Context of ".."
1732 The context (scalar or array) of the ".." operator determines whether
1733 it behaves as a range or a flip/flop. Standard perl delays until
1734 runtime the decision of which context it is in but the compiler needs
1735 to know the context at compile-time. For example,
1738 sub range { (shift @a)..(shift @a) }
1740 while (@a) { print scalar(range()) }
1742 generates the output
1746 with standard Perl but gives a compile-time error with compiled Perl.
1750 Compiled Perl programs use native C arithemtic much more frequently
1751 than standard perl. Operations on large numbers or on boundary
1752 cases may produce different behaviour.
1754 =head2 Deprecated features
1756 Features of standard perl such as C<$[> which have been deprecated
1757 in standard perl since Perl5 was released have not been implemented
1762 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>