3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
5 # You may distribute under the terms of either the GNU General Public
6 # License or the Artistic License, as specified in the README file.
10 use B qw(main_start main_root class comppadlist peekop svref_2object
11 timing_info init_av sv_undef amagic_generation
12 OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
13 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
14 OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
15 CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
17 use B::C qw(save_unused_subs objsym init_sections mark_unused
18 output_all output_boilerplate output_main);
19 use B::Bblock qw(find_leaders);
20 use B::Stackobj qw(:types :flags);
22 # These should probably be elsewhere
23 # Flags for $op->flags
25 my $module; # module name (when compiled with -m)
26 my %done; # hash keyed by $$op of leaders of basic blocks
27 # which have already been done.
28 my $leaders; # ref to hash of basic block leaders. Keys are $$op
29 # addresses, values are the $op objects themselves.
30 my @bblock_todo; # list of leaders of basic blocks that need visiting
32 my @cc_todo; # list of tuples defining what PP code needs to be
33 # saved (e.g. CV, main or PMOP repl code). Each tuple
34 # is [$name, $root, $start, @padlist]. PMOP repl code
35 # tuples inherit padlist.
36 my @stack; # shadows perl's stack when contents are known.
37 # Values are objects derived from class B::Stackobj
38 my @pad; # Lexicals in current pad as Stackobj-derived objects
39 my @padlist; # Copy of current padlist so PMOP repl code can find it
40 my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
41 my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
42 my %constobj; # OP_CONST constants as Stackobj-derived objects
44 my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
45 # block or even to the end of each loop of blocks,
46 # depending on optimisation options.
47 my $know_op = 0; # Set when C variable op already holds the right op
48 # (from an immediately preceding DOOP(ppname)).
49 my $errors = 0; # Number of errors encountered
50 my %skip_stack; # Hash of PP names which don't need write_back_stack
51 my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
52 my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
53 my %ignore_op; # Hash of ops which do nothing except returning op_next
54 my %need_curcop; # Hash of ops which need PL_curcop
56 my %lexstate; #state of padsvs at the start of a bblock
59 foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
65 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
66 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
68 # Optimisation options. On the command line, use hyphens instead of
69 # underscores for compatibility with gcc-style options. We use
70 # underscores here because they are OK in (strict) barewords.
71 my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
72 my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
73 freetmps_each_loop => \$freetmps_each_loop,
74 omit_taint => \$omit_taint);
75 # perl patchlevel to generate code for (defaults to current patchlevel)
76 my $patchlevel = int(0.5 + 1000 * ($] - 5));
78 # Could rewrite push_runtime() and output_runtime() to use a
79 # temporary file if memory is at a premium.
80 my $ppname; # name of current fake PP function
82 my $declare_ref; # Hash ref keyed by C variable type of declarations.
84 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
85 # tuples to be written out.
89 sub init_hash { map { $_ => 1 } @_ }
92 # Initialise the hashes for the default PP functions where we can avoid
93 # either write_back_stack, write_back_lexicals or invalidate_lexicals.
95 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
96 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
97 %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
98 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
99 pp_entertry pp_enterloop pp_enteriter pp_entersub
103 if ($debug_runtime) {
107 runtime(map { chomp; "/* $_ */"} @tmp);
112 my ($type, $var) = @_;
113 push(@{$declare_ref->{$type}}, $var);
117 push(@$runtime_list_ref, @_);
118 warn join("\n", @_) . "\n" if $debug_runtime;
122 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
127 print qq(#include "cc_runtime.h"\n);
128 foreach $ppdata (@pp_list) {
129 my ($name, $runtime, $declare) = @$ppdata;
130 print "\nstatic\nCCPP($name)\n{\n";
131 my ($type, $varlist, $line);
132 while (($type, $varlist) = each %$declare) {
133 print "\t$type ", join(", ", @$varlist), ";\n";
135 foreach $line (@$runtime) {
145 push_runtime("\t$line");
151 $runtime_list_ref = [];
154 declare("I32", "oldsave");
155 declare("SV", "**svp");
156 map { declare("SV", "*$_") } qw(sv src dst left right);
157 declare("MAGIC", "*mg");
158 $decl->add("static OP * $ppname (pTHX);");
159 debug "init_pp: $ppname\n" if $debug_queue;
162 # Initialise runtime_callback function for Stackobj class
163 BEGIN { B::Stackobj::set_callback(\&runtime) }
165 # Initialise saveoptree_callback for B::C class
167 my ($name, $root, $start, @pl) = @_;
168 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
170 if ($name eq "*ignore*") {
173 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
175 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
176 $start = $fakeop->save;
177 debug "cc_queue: name $name returns $start\n" if $debug_queue;
180 BEGIN { B::C::set_callback(\&cc_queue) }
182 sub valid_int { $_[0]->{flags} & VALID_INT }
183 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
184 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
185 sub valid_sv { $_[0]->{flags} & VALID_SV }
187 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
188 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
189 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
190 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
191 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
193 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
194 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
195 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
196 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
199 return ((pop @stack)->as_bool);
201 # Careful: POPs has an auto-decrement and SvTRUE evaluates
202 # its argument more than once.
203 runtime("sv = POPs;");
208 sub write_back_lexicals {
209 my $avoid = shift || 0;
210 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
213 foreach $lex (@pad) {
214 next unless ref($lex);
215 $lex->write_back unless $lex->{flags} & $avoid;
219 sub save_or_restore_lexical_state {
221 unless( exists $lexstate{$bblock}){
222 foreach my $lex (@pad) {
223 next unless ref($lex);
224 ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
227 foreach my $lex (@pad) {
228 next unless ref($lex);
229 my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ;
230 next if ( $old_flags eq $lex->{flags});
231 if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){
234 if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
237 if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
244 sub write_back_stack {
246 return unless @stack;
247 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
248 foreach $obj (@stack) {
249 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
254 sub invalidate_lexicals {
255 my $avoid = shift || 0;
256 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
259 foreach $lex (@pad) {
260 next unless ref($lex);
261 $lex->invalidate unless $lex->{flags} & $avoid;
265 sub reload_lexicals {
267 foreach $lex (@pad) {
268 next unless ref($lex);
269 my $type = $lex->{type};
270 if ($type == T_INT) {
272 } elsif ($type == T_DOUBLE) {
281 package B::Pseudoreg;
283 # This class allocates pseudo-registers (OK, so they're C variables).
285 my %alloc; # Keyed by variable name. A value of 1 means the
286 # variable has been declared. A value of 2 means
289 sub new_scope { %alloc = () }
292 my ($class, $type, $prefix) = @_;
293 my ($ptr, $i, $varname, $status, $obj);
294 $prefix =~ s/^(\**)//;
298 $varname = "$prefix$i";
299 $status = $alloc{$varname};
300 } while $status == 2;
303 B::CC::declare($type, "$ptr$varname");
304 $alloc{$varname} = 2; # declared and in use
306 $obj = bless \$varname, $class;
311 $alloc{$$obj} = 1; # no longer in use but still declared
317 # This class gives a standard API for a perl object to shadow a
318 # C variable and only generate reloads/write-backs when necessary.
320 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
321 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
322 # Use $obj->invalidate whenever an unknown function may have
326 my ($class, $write_back) = @_;
327 # Object fields are perl shadow variable, validity flag
328 # (for *C* variable) and callback sub for write_back
329 # (passed perl shadow variable as argument).
330 bless [undef, 1, $write_back], $class;
333 my ($obj, $newval) = @_;
334 $obj->[1] = 0; # C variable no longer valid
340 $obj->[1] = 1; # C variable will now be valid
341 &{$obj->[2]}($obj->[0]);
344 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
346 my $curcop = new B::Shadow (sub {
347 my $opsym = shift->save;
348 runtime("PL_curcop = (COP*)$opsym;");
352 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
355 my $cxix = $#cxstack;
356 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
359 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
365 my $cxix = $#cxstack;
367 ($cxstack[$cxix]->{type} != CXt_LOOP ||
368 $cxstack[$cxix]->{label} ne $label)) {
371 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
377 my $file = $curcop->[0]->filegv->SV->PV;
378 my $line = $curcop->[0]->line;
381 warn sprintf("%s:%d: $format\n", $file, $line, @_);
383 warn sprintf("%s:%d: %s\n", $file, $line, $format);
388 # Load pad takes (the elements of) a PADLIST as arguments and loads
389 # up @pad with Stackobj-derived objects which represent those lexicals.
390 # If/when perl itself can generate type information (my int $foo) then
391 # we'll take advantage of that here. Until then, we'll use various hacks
392 # to tell the compiler when we want a lexical to be a particular type
393 # or to be a register.
396 my ($namelistav, $valuelistav) = @_;
398 my @namelist = $namelistav->ARRAY;
399 my @valuelist = $valuelistav->ARRAY;
402 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
403 # Temporary lexicals don't get named so it's possible for @valuelist
404 # to be strictly longer than @namelist. We count $ix up to the end of
405 # @valuelist but index into @namelist for the name. Any temporaries which
406 # run off the end of @namelist will make $namesv undefined and we treat
407 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
408 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
409 for ($ix = 1; $ix < @valuelist; $ix++) {
410 my $namesv = $namelist[$ix];
411 my $type = T_UNKNOWN;
414 my $class = class($namesv);
415 if (!defined($namesv) || $class eq "SPECIAL") {
416 # temporaries have &PL_sv_undef instead of a PVNV for a name
417 $flags = VALID_SV|TEMPORARY|REGISTER;
419 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
423 $flags = VALID_SV|VALID_INT;
424 } elsif ($2 eq "d") {
426 $flags = VALID_SV|VALID_DOUBLE;
428 $flags |= REGISTER if $3;
431 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
432 "i_$name", "d_$name");
434 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
440 for ($ix = 1; $ix <= $#pad; $ix++) {
441 my $type = $pad[$ix]->{type};
442 declare("IV", $type == T_INT ?
443 sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
444 declare("double", $type == T_DOUBLE ?
445 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
452 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
460 # XXX Preserve original label name for "real" labels?
461 return sprintf("lab_%x", $$op);
466 push_runtime(sprintf(" %s:", label($op)));
471 my $opsym = $op->save;
472 runtime("PL_op = $opsym;") unless $know_op;
478 my $ppname = $op->ppaddr;
479 my $sym = loadop($op);
480 runtime("DOOP($ppname);");
487 my $flags = $op->flags;
488 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
492 # Code generation for PP code
502 my $gimme = gimme($op);
503 if ($gimme != G_ARRAY) {
504 my $obj= new B::Stackobj::Const(sv_undef);
506 # XXX Change to push a constant sv_undef Stackobj onto @stack
508 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
516 runtime("PP_UNSTACK;");
522 my $next = $op->next;
524 unshift(@bblock_todo, $next);
526 my $bool = pop_bool();
528 save_or_restore_lexical_state($$next);
529 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
531 save_or_restore_lexical_state($$next);
532 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
540 my $next = $op->next;
542 unshift(@bblock_todo, $next);
544 my $bool = pop_bool @stack;
546 save_or_restore_lexical_state($$next);
547 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
548 $bool, label($next)));
550 save_or_restore_lexical_state($$next);
551 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
559 my $false = $op->next;
560 unshift(@bblock_todo, $false);
562 my $bool = pop_bool();
564 save_or_restore_lexical_state($$false);
565 runtime(sprintf("if (!$bool) goto %s;", label($false)));
572 push(@stack, $pad[$ix]);
573 if ($op->flags & OPf_MOD) {
574 my $private = $op->private;
575 if ($private & OPpLVAL_INTRO) {
576 runtime("SAVECLEARSV(PL_curpad[$ix]);");
577 } elsif ($private & OPpDEREF) {
578 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
579 $ix, $private & OPpDEREF));
580 $pad[$ix]->invalidate;
589 my $obj = $constobj{$$sv};
590 if (!defined($obj)) {
591 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
601 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
602 runtime("TAINT_NOT;") unless $omit_taint;
603 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
604 if ($freetmps_each_bblock || $freetmps_each_loop) {
607 runtime("FREETMPS;");
614 $curcop->invalidate; # XXX?
615 return default_pp($op);
618 #default_pp will handle this:
619 #sub pp_bless { $curcop->write_back; default_pp(@_) }
620 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
621 # The following subs need $curcop->write_back if we decide to support arybase:
622 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
623 #sub pp_caller { $curcop->write_back; default_pp(@_) }
624 #sub pp_reset { $curcop->write_back; default_pp(@_) }
629 write_back_lexicals() unless $skip_lexicals{$ppname};
630 write_back_stack() unless $skip_stack{$ppname};
632 if ($op->private & OPpDEREF) {
633 $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
634 $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
641 my $ppname = $op->ppaddr;
642 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
643 #this indicates the sort BLOCK Array case
644 #ugly surgery required.
645 my $root=$op->first->sibling->first;
646 my $start=$root->first;
648 $op->first->sibling->save;
650 my $sym=$start->save;
651 my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
652 $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
655 write_back_lexicals();
662 my $gvsym = $op->gv->save;
664 runtime("XPUSHs((SV*)$gvsym);");
670 my $gvsym = $op->gv->save;
672 if ($op->private & OPpLVAL_INTRO) {
673 runtime("XPUSHs(save_scalar($gvsym));");
675 runtime("XPUSHs(GvSV($gvsym));");
682 my $gvsym = $op->gv->save;
683 my $ix = $op->private;
684 my $flag = $op->flags & OPf_MOD;
686 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
687 "PUSHs(svp ? *svp : &PL_sv_undef);");
692 my ($op, $operator) = @_;
693 if ($op->flags & OPf_STACKED) {
694 my $right = pop_int();
696 my $left = top_int();
697 $stack[-1]->set_int(&$operator($left, $right));
699 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
702 my $targ = $pad[$op->targ];
703 my $right = new B::Pseudoreg ("IV", "riv");
704 my $left = new B::Pseudoreg ("IV", "liv");
705 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
706 $targ->set_int(&$operator($$left, $$right));
712 sub INTS_CLOSED () { 0x1 }
713 sub INT_RESULT () { 0x2 }
714 sub NUMERIC_RESULT () { 0x4 }
717 my ($op, $operator, $flags) = @_;
719 $force_int ||= ($flags & INT_RESULT);
720 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
721 && valid_int($stack[-2]) && valid_int($stack[-1]));
722 if ($op->flags & OPf_STACKED) {
723 my $right = pop_numeric();
725 my $left = top_numeric();
727 $stack[-1]->set_int(&$operator($left, $right));
729 $stack[-1]->set_numeric(&$operator($left, $right));
733 my $rightruntime = new B::Pseudoreg ("IV", "riv");
734 runtime(sprintf("$$rightruntime = %s;",$right));
735 runtime(sprintf("sv_setiv(TOPs, %s);",
736 &$operator("TOPi", $$rightruntime)));
738 my $rightruntime = new B::Pseudoreg ("double", "rnv");
739 runtime(sprintf("$$rightruntime = %s;",$right));
740 runtime(sprintf("sv_setnv(TOPs, %s);",
741 &$operator("TOPn",$$rightruntime)));
745 my $targ = $pad[$op->targ];
746 $force_int ||= ($targ->{type} == T_INT);
748 my $right = new B::Pseudoreg ("IV", "riv");
749 my $left = new B::Pseudoreg ("IV", "liv");
750 runtime(sprintf("$$right = %s; $$left = %s;",
751 pop_numeric(), pop_numeric));
752 $targ->set_int(&$operator($$left, $$right));
754 my $right = new B::Pseudoreg ("double", "rnv");
755 my $left = new B::Pseudoreg ("double", "lnv");
756 runtime(sprintf("$$right = %s; $$left = %s;",
757 pop_numeric(), pop_numeric));
758 $targ->set_numeric(&$operator($$left, $$right));
767 if ($op->flags & OPf_STACKED) {
768 my $right = pop_numeric();
770 my $left = top_numeric();
771 runtime sprintf("if (%s > %s){",$left,$right);
772 $stack[-1]->set_int(1);
773 $stack[-1]->write_back();
774 runtime sprintf("}else if (%s < %s ) {",$left,$right);
775 $stack[-1]->set_int(-1);
776 $stack[-1]->write_back();
777 runtime sprintf("}else if (%s == %s) {",$left,$right);
778 $stack[-1]->set_int(0);
779 $stack[-1]->write_back();
780 runtime sprintf("}else {");
781 $stack[-1]->set_sv("&PL_sv_undef");
784 my $rightruntime = new B::Pseudoreg ("double", "rnv");
785 runtime(sprintf("$$rightruntime = %s;",$right));
786 runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
787 runtime sprintf("sv_setiv(TOPs,1);");
788 runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
789 runtime sprintf("sv_setiv(TOPs,-1);");
790 runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
791 runtime sprintf("sv_setiv(TOPs,0);");
792 runtime sprintf(qq/}else {/);
793 runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
797 my $targ = $pad[$op->targ];
798 my $right = new B::Pseudoreg ("double", "rnv");
799 my $left = new B::Pseudoreg ("double", "lnv");
800 runtime(sprintf("$$right = %s; $$left = %s;",
801 pop_numeric(), pop_numeric));
802 runtime sprintf("if (%s > %s){",$$left,$$right);
805 runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
808 runtime sprintf("}else if (%s == %s) {",$$left,$$right);
811 runtime sprintf("}else {");
812 $targ->set_sv("&PL_sv_undef");
820 my ($op, $operator, $flags) = @_;
821 if ($op->flags & OPf_STACKED) {
822 my $right = pop_sv();
825 if ($flags & INT_RESULT) {
826 $stack[-1]->set_int(&$operator($left, $right));
827 } elsif ($flags & NUMERIC_RESULT) {
828 $stack[-1]->set_numeric(&$operator($left, $right));
830 # XXX Does this work?
831 runtime(sprintf("sv_setsv($left, %s);",
832 &$operator($left, $right)));
833 $stack[-1]->invalidate;
837 if ($flags & INT_RESULT) {
839 } elsif ($flags & NUMERIC_RESULT) {
844 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
847 my $targ = $pad[$op->targ];
848 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
849 if ($flags & INT_RESULT) {
850 $targ->set_int(&$operator("left", "right"));
851 } elsif ($flags & NUMERIC_RESULT) {
852 $targ->set_numeric(&$operator("left", "right"));
854 # XXX Does this work?
855 runtime(sprintf("sv_setsv(%s, %s);",
856 $targ->as_sv, &$operator("left", "right")));
865 my ($op, $operator) = @_;
866 my $right = new B::Pseudoreg ("IV", "riv");
867 my $left = new B::Pseudoreg ("IV", "liv");
868 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
869 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
870 $bool->set_int(&$operator($$left, $$right));
875 sub bool_numeric_binop {
876 my ($op, $operator) = @_;
877 my $right = new B::Pseudoreg ("double", "rnv");
878 my $left = new B::Pseudoreg ("double", "lnv");
879 runtime(sprintf("$$right = %s; $$left = %s;",
880 pop_numeric(), pop_numeric()));
881 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
882 $bool->set_numeric(&$operator($$left, $$right));
888 my ($op, $operator) = @_;
889 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
890 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
891 $bool->set_numeric(&$operator("left", "right"));
898 return sub { "$_[0] $opname $_[1]" }
903 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
907 my $plus_op = infix_op("+");
908 my $minus_op = infix_op("-");
909 my $multiply_op = infix_op("*");
910 my $divide_op = infix_op("/");
911 my $modulo_op = infix_op("%");
912 my $lshift_op = infix_op("<<");
913 my $rshift_op = infix_op(">>");
914 my $scmp_op = prefix_op("sv_cmp");
915 my $seq_op = prefix_op("sv_eq");
916 my $sne_op = prefix_op("!sv_eq");
917 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
918 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
919 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
920 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
921 my $eq_op = infix_op("==");
922 my $ne_op = infix_op("!=");
923 my $lt_op = infix_op("<");
924 my $gt_op = infix_op(">");
925 my $le_op = infix_op("<=");
926 my $ge_op = infix_op(">=");
929 # XXX The standard perl PP code has extra handling for
930 # some special case arguments of these operators.
932 sub pp_add { numeric_binop($_[0], $plus_op) }
933 sub pp_subtract { numeric_binop($_[0], $minus_op) }
934 sub pp_multiply { numeric_binop($_[0], $multiply_op) }
935 sub pp_divide { numeric_binop($_[0], $divide_op) }
936 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
938 sub pp_left_shift { int_binop($_[0], $lshift_op) }
939 sub pp_right_shift { int_binop($_[0], $rshift_op) }
940 sub pp_i_add { int_binop($_[0], $plus_op) }
941 sub pp_i_subtract { int_binop($_[0], $minus_op) }
942 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
943 sub pp_i_divide { int_binop($_[0], $divide_op) }
944 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
946 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
947 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
948 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
949 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
950 sub pp_le { bool_numeric_binop($_[0], $le_op) }
951 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
953 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
954 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
955 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
956 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
957 sub pp_i_le { bool_int_binop($_[0], $le_op) }
958 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
960 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
961 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
962 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
963 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
964 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
965 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
966 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
972 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
977 ($src, $dst) = ($dst, $src) if $backwards;
978 my $type = $src->{type};
979 if ($type == T_INT) {
980 $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
981 } elsif ($type == T_DOUBLE) {
982 $dst->set_numeric($src->as_numeric);
984 $dst->set_sv($src->as_sv);
987 } elsif (@stack == 1) {
989 my $src = pop @stack;
990 my $type = $src->{type};
991 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
992 if ($type == T_INT) {
993 if ($src->{flags} & VALID_UNSIGNED){
994 runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
996 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
998 } elsif ($type == T_DOUBLE) {
999 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
1001 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
1003 runtime("SvSETMAGIC(TOPs);");
1005 my $dst = $stack[-1];
1006 my $type = $dst->{type};
1007 runtime("sv = POPs;");
1008 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
1009 if ($type == T_INT) {
1010 $dst->set_int("SvIV(sv)");
1011 } elsif ($type == T_DOUBLE) {
1012 $dst->set_double("SvNV(sv)");
1014 runtime("SvSetMagicSV($dst->{sv}, sv);");
1020 runtime("src = POPs; dst = TOPs;");
1022 runtime("dst = POPs; src = TOPs;");
1024 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
1025 "SvSetSV(dst, src);",
1035 my $obj = $stack[-1];
1036 my $type = $obj->{type};
1037 if ($type == T_INT || $type == T_DOUBLE) {
1038 $obj->set_int($obj->as_int . " + 1");
1040 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
1044 runtime sprintf("PP_PREINC(TOPs);");
1053 runtime("PUSHMARK(sp);");
1060 my $gimme = gimme($op);
1061 if ($gimme == G_ARRAY) { # sic
1062 runtime("POPMARK;"); # need this even though not a "full" pp_list
1064 runtime("PP_LIST($gimme);");
1071 $curcop->write_back;
1072 write_back_lexicals(REGISTER|TEMPORARY);
1074 my $sym = doop($op);
1075 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1076 runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
1077 runtime("SPAGAIN;}");
1079 invalidate_lexicals(REGISTER|TEMPORARY);
1084 my $ppname = $op->ppaddr;
1085 write_back_lexicals() unless $skip_lexicals{$ppname};
1086 write_back_stack() unless $skip_stack{$ppname};
1088 # See comment in pp_grepwhile to see why!
1089 $init->add("((LISTOP*)$sym)->op_first = $sym;");
1090 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1091 save_or_restore_lexical_state(${$op->first});
1092 runtime( sprintf("goto %s;",label($op->first)));
1100 my $ppname = $op->ppaddr;
1101 write_back_lexicals() unless $skip_lexicals{$ppname};
1102 write_back_stack() unless $skip_stack{$ppname};
1104 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
1105 invalidate_lexicals() unless $skip_invalidate{$ppname};
1114 write_back_lexicals() unless $skip_lexicals{$ppname};
1115 write_back_stack() unless $skip_stack{$ppname};
1116 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
1117 runtime("\tPUTBACK;return 0;");
1124 write_back_lexicals(REGISTER|TEMPORARY);
1126 my $sym = doop($op);
1127 # XXX Is this the right way to distinguish between it returning
1128 # CvSTART(cv) (via doform) and pop_return()?
1129 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
1130 runtime("SPAGAIN;");
1132 invalidate_lexicals(REGISTER|TEMPORARY);
1138 $curcop->write_back;
1139 write_back_lexicals(REGISTER|TEMPORARY);
1141 my $sym = loadop($op);
1142 my $ppaddr = $op->ppaddr;
1143 #runtime(qq/printf("$ppaddr type eval\n");/);
1144 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1146 invalidate_lexicals(REGISTER|TEMPORARY);
1150 sub pp_entereval { doeval(@_) }
1151 sub pp_dofile { doeval(@_) }
1153 #pp_require is protected by pp_entertry, so no protection for it.
1156 $curcop->write_back;
1157 write_back_lexicals(REGISTER|TEMPORARY);
1159 my $sym = doop($op);
1160 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1161 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
1162 runtime("SPAGAIN;}");
1164 invalidate_lexicals(REGISTER|TEMPORARY);
1171 $curcop->write_back;
1172 write_back_lexicals(REGISTER|TEMPORARY);
1174 my $sym = doop($op);
1175 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1176 declare("JMPENV", $jmpbuf);
1177 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1178 invalidate_lexicals(REGISTER|TEMPORARY);
1185 runtime("PP_LEAVETRY;");
1191 if ($need_freetmps && $freetmps_each_loop) {
1192 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1199 my $nexttonext=$next->next;
1201 save_or_restore_lexical_state($$nexttonext);
1202 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1203 label($nexttonext)));
1204 return $op->next->other;
1209 if ($need_freetmps && $freetmps_each_loop) {
1210 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1214 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1215 # we need to be able to distinguish the two at runtime.
1219 my $nexttonext=$next->next;
1221 save_or_restore_lexical_state($$nexttonext);
1222 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1223 label($nexttonext)));
1224 return $op->next->other;
1229 my $next = $op->next;
1230 unshift(@bblock_todo, $next);
1231 write_back_lexicals();
1233 my $sym = doop($op);
1234 # pp_grepwhile can return either op_next or op_other and we need to
1235 # be able to distinguish the two at runtime. Since it's possible for
1236 # both ops to be "inlined", the fields could both be zero. To get
1237 # around that, we hack op_next to be our own op (purely because we
1238 # know it's a non-NULL pointer and can't be the same as op_other).
1239 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1240 save_or_restore_lexical_state($$next);
1241 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1252 write_back_lexicals(REGISTER|TEMPORARY);
1255 runtime("PUTBACK;", "return PL_op;");
1262 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1263 return default_pp($op);
1268 my $flags = $op->flags;
1269 if (!($flags & OPf_WANT)) {
1270 error("context of range unknown at compile-time");
1272 write_back_lexicals();
1274 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
1275 # We need to save our UNOP structure since pp_flop uses
1276 # it to find and adjust out targ. We don't need it ourselves.
1278 save_or_restore_lexical_state(${$op->other});
1279 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1280 $op->targ, label($op->other));
1281 unshift(@bblock_todo, $op->other);
1288 my $flags = $op->flags;
1289 if (!($flags & OPf_WANT)) {
1290 error("context of flip unknown at compile-time");
1292 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1293 return $op->first->other;
1295 write_back_lexicals();
1297 # We need to save our UNOP structure since pp_flop uses
1298 # it to find and adjust out targ. We don't need it ourselves.
1301 my $rangeix = $op->first->targ;
1302 runtime(($op->private & OPpFLIP_LINENUM) ?
1303 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1304 : "if (SvTRUE(TOPs)) {");
1305 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1306 if ($op->flags & OPf_SPECIAL) {
1307 runtime("sv_setiv(PL_curpad[$ix], 1);");
1309 save_or_restore_lexical_state(${$op->first->other});
1310 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1312 sprintf("\tgoto %s;", label($op->first->other)));
1315 qq{sv_setpv(PL_curpad[$ix], "");},
1316 "SETs(PL_curpad[$ix]);");
1330 my $nextop = $op->nextop;
1331 my $lastop = $op->lastop;
1332 my $redoop = $op->redoop;
1333 $curcop->write_back;
1334 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1338 "label" => $curcop->[0]->label,
1346 return default_pp($op);
1349 sub pp_enterloop { enterloop(@_) }
1350 sub pp_enteriter { enterloop(@_) }
1355 die "panic: leaveloop";
1357 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1359 return default_pp($op);
1365 if ($op->flags & OPf_SPECIAL) {
1366 $cxix = dopoptoloop();
1368 error('"next" used outside loop');
1369 return $op->next; # ignore the op
1372 $cxix = dopoptolabel($op->pv);
1374 error('Label not found at compile time for "next %s"', $op->pv);
1375 return $op->next; # ignore the op
1379 my $nextop = $cxstack[$cxix]->{nextop};
1380 push(@bblock_todo, $nextop);
1381 save_or_restore_lexical_state($$nextop);
1382 runtime(sprintf("goto %s;", label($nextop)));
1389 if ($op->flags & OPf_SPECIAL) {
1390 $cxix = dopoptoloop();
1392 error('"redo" used outside loop');
1393 return $op->next; # ignore the op
1396 $cxix = dopoptolabel($op->pv);
1398 error('Label not found at compile time for "redo %s"', $op->pv);
1399 return $op->next; # ignore the op
1403 my $redoop = $cxstack[$cxix]->{redoop};
1404 push(@bblock_todo, $redoop);
1405 save_or_restore_lexical_state($$redoop);
1406 runtime(sprintf("goto %s;", label($redoop)));
1413 if ($op->flags & OPf_SPECIAL) {
1414 $cxix = dopoptoloop();
1416 error('"last" used outside loop');
1417 return $op->next; # ignore the op
1420 $cxix = dopoptolabel($op->pv);
1422 error('Label not found at compile time for "last %s"', $op->pv);
1423 return $op->next; # ignore the op
1425 # XXX Add support for "last" to leave non-loop blocks
1426 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1427 error('Use of "last" for non-loop blocks is not yet implemented');
1428 return $op->next; # ignore the op
1432 my $lastop = $cxstack[$cxix]->{lastop}->next;
1433 push(@bblock_todo, $lastop);
1434 save_or_restore_lexical_state($$lastop);
1435 runtime(sprintf("goto %s;", label($lastop)));
1441 write_back_lexicals();
1443 my $sym = doop($op);
1444 my $replroot = $op->pmreplroot;
1446 save_or_restore_lexical_state($$replroot);
1447 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1448 $sym, label($replroot));
1449 $op->pmreplstart->save;
1450 push(@bblock_todo, $replroot);
1452 invalidate_lexicals();
1458 write_back_lexicals();
1461 my $pmop = $op->other;
1462 # warn sprintf("substcont: op = %s, pmop = %s\n",
1463 # peekop($op), peekop($pmop));#debug
1464 # my $pmopsym = objsym($pmop);
1465 my $pmopsym = $pmop->save; # XXX can this recurse?
1466 # warn "pmopsym = $pmopsym\n";#debug
1467 save_or_restore_lexical_state(${$pmop->pmreplstart});
1468 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1469 $pmopsym, label($pmop->pmreplstart));
1470 invalidate_lexicals();
1476 my $ppname = "pp_" . $op->name;
1477 if ($curcop and $need_curcop{$ppname}){
1478 $curcop->write_back;
1480 write_back_lexicals() unless $skip_lexicals{$ppname};
1481 write_back_stack() unless $skip_stack{$ppname};
1483 # XXX If the only way that ops can write to a TEMPORARY lexical is
1484 # when it's named in $op->targ then we could call
1485 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1486 # the temporaries. For now, we'll play it safe and write back the lot.
1487 invalidate_lexicals() unless $skip_invalidate{$ppname};
1493 my $ppname = "pp_" . $op->name;
1494 if (exists $ignore_op{$ppname}) {
1497 debug peek_stack() if $debug_stack;
1499 debug sprintf("%s [%s]\n",
1501 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1504 if (defined(&$ppname)) {
1506 return &$ppname($op);
1508 return default_pp($op);
1512 sub compile_bblock {
1514 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1515 save_or_restore_lexical_state($$op);
1519 $op = compile_op($op);
1520 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1521 write_back_stack(); # boo hoo: big loss
1527 my ($name, $root, $start, @padlist) = @_;
1530 #warn "repeat=>".ref($start)."$name,\n";#debug
1531 $decl->add(sprintf("#define $name %s",$done{$$start}));
1537 B::Pseudoreg->new_scope;
1539 if ($debug_timings) {
1540 warn sprintf("Basic block analysis at %s\n", timing_info);
1542 $leaders = find_leaders($root, $start);
1543 my @leaders= keys %$leaders;
1544 if ($#leaders > -1) {
1545 @bblock_todo = ($start, values %$leaders) ;
1547 runtime("return PL_op?PL_op->op_next:0;");
1549 if ($debug_timings) {
1550 warn sprintf("Compilation at %s\n", timing_info);
1552 while (@bblock_todo) {
1553 $op = shift @bblock_todo;
1554 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1555 next if !defined($op) || !$$op || $done{$$op};
1556 #warn "...compiling it\n"; # debug
1558 $done{$$op} = $name;
1559 $op = compile_bblock($op);
1560 if ($need_freetmps && $freetmps_each_bblock) {
1561 runtime("FREETMPS;");
1564 } while defined($op) && $$op && !$done{$$op};
1565 if ($need_freetmps && $freetmps_each_loop) {
1566 runtime("FREETMPS;");
1570 runtime("PUTBACK;","return PL_op;");
1571 } elsif ($done{$$op}) {
1572 save_or_restore_lexical_state($$op);
1573 runtime(sprintf("goto %s;", label($op)));
1576 if ($debug_timings) {
1577 warn sprintf("Saving runtime at %s\n", timing_info);
1579 declare_pad(@padlist) ;
1586 $start = cc_queue(@_) if @_;
1587 while ($ccinfo = shift @cc_todo) {
1594 my ($name, $cvref) = @_;
1595 my $cv = svref_2object($cvref);
1596 my @padlist = $cv->PADLIST->ARRAY;
1597 my $curpad_sym = $padlist[1]->save;
1598 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1602 my @comppadlist = comppadlist->ARRAY;
1603 my $curpad_nam = $comppadlist[0]->save;
1604 my $curpad_sym = $comppadlist[1]->save;
1605 my $init_av = init_av->save;
1606 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1607 # Do save_unused_subs before saving inc_hv
1611 my $inc_hv = svref_2object(\%INC)->save;
1612 my $inc_av = svref_2object(\@INC)->save;
1613 my $amagic_generate= amagic_generation;
1615 if (!defined($module)) {
1616 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1617 "PL_main_start = $start;",
1618 "PL_curpad = AvARRAY($curpad_sym);",
1619 "PL_initav = (AV *) $init_av;",
1620 "GvHV(PL_incgv) = $inc_hv;",
1621 "GvAV(PL_incgv) = $inc_av;",
1622 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1623 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1624 "PL_amagic_generation= $amagic_generate;",
1628 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
1629 output_boilerplate();
1631 output_all("perl_init");
1635 if (defined($module)) {
1636 my $cmodule = $module;
1637 $cmodule =~ s/::/__/g;
1647 SAVESPTR(PL_curpad);
1649 PL_curpad = AvARRAY($curpad_sym);
1659 if ($debug_timings) {
1660 warn sprintf("Done at %s\n", timing_info);
1666 my ($option, $opt, $arg);
1668 while ($option = shift @options) {
1669 if ($option =~ /^-(.)(.*)/) {
1673 unshift @options, $option;
1676 if ($opt eq "-" && $arg eq "-") {
1679 } elsif ($opt eq "o") {
1680 $arg ||= shift @options;
1681 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1682 } elsif ($opt eq "n") {
1683 $arg ||= shift @options;
1684 $module_name = $arg;
1685 } elsif ($opt eq "u") {
1686 $arg ||= shift @options;
1687 mark_unused($arg,undef);
1688 } elsif ($opt eq "f") {
1689 $arg ||= shift @options;
1690 my $value = $arg !~ s/^no-//;
1692 my $ref = $optimise{$arg};
1693 if (defined($ref)) {
1696 warn qq(ignoring unknown optimisation option "$arg"\n);
1698 } elsif ($opt eq "O") {
1699 $arg = 1 if $arg eq "";
1701 foreach $ref (values %optimise) {
1705 $freetmps_each_loop = 1;
1708 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1710 } elsif ($opt eq "m") {
1711 $arg ||= shift @options;
1713 mark_unused($arg,undef);
1714 } elsif ($opt eq "p") {
1715 $arg ||= shift @options;
1717 } elsif ($opt eq "D") {
1718 $arg ||= shift @options;
1719 foreach $arg (split(//, $arg)) {
1722 } elsif ($arg eq "O") {
1724 } elsif ($arg eq "s") {
1726 } elsif ($arg eq "c") {
1728 } elsif ($arg eq "p") {
1730 } elsif ($arg eq "r") {
1732 } elsif ($arg eq "S") {
1734 } elsif ($arg eq "q") {
1736 } elsif ($arg eq "l") {
1738 } elsif ($arg eq "t") {
1745 $init = B::Section->get("init");
1746 $decl = B::Section->get("decl");
1750 my ($objname, $ppname);
1751 foreach $objname (@options) {
1752 $objname = "main::$objname" unless $objname =~ /::/;
1753 ($ppname = $objname) =~ s/^.*?:://;
1754 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1755 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1758 output_boilerplate();
1760 output_all($module_name || "init_module");
1764 return sub { cc_main() };
1774 B::CC - Perl compiler's optimized C translation backend
1778 perl -MO=CC[,OPTIONS] foo.pl
1782 This compiler backend takes Perl source and generates C source code
1783 corresponding to the flow of your program. In other words, this
1784 backend is somewhat a "real" compiler in the sense that many people
1785 think about compilers. Note however that, currently, it is a very
1786 poor compiler in that although it generates (mostly, or at least
1787 sometimes) correct code, it performs relatively few optimisations.
1788 This will change as the compiler develops. The result is that
1789 running an executable compiled with this backend may start up more
1790 quickly than running the original Perl program (a feature shared
1791 by the B<C> compiler backend--see F<B::C>) and may also execute
1792 slightly faster. This is by no means a good optimising compiler--yet.
1796 If there are any non-option arguments, they are taken to be
1797 names of objects to be saved (probably doesn't work properly yet).
1798 Without extra arguments, it saves the main program.
1804 Output to filename instead of STDOUT
1808 Verbose compilation (currently gives a few compilation statistics).
1812 Force end of options
1816 Force apparently unused subs from package Packname to be compiled.
1817 This allows programs to use eval "foo()" even when sub foo is never
1818 seen to be used at compile time. The down side is that any subs which
1819 really are never used also have code generated. This option is
1820 necessary, for example, if you have a signal handler foo which you
1821 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1822 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1823 options. The compiler tries to figure out which packages may possibly
1824 have subs in which need compiling but the current version doesn't do
1825 it very well. In particular, it is confused by nested packages (i.e.
1826 of the form C<A::B>) where package C<A> does not contain any subs.
1828 =item B<-mModulename>
1830 Instead of generating source for a runnable executable, generate
1831 source for an XSUB module. The boot_Modulename function (which
1832 DynaLoader can look for) does the appropriate initialisation and runs
1833 the main part of the Perl source that is being compiled.
1838 Debug options (concatenated or separate flags like C<perl -D>).
1842 Writes debugging output to STDERR just as it's about to write to the
1843 program's runtime (otherwise writes debugging info as comments in
1848 Outputs each OP as it's compiled
1852 Outputs the contents of the shadow stack at each OP
1856 Outputs the contents of the shadow pad of lexicals as it's loaded for
1857 each sub or the main program.
1861 Outputs the name of each fake PP function in the queue as it's about
1866 Output the filename and line number of each original line of Perl
1867 code as it's processed (C<pp_nextstate>).
1871 Outputs timing information of compilation stages.
1875 Force optimisations on or off one at a time.
1877 =item B<-ffreetmps-each-bblock>
1879 Delays FREETMPS from the end of each statement to the end of the each
1882 =item B<-ffreetmps-each-loop>
1884 Delays FREETMPS from the end of each statement to the end of the group
1885 of basic blocks forming a loop. At most one of the freetmps-each-*
1886 options can be used.
1888 =item B<-fomit-taint>
1890 Omits generating code for handling perl's tainting mechanism.
1894 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1895 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1896 sets B<-ffreetmps-each-loop>.
1902 perl -MO=CC,-O2,-ofoo.c foo.pl
1903 perl cc_harness -o foo foo.c
1905 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1906 library directory. The utility called C<perlcc> may also be used to
1907 help make use of this compiler.
1909 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1910 perl cc_harness -shared -c -o Foo.so Foo.c
1914 Plenty. Current status: experimental.
1918 These aren't really bugs but they are constructs which are heavily
1919 tied to perl's compile-and-go implementation and with which this
1920 compiler backend cannot cope.
1924 Standard perl calculates the target of "next", "last", and "redo"
1925 at run-time. The compiler calculates the targets at compile-time.
1926 For example, the program
1928 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1929 NUMBER: for ($i = 0; $i < 5; $i++) {
1938 with standard perl but gives a compile-time error with the compiler.
1940 =head2 Context of ".."
1942 The context (scalar or array) of the ".." operator determines whether
1943 it behaves as a range or a flip/flop. Standard perl delays until
1944 runtime the decision of which context it is in but the compiler needs
1945 to know the context at compile-time. For example,
1948 sub range { (shift @a)..(shift @a) }
1950 while (@a) { print scalar(range()) }
1952 generates the output
1956 with standard Perl but gives a compile-time error with compiled Perl.
1960 Compiled Perl programs use native C arithemtic much more frequently
1961 than standard perl. Operations on large numbers or on boundary
1962 cases may produce different behaviour.
1964 =head2 Deprecated features
1966 Features of standard perl such as C<$[> which have been deprecated
1967 in standard perl since Perl5 was released have not been implemented
1972 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>