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 our $VERSION = '1.00';
14 use B qw(main_start main_root class comppadlist peekop svref_2object
15 timing_info init_av sv_undef amagic_generation
16 OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
17 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
18 OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
19 CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
21 use B::C qw(save_unused_subs objsym init_sections mark_unused
22 output_all output_boilerplate output_main);
23 use B::Bblock qw(find_leaders);
24 use B::Stackobj qw(:types :flags);
26 # These should probably be elsewhere
27 # Flags for $op->flags
29 my $module; # module name (when compiled with -m)
30 my %done; # hash keyed by $$op of leaders of basic blocks
31 # which have already been done.
32 my $leaders; # ref to hash of basic block leaders. Keys are $$op
33 # addresses, values are the $op objects themselves.
34 my @bblock_todo; # list of leaders of basic blocks that need visiting
36 my @cc_todo; # list of tuples defining what PP code needs to be
37 # saved (e.g. CV, main or PMOP repl code). Each tuple
38 # is [$name, $root, $start, @padlist]. PMOP repl code
39 # tuples inherit padlist.
40 my @stack; # shadows perl's stack when contents are known.
41 # Values are objects derived from class B::Stackobj
42 my @pad; # Lexicals in current pad as Stackobj-derived objects
43 my @padlist; # Copy of current padlist so PMOP repl code can find it
44 my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
45 my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
46 my %constobj; # OP_CONST constants as Stackobj-derived objects
48 my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
49 # block or even to the end of each loop of blocks,
50 # depending on optimisation options.
51 my $know_op = 0; # Set when C variable op already holds the right op
52 # (from an immediately preceding DOOP(ppname)).
53 my $errors = 0; # Number of errors encountered
54 my %skip_stack; # Hash of PP names which don't need write_back_stack
55 my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
56 my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
57 my %ignore_op; # Hash of ops which do nothing except returning op_next
58 my %need_curcop; # Hash of ops which need PL_curcop
60 my %lexstate; #state of padsvs at the start of a bblock
63 foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
69 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
70 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
72 # Optimisation options. On the command line, use hyphens instead of
73 # underscores for compatibility with gcc-style options. We use
74 # underscores here because they are OK in (strict) barewords.
75 my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
76 my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
77 freetmps_each_loop => \$freetmps_each_loop,
78 omit_taint => \$omit_taint);
79 # perl patchlevel to generate code for (defaults to current patchlevel)
80 my $patchlevel = int(0.5 + 1000 * ($] - 5));
82 # Could rewrite push_runtime() and output_runtime() to use a
83 # temporary file if memory is at a premium.
84 my $ppname; # name of current fake PP function
86 my $declare_ref; # Hash ref keyed by C variable type of declarations.
88 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
89 # tuples to be written out.
93 sub init_hash { map { $_ => 1 } @_ }
96 # Initialise the hashes for the default PP functions where we can avoid
97 # either write_back_stack, write_back_lexicals or invalidate_lexicals.
99 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
100 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
101 %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
102 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
103 pp_entertry pp_enterloop pp_enteriter pp_entersub
107 if ($debug_runtime) {
111 runtime(map { chomp; "/* $_ */"} @tmp);
116 my ($type, $var) = @_;
117 push(@{$declare_ref->{$type}}, $var);
121 push(@$runtime_list_ref, @_);
122 warn join("\n", @_) . "\n" if $debug_runtime;
126 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
131 print qq(#include "cc_runtime.h"\n);
132 foreach $ppdata (@pp_list) {
133 my ($name, $runtime, $declare) = @$ppdata;
134 print "\nstatic\nCCPP($name)\n{\n";
135 my ($type, $varlist, $line);
136 while (($type, $varlist) = each %$declare) {
137 print "\t$type ", join(", ", @$varlist), ";\n";
139 foreach $line (@$runtime) {
149 push_runtime("\t$line");
155 $runtime_list_ref = [];
158 declare("I32", "oldsave");
159 declare("SV", "**svp");
160 map { declare("SV", "*$_") } qw(sv src dst left right);
161 declare("MAGIC", "*mg");
162 $decl->add("static OP * $ppname (pTHX);");
163 debug "init_pp: $ppname\n" if $debug_queue;
166 # Initialise runtime_callback function for Stackobj class
167 BEGIN { B::Stackobj::set_callback(\&runtime) }
169 # Initialise saveoptree_callback for B::C class
171 my ($name, $root, $start, @pl) = @_;
172 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
174 if ($name eq "*ignore*") {
177 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
179 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
180 $start = $fakeop->save;
181 debug "cc_queue: name $name returns $start\n" if $debug_queue;
184 BEGIN { B::C::set_callback(\&cc_queue) }
186 sub valid_int { $_[0]->{flags} & VALID_INT }
187 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
188 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
189 sub valid_sv { $_[0]->{flags} & VALID_SV }
191 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
192 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
193 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
194 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
195 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
197 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
198 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
199 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
200 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
203 return ((pop @stack)->as_bool);
205 # Careful: POPs has an auto-decrement and SvTRUE evaluates
206 # its argument more than once.
207 runtime("sv = POPs;");
212 sub write_back_lexicals {
213 my $avoid = shift || 0;
214 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
217 foreach $lex (@pad) {
218 next unless ref($lex);
219 $lex->write_back unless $lex->{flags} & $avoid;
223 sub save_or_restore_lexical_state {
225 unless( exists $lexstate{$bblock}){
226 foreach my $lex (@pad) {
227 next unless ref($lex);
228 ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
232 foreach my $lex (@pad) {
233 next unless ref($lex);
234 my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ;
235 next if ( $old_flags eq $lex->{flags});
236 if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){
239 if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
242 if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
249 sub write_back_stack {
251 return unless @stack;
252 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
253 foreach $obj (@stack) {
254 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
259 sub invalidate_lexicals {
260 my $avoid = shift || 0;
261 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
264 foreach $lex (@pad) {
265 next unless ref($lex);
266 $lex->invalidate unless $lex->{flags} & $avoid;
270 sub reload_lexicals {
272 foreach $lex (@pad) {
273 next unless ref($lex);
274 my $type = $lex->{type};
275 if ($type == T_INT) {
277 } elsif ($type == T_DOUBLE) {
286 package B::Pseudoreg;
288 # This class allocates pseudo-registers (OK, so they're C variables).
290 my %alloc; # Keyed by variable name. A value of 1 means the
291 # variable has been declared. A value of 2 means
294 sub new_scope { %alloc = () }
297 my ($class, $type, $prefix) = @_;
298 my ($ptr, $i, $varname, $status, $obj);
299 $prefix =~ s/^(\**)//;
303 $varname = "$prefix$i";
304 $status = $alloc{$varname};
305 } while $status == 2;
308 B::CC::declare($type, "$ptr$varname");
309 $alloc{$varname} = 2; # declared and in use
311 $obj = bless \$varname, $class;
316 $alloc{$$obj} = 1; # no longer in use but still declared
322 # This class gives a standard API for a perl object to shadow a
323 # C variable and only generate reloads/write-backs when necessary.
325 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
326 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
327 # Use $obj->invalidate whenever an unknown function may have
331 my ($class, $write_back) = @_;
332 # Object fields are perl shadow variable, validity flag
333 # (for *C* variable) and callback sub for write_back
334 # (passed perl shadow variable as argument).
335 bless [undef, 1, $write_back], $class;
338 my ($obj, $newval) = @_;
339 $obj->[1] = 0; # C variable no longer valid
345 $obj->[1] = 1; # C variable will now be valid
346 &{$obj->[2]}($obj->[0]);
349 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
351 my $curcop = new B::Shadow (sub {
352 my $opsym = shift->save;
353 runtime("PL_curcop = (COP*)$opsym;");
357 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
360 my $cxix = $#cxstack;
361 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
364 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
370 my $cxix = $#cxstack;
372 ($cxstack[$cxix]->{type} != CXt_LOOP ||
373 $cxstack[$cxix]->{label} ne $label)) {
376 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
382 my $file = $curcop->[0]->file;
383 my $line = $curcop->[0]->line;
386 warn sprintf("%s:%d: $format\n", $file, $line, @_);
388 warn sprintf("%s:%d: %s\n", $file, $line, $format);
393 # Load pad takes (the elements of) a PADLIST as arguments and loads
394 # up @pad with Stackobj-derived objects which represent those lexicals.
395 # If/when perl itself can generate type information (my int $foo) then
396 # we'll take advantage of that here. Until then, we'll use various hacks
397 # to tell the compiler when we want a lexical to be a particular type
398 # or to be a register.
401 my ($namelistav, $valuelistav) = @_;
403 my @namelist = $namelistav->ARRAY;
404 my @valuelist = $valuelistav->ARRAY;
407 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
408 # Temporary lexicals don't get named so it's possible for @valuelist
409 # to be strictly longer than @namelist. We count $ix up to the end of
410 # @valuelist but index into @namelist for the name. Any temporaries which
411 # run off the end of @namelist will make $namesv undefined and we treat
412 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
413 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
414 for ($ix = 1; $ix < @valuelist; $ix++) {
415 my $namesv = $namelist[$ix];
416 my $type = T_UNKNOWN;
419 my $class = class($namesv);
420 if (!defined($namesv) || $class eq "SPECIAL") {
421 # temporaries have &PL_sv_undef instead of a PVNV for a name
422 $flags = VALID_SV|TEMPORARY|REGISTER;
424 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
428 $flags = VALID_SV|VALID_INT;
429 } elsif ($2 eq "d") {
431 $flags = VALID_SV|VALID_DOUBLE;
433 $flags |= REGISTER if $3;
436 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
437 "i_$name", "d_$name");
439 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
445 for ($ix = 1; $ix <= $#pad; $ix++) {
446 my $type = $pad[$ix]->{type};
447 declare("IV", $type == T_INT ?
448 sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
449 declare("double", $type == T_DOUBLE ?
450 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
457 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
465 # XXX Preserve original label name for "real" labels?
466 return sprintf("lab_%x", $$op);
471 push_runtime(sprintf(" %s:", label($op)));
476 my $opsym = $op->save;
477 runtime("PL_op = $opsym;") unless $know_op;
483 my $ppname = $op->ppaddr;
484 my $sym = loadop($op);
485 runtime("DOOP($ppname);");
492 my $flags = $op->flags;
493 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
497 # Code generation for PP code
507 my $gimme = gimme($op);
508 if ($gimme != G_ARRAY) {
509 my $obj= new B::Stackobj::Const(sv_undef);
511 # XXX Change to push a constant sv_undef Stackobj onto @stack
513 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
521 runtime("PP_UNSTACK;");
527 my $next = $op->next;
529 unshift(@bblock_todo, $next);
531 my $bool = pop_bool();
533 save_or_restore_lexical_state($$next);
534 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
536 save_or_restore_lexical_state($$next);
537 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
545 my $next = $op->next;
547 unshift(@bblock_todo, $next);
549 my $bool = pop_bool @stack;
551 save_or_restore_lexical_state($$next);
552 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
553 $bool, label($next)));
555 save_or_restore_lexical_state($$next);
556 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
564 my $false = $op->next;
565 unshift(@bblock_todo, $false);
567 my $bool = pop_bool();
569 save_or_restore_lexical_state($$false);
570 runtime(sprintf("if (!$bool) goto %s;", label($false)));
577 push(@stack, $pad[$ix]);
578 if ($op->flags & OPf_MOD) {
579 my $private = $op->private;
580 if ($private & OPpLVAL_INTRO) {
581 runtime("SAVECLEARSV(PL_curpad[$ix]);");
582 } elsif ($private & OPpDEREF) {
583 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
584 $ix, $private & OPpDEREF));
585 $pad[$ix]->invalidate;
595 # constant could be in the pad (under useithreads)
597 $obj = $constobj{$$sv};
598 if (!defined($obj)) {
599 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
603 $obj = $pad[$op->targ];
613 debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
614 runtime("TAINT_NOT;") unless $omit_taint;
615 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
616 if ($freetmps_each_bblock || $freetmps_each_loop) {
619 runtime("FREETMPS;");
626 $curcop->invalidate; # XXX?
627 return default_pp($op);
630 #default_pp will handle this:
631 #sub pp_bless { $curcop->write_back; default_pp(@_) }
632 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
633 # The following subs need $curcop->write_back if we decide to support arybase:
634 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
635 #sub pp_caller { $curcop->write_back; default_pp(@_) }
636 #sub pp_reset { $curcop->write_back; default_pp(@_) }
641 write_back_lexicals() unless $skip_lexicals{$ppname};
642 write_back_stack() unless $skip_stack{$ppname};
644 if ($op->private & OPpDEREF) {
645 $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
646 $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
653 my $ppname = $op->ppaddr;
654 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
655 #this indicates the sort BLOCK Array case
656 #ugly surgery required.
657 my $root=$op->first->sibling->first;
658 my $start=$root->first;
660 $op->first->sibling->save;
662 my $sym=$start->save;
663 my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
664 $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
667 write_back_lexicals();
676 if ($Config{useithreads}) {
677 $gvsym = $pad[$op->padix]->as_sv;
680 $gvsym = $op->gv->save;
683 runtime("XPUSHs((SV*)$gvsym);");
690 if ($Config{useithreads}) {
691 $gvsym = $pad[$op->padix]->as_sv;
694 $gvsym = $op->gv->save;
697 if ($op->private & OPpLVAL_INTRO) {
698 runtime("XPUSHs(save_scalar($gvsym));");
700 runtime("XPUSHs(GvSV($gvsym));");
708 if ($Config{useithreads}) {
709 $gvsym = $pad[$op->padix]->as_sv;
712 $gvsym = $op->gv->save;
714 my $ix = $op->private;
715 my $flag = $op->flags & OPf_MOD;
717 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
718 "PUSHs(svp ? *svp : &PL_sv_undef);");
723 my ($op, $operator) = @_;
724 if ($op->flags & OPf_STACKED) {
725 my $right = pop_int();
727 my $left = top_int();
728 $stack[-1]->set_int(&$operator($left, $right));
730 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
733 my $targ = $pad[$op->targ];
734 my $right = new B::Pseudoreg ("IV", "riv");
735 my $left = new B::Pseudoreg ("IV", "liv");
736 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
737 $targ->set_int(&$operator($$left, $$right));
743 sub INTS_CLOSED () { 0x1 }
744 sub INT_RESULT () { 0x2 }
745 sub NUMERIC_RESULT () { 0x4 }
748 my ($op, $operator, $flags) = @_;
750 $force_int ||= ($flags & INT_RESULT);
751 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
752 && valid_int($stack[-2]) && valid_int($stack[-1]));
753 if ($op->flags & OPf_STACKED) {
754 my $right = pop_numeric();
756 my $left = top_numeric();
758 $stack[-1]->set_int(&$operator($left, $right));
760 $stack[-1]->set_numeric(&$operator($left, $right));
764 my $rightruntime = new B::Pseudoreg ("IV", "riv");
765 runtime(sprintf("$$rightruntime = %s;",$right));
766 runtime(sprintf("sv_setiv(TOPs, %s);",
767 &$operator("TOPi", $$rightruntime)));
769 my $rightruntime = new B::Pseudoreg ("double", "rnv");
770 runtime(sprintf("$$rightruntime = %s;",$right));
771 runtime(sprintf("sv_setnv(TOPs, %s);",
772 &$operator("TOPn",$$rightruntime)));
776 my $targ = $pad[$op->targ];
777 $force_int ||= ($targ->{type} == T_INT);
779 my $right = new B::Pseudoreg ("IV", "riv");
780 my $left = new B::Pseudoreg ("IV", "liv");
781 runtime(sprintf("$$right = %s; $$left = %s;",
782 pop_numeric(), pop_numeric));
783 $targ->set_int(&$operator($$left, $$right));
785 my $right = new B::Pseudoreg ("double", "rnv");
786 my $left = new B::Pseudoreg ("double", "lnv");
787 runtime(sprintf("$$right = %s; $$left = %s;",
788 pop_numeric(), pop_numeric));
789 $targ->set_numeric(&$operator($$left, $$right));
798 if ($op->flags & OPf_STACKED) {
799 my $right = pop_numeric();
801 my $left = top_numeric();
802 runtime sprintf("if (%s > %s){",$left,$right);
803 $stack[-1]->set_int(1);
804 $stack[-1]->write_back();
805 runtime sprintf("}else if (%s < %s ) {",$left,$right);
806 $stack[-1]->set_int(-1);
807 $stack[-1]->write_back();
808 runtime sprintf("}else if (%s == %s) {",$left,$right);
809 $stack[-1]->set_int(0);
810 $stack[-1]->write_back();
811 runtime sprintf("}else {");
812 $stack[-1]->set_sv("&PL_sv_undef");
815 my $rightruntime = new B::Pseudoreg ("double", "rnv");
816 runtime(sprintf("$$rightruntime = %s;",$right));
817 runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
818 runtime sprintf("sv_setiv(TOPs,1);");
819 runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
820 runtime sprintf("sv_setiv(TOPs,-1);");
821 runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
822 runtime sprintf("sv_setiv(TOPs,0);");
823 runtime sprintf(qq/}else {/);
824 runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
828 my $targ = $pad[$op->targ];
829 my $right = new B::Pseudoreg ("double", "rnv");
830 my $left = new B::Pseudoreg ("double", "lnv");
831 runtime(sprintf("$$right = %s; $$left = %s;",
832 pop_numeric(), pop_numeric));
833 runtime sprintf("if (%s > %s){",$$left,$$right);
836 runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
839 runtime sprintf("}else if (%s == %s) {",$$left,$$right);
842 runtime sprintf("}else {");
843 $targ->set_sv("&PL_sv_undef");
851 my ($op, $operator, $flags) = @_;
852 if ($op->flags & OPf_STACKED) {
853 my $right = pop_sv();
856 if ($flags & INT_RESULT) {
857 $stack[-1]->set_int(&$operator($left, $right));
858 } elsif ($flags & NUMERIC_RESULT) {
859 $stack[-1]->set_numeric(&$operator($left, $right));
861 # XXX Does this work?
862 runtime(sprintf("sv_setsv($left, %s);",
863 &$operator($left, $right)));
864 $stack[-1]->invalidate;
868 if ($flags & INT_RESULT) {
870 } elsif ($flags & NUMERIC_RESULT) {
875 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
878 my $targ = $pad[$op->targ];
879 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
880 if ($flags & INT_RESULT) {
881 $targ->set_int(&$operator("left", "right"));
882 } elsif ($flags & NUMERIC_RESULT) {
883 $targ->set_numeric(&$operator("left", "right"));
885 # XXX Does this work?
886 runtime(sprintf("sv_setsv(%s, %s);",
887 $targ->as_sv, &$operator("left", "right")));
896 my ($op, $operator) = @_;
897 my $right = new B::Pseudoreg ("IV", "riv");
898 my $left = new B::Pseudoreg ("IV", "liv");
899 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
900 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
901 $bool->set_int(&$operator($$left, $$right));
906 sub bool_numeric_binop {
907 my ($op, $operator) = @_;
908 my $right = new B::Pseudoreg ("double", "rnv");
909 my $left = new B::Pseudoreg ("double", "lnv");
910 runtime(sprintf("$$right = %s; $$left = %s;",
911 pop_numeric(), pop_numeric()));
912 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
913 $bool->set_numeric(&$operator($$left, $$right));
919 my ($op, $operator) = @_;
920 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
921 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
922 $bool->set_numeric(&$operator("left", "right"));
929 return sub { "$_[0] $opname $_[1]" }
934 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
938 my $plus_op = infix_op("+");
939 my $minus_op = infix_op("-");
940 my $multiply_op = infix_op("*");
941 my $divide_op = infix_op("/");
942 my $modulo_op = infix_op("%");
943 my $lshift_op = infix_op("<<");
944 my $rshift_op = infix_op(">>");
945 my $scmp_op = prefix_op("sv_cmp");
946 my $seq_op = prefix_op("sv_eq");
947 my $sne_op = prefix_op("!sv_eq");
948 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
949 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
950 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
951 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
952 my $eq_op = infix_op("==");
953 my $ne_op = infix_op("!=");
954 my $lt_op = infix_op("<");
955 my $gt_op = infix_op(">");
956 my $le_op = infix_op("<=");
957 my $ge_op = infix_op(">=");
960 # XXX The standard perl PP code has extra handling for
961 # some special case arguments of these operators.
963 sub pp_add { numeric_binop($_[0], $plus_op) }
964 sub pp_subtract { numeric_binop($_[0], $minus_op) }
965 sub pp_multiply { numeric_binop($_[0], $multiply_op) }
966 sub pp_divide { numeric_binop($_[0], $divide_op) }
967 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
969 sub pp_left_shift { int_binop($_[0], $lshift_op) }
970 sub pp_right_shift { int_binop($_[0], $rshift_op) }
971 sub pp_i_add { int_binop($_[0], $plus_op) }
972 sub pp_i_subtract { int_binop($_[0], $minus_op) }
973 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
974 sub pp_i_divide { int_binop($_[0], $divide_op) }
975 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
977 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
978 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
979 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
980 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
981 sub pp_le { bool_numeric_binop($_[0], $le_op) }
982 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
984 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
985 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
986 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
987 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
988 sub pp_i_le { bool_int_binop($_[0], $le_op) }
989 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
991 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
992 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
993 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
994 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
995 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
996 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
997 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
1003 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
1008 ($src, $dst) = ($dst, $src) if $backwards;
1009 my $type = $src->{type};
1010 if ($type == T_INT) {
1011 $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
1012 } elsif ($type == T_DOUBLE) {
1013 $dst->set_numeric($src->as_numeric);
1015 $dst->set_sv($src->as_sv);
1018 } elsif (@stack == 1) {
1020 my $src = pop @stack;
1021 my $type = $src->{type};
1022 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
1023 if ($type == T_INT) {
1024 if ($src->{flags} & VALID_UNSIGNED){
1025 runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
1027 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
1029 } elsif ($type == T_DOUBLE) {
1030 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
1032 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
1034 runtime("SvSETMAGIC(TOPs);");
1036 my $dst = $stack[-1];
1037 my $type = $dst->{type};
1038 runtime("sv = POPs;");
1039 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
1040 if ($type == T_INT) {
1041 $dst->set_int("SvIV(sv)");
1042 } elsif ($type == T_DOUBLE) {
1043 $dst->set_double("SvNV(sv)");
1045 runtime("SvSetMagicSV($dst->{sv}, sv);");
1051 runtime("src = POPs; dst = TOPs;");
1053 runtime("dst = POPs; src = TOPs;");
1055 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
1056 "SvSetSV(dst, src);",
1066 my $obj = $stack[-1];
1067 my $type = $obj->{type};
1068 if ($type == T_INT || $type == T_DOUBLE) {
1069 $obj->set_int($obj->as_int . " + 1");
1071 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
1075 runtime sprintf("PP_PREINC(TOPs);");
1084 runtime("PUSHMARK(sp);");
1091 my $gimme = gimme($op);
1092 if ($gimme == G_ARRAY) { # sic
1093 runtime("POPMARK;"); # need this even though not a "full" pp_list
1095 runtime("PP_LIST($gimme);");
1102 $curcop->write_back;
1103 write_back_lexicals(REGISTER|TEMPORARY);
1105 my $sym = doop($op);
1106 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1107 runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
1108 runtime("SPAGAIN;}");
1110 invalidate_lexicals(REGISTER|TEMPORARY);
1115 my $ppname = $op->ppaddr;
1116 write_back_lexicals() unless $skip_lexicals{$ppname};
1117 write_back_stack() unless $skip_stack{$ppname};
1119 # See comment in pp_grepwhile to see why!
1120 $init->add("((LISTOP*)$sym)->op_first = $sym;");
1121 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1122 save_or_restore_lexical_state(${$op->first});
1123 runtime( sprintf("goto %s;",label($op->first)));
1131 my $ppname = $op->ppaddr;
1132 write_back_lexicals() unless $skip_lexicals{$ppname};
1133 write_back_stack() unless $skip_stack{$ppname};
1135 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
1136 invalidate_lexicals() unless $skip_invalidate{$ppname};
1145 write_back_lexicals() unless $skip_lexicals{$ppname};
1146 write_back_stack() unless $skip_stack{$ppname};
1147 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
1148 runtime("\tPUTBACK;return 0;");
1155 write_back_lexicals(REGISTER|TEMPORARY);
1157 my $sym = doop($op);
1158 # XXX Is this the right way to distinguish between it returning
1159 # CvSTART(cv) (via doform) and pop_return()?
1160 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
1161 runtime("SPAGAIN;");
1163 invalidate_lexicals(REGISTER|TEMPORARY);
1169 $curcop->write_back;
1170 write_back_lexicals(REGISTER|TEMPORARY);
1172 my $sym = loadop($op);
1173 my $ppaddr = $op->ppaddr;
1174 #runtime(qq/printf("$ppaddr type eval\n");/);
1175 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1177 invalidate_lexicals(REGISTER|TEMPORARY);
1181 sub pp_entereval { doeval(@_) }
1182 sub pp_dofile { doeval(@_) }
1184 #pp_require is protected by pp_entertry, so no protection for it.
1187 $curcop->write_back;
1188 write_back_lexicals(REGISTER|TEMPORARY);
1190 my $sym = doop($op);
1191 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1192 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
1193 runtime("SPAGAIN;}");
1195 invalidate_lexicals(REGISTER|TEMPORARY);
1202 $curcop->write_back;
1203 write_back_lexicals(REGISTER|TEMPORARY);
1205 my $sym = doop($op);
1206 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1207 declare("JMPENV", $jmpbuf);
1208 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1209 invalidate_lexicals(REGISTER|TEMPORARY);
1216 runtime("PP_LEAVETRY;");
1222 if ($need_freetmps && $freetmps_each_loop) {
1223 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1230 my $nexttonext=$next->next;
1232 save_or_restore_lexical_state($$nexttonext);
1233 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1234 label($nexttonext)));
1235 return $op->next->other;
1240 if ($need_freetmps && $freetmps_each_loop) {
1241 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1245 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1246 # we need to be able to distinguish the two at runtime.
1250 my $nexttonext=$next->next;
1252 save_or_restore_lexical_state($$nexttonext);
1253 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1254 label($nexttonext)));
1255 return $op->next->other;
1260 my $next = $op->next;
1261 unshift(@bblock_todo, $next);
1262 write_back_lexicals();
1264 my $sym = doop($op);
1265 # pp_grepwhile can return either op_next or op_other and we need to
1266 # be able to distinguish the two at runtime. Since it's possible for
1267 # both ops to be "inlined", the fields could both be zero. To get
1268 # around that, we hack op_next to be our own op (purely because we
1269 # know it's a non-NULL pointer and can't be the same as op_other).
1270 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1271 save_or_restore_lexical_state($$next);
1272 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1283 write_back_lexicals(REGISTER|TEMPORARY);
1286 runtime("PUTBACK;", "return PL_op;");
1293 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1294 return default_pp($op);
1299 my $flags = $op->flags;
1300 if (!($flags & OPf_WANT)) {
1301 error("context of range unknown at compile-time");
1303 write_back_lexicals();
1305 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
1306 # We need to save our UNOP structure since pp_flop uses
1307 # it to find and adjust out targ. We don't need it ourselves.
1309 save_or_restore_lexical_state(${$op->other});
1310 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1311 $op->targ, label($op->other));
1312 unshift(@bblock_todo, $op->other);
1319 my $flags = $op->flags;
1320 if (!($flags & OPf_WANT)) {
1321 error("context of flip unknown at compile-time");
1323 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1324 return $op->first->other;
1326 write_back_lexicals();
1328 # We need to save our UNOP structure since pp_flop uses
1329 # it to find and adjust out targ. We don't need it ourselves.
1332 my $rangeix = $op->first->targ;
1333 runtime(($op->private & OPpFLIP_LINENUM) ?
1334 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1335 : "if (SvTRUE(TOPs)) {");
1336 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1337 if ($op->flags & OPf_SPECIAL) {
1338 runtime("sv_setiv(PL_curpad[$ix], 1);");
1340 save_or_restore_lexical_state(${$op->first->other});
1341 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1343 sprintf("\tgoto %s;", label($op->first->other)));
1346 qq{sv_setpv(PL_curpad[$ix], "");},
1347 "SETs(PL_curpad[$ix]);");
1361 my $nextop = $op->nextop;
1362 my $lastop = $op->lastop;
1363 my $redoop = $op->redoop;
1364 $curcop->write_back;
1365 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1369 "label" => $curcop->[0]->label,
1377 return default_pp($op);
1380 sub pp_enterloop { enterloop(@_) }
1381 sub pp_enteriter { enterloop(@_) }
1386 die "panic: leaveloop";
1388 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1390 return default_pp($op);
1396 if ($op->flags & OPf_SPECIAL) {
1397 $cxix = dopoptoloop();
1399 error('"next" used outside loop');
1400 return $op->next; # ignore the op
1403 $cxix = dopoptolabel($op->pv);
1405 error('Label not found at compile time for "next %s"', $op->pv);
1406 return $op->next; # ignore the op
1410 my $nextop = $cxstack[$cxix]->{nextop};
1411 push(@bblock_todo, $nextop);
1412 save_or_restore_lexical_state($$nextop);
1413 runtime(sprintf("goto %s;", label($nextop)));
1420 if ($op->flags & OPf_SPECIAL) {
1421 $cxix = dopoptoloop();
1423 error('"redo" used outside loop');
1424 return $op->next; # ignore the op
1427 $cxix = dopoptolabel($op->pv);
1429 error('Label not found at compile time for "redo %s"', $op->pv);
1430 return $op->next; # ignore the op
1434 my $redoop = $cxstack[$cxix]->{redoop};
1435 push(@bblock_todo, $redoop);
1436 save_or_restore_lexical_state($$redoop);
1437 runtime(sprintf("goto %s;", label($redoop)));
1444 if ($op->flags & OPf_SPECIAL) {
1445 $cxix = dopoptoloop();
1447 error('"last" used outside loop');
1448 return $op->next; # ignore the op
1451 $cxix = dopoptolabel($op->pv);
1453 error('Label not found at compile time for "last %s"', $op->pv);
1454 return $op->next; # ignore the op
1456 # XXX Add support for "last" to leave non-loop blocks
1457 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1458 error('Use of "last" for non-loop blocks is not yet implemented');
1459 return $op->next; # ignore the op
1463 my $lastop = $cxstack[$cxix]->{lastop}->next;
1464 push(@bblock_todo, $lastop);
1465 save_or_restore_lexical_state($$lastop);
1466 runtime(sprintf("goto %s;", label($lastop)));
1472 write_back_lexicals();
1474 my $sym = doop($op);
1475 my $replroot = $op->pmreplroot;
1477 save_or_restore_lexical_state($$replroot);
1478 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1479 $sym, label($replroot));
1480 $op->pmreplstart->save;
1481 push(@bblock_todo, $replroot);
1483 invalidate_lexicals();
1489 write_back_lexicals();
1492 my $pmop = $op->other;
1493 # warn sprintf("substcont: op = %s, pmop = %s\n",
1494 # peekop($op), peekop($pmop));#debug
1495 # my $pmopsym = objsym($pmop);
1496 my $pmopsym = $pmop->save; # XXX can this recurse?
1497 # warn "pmopsym = $pmopsym\n";#debug
1498 save_or_restore_lexical_state(${$pmop->pmreplstart});
1499 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1500 $pmopsym, label($pmop->pmreplstart));
1501 invalidate_lexicals();
1507 my $ppname = "pp_" . $op->name;
1508 if ($curcop and $need_curcop{$ppname}){
1509 $curcop->write_back;
1511 write_back_lexicals() unless $skip_lexicals{$ppname};
1512 write_back_stack() unless $skip_stack{$ppname};
1514 # XXX If the only way that ops can write to a TEMPORARY lexical is
1515 # when it's named in $op->targ then we could call
1516 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1517 # the temporaries. For now, we'll play it safe and write back the lot.
1518 invalidate_lexicals() unless $skip_invalidate{$ppname};
1524 my $ppname = "pp_" . $op->name;
1525 if (exists $ignore_op{$ppname}) {
1528 debug peek_stack() if $debug_stack;
1530 debug sprintf("%s [%s]\n",
1532 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1535 if (defined(&$ppname)) {
1537 return &$ppname($op);
1539 return default_pp($op);
1543 sub compile_bblock {
1545 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1546 save_or_restore_lexical_state($$op);
1550 $op = compile_op($op);
1551 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1552 write_back_stack(); # boo hoo: big loss
1558 my ($name, $root, $start, @padlist) = @_;
1561 #warn "repeat=>".ref($start)."$name,\n";#debug
1562 $decl->add(sprintf("#define $name %s",$done{$$start}));
1568 B::Pseudoreg->new_scope;
1570 if ($debug_timings) {
1571 warn sprintf("Basic block analysis at %s\n", timing_info);
1573 $leaders = find_leaders($root, $start);
1574 my @leaders= keys %$leaders;
1575 if ($#leaders > -1) {
1576 @bblock_todo = ($start, values %$leaders) ;
1578 runtime("return PL_op?PL_op->op_next:0;");
1580 if ($debug_timings) {
1581 warn sprintf("Compilation at %s\n", timing_info);
1583 while (@bblock_todo) {
1584 $op = shift @bblock_todo;
1585 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1586 next if !defined($op) || !$$op || $done{$$op};
1587 #warn "...compiling it\n"; # debug
1589 $done{$$op} = $name;
1590 $op = compile_bblock($op);
1591 if ($need_freetmps && $freetmps_each_bblock) {
1592 runtime("FREETMPS;");
1595 } while defined($op) && $$op && !$done{$$op};
1596 if ($need_freetmps && $freetmps_each_loop) {
1597 runtime("FREETMPS;");
1601 runtime("PUTBACK;","return PL_op;");
1602 } elsif ($done{$$op}) {
1603 save_or_restore_lexical_state($$op);
1604 runtime(sprintf("goto %s;", label($op)));
1607 if ($debug_timings) {
1608 warn sprintf("Saving runtime at %s\n", timing_info);
1610 declare_pad(@padlist) ;
1617 $start = cc_queue(@_) if @_;
1618 while ($ccinfo = shift @cc_todo) {
1625 my ($name, $cvref) = @_;
1626 my $cv = svref_2object($cvref);
1627 my @padlist = $cv->PADLIST->ARRAY;
1628 my $curpad_sym = $padlist[1]->save;
1629 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1633 my @comppadlist = comppadlist->ARRAY;
1634 my $curpad_nam = $comppadlist[0]->save;
1635 my $curpad_sym = $comppadlist[1]->save;
1636 my $init_av = init_av->save;
1637 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1638 # Do save_unused_subs before saving inc_hv
1642 my $inc_hv = svref_2object(\%INC)->save;
1643 my $inc_av = svref_2object(\@INC)->save;
1644 my $amagic_generate= amagic_generation;
1646 if (!defined($module)) {
1647 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1648 "PL_main_start = $start;",
1649 "PL_curpad = AvARRAY($curpad_sym);",
1650 "PL_initav = (AV *) $init_av;",
1651 "GvHV(PL_incgv) = $inc_hv;",
1652 "GvAV(PL_incgv) = $inc_av;",
1653 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1654 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1655 "PL_amagic_generation= $amagic_generate;",
1659 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
1660 output_boilerplate();
1662 output_all("perl_init");
1666 if (defined($module)) {
1667 my $cmodule = $module;
1668 $cmodule =~ s/::/__/g;
1678 SAVEVPTR(PL_curpad);
1680 PL_curpad = AvARRAY($curpad_sym);
1690 if ($debug_timings) {
1691 warn sprintf("Done at %s\n", timing_info);
1697 my ($option, $opt, $arg);
1699 while ($option = shift @options) {
1700 if ($option =~ /^-(.)(.*)/) {
1704 unshift @options, $option;
1707 if ($opt eq "-" && $arg eq "-") {
1710 } elsif ($opt eq "o") {
1711 $arg ||= shift @options;
1712 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1713 } elsif ($opt eq "n") {
1714 $arg ||= shift @options;
1715 $module_name = $arg;
1716 } elsif ($opt eq "u") {
1717 $arg ||= shift @options;
1718 mark_unused($arg,undef);
1719 } elsif ($opt eq "f") {
1720 $arg ||= shift @options;
1721 my $value = $arg !~ s/^no-//;
1723 my $ref = $optimise{$arg};
1724 if (defined($ref)) {
1727 warn qq(ignoring unknown optimisation option "$arg"\n);
1729 } elsif ($opt eq "O") {
1730 $arg = 1 if $arg eq "";
1732 foreach $ref (values %optimise) {
1736 $freetmps_each_loop = 1;
1739 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1741 } elsif ($opt eq "m") {
1742 $arg ||= shift @options;
1744 mark_unused($arg,undef);
1745 } elsif ($opt eq "p") {
1746 $arg ||= shift @options;
1748 } elsif ($opt eq "D") {
1749 $arg ||= shift @options;
1750 foreach $arg (split(//, $arg)) {
1753 } elsif ($arg eq "O") {
1755 } elsif ($arg eq "s") {
1757 } elsif ($arg eq "c") {
1759 } elsif ($arg eq "p") {
1761 } elsif ($arg eq "r") {
1763 } elsif ($arg eq "S") {
1765 } elsif ($arg eq "q") {
1767 } elsif ($arg eq "l") {
1769 } elsif ($arg eq "t") {
1776 $init = B::Section->get("init");
1777 $decl = B::Section->get("decl");
1781 my ($objname, $ppname);
1782 foreach $objname (@options) {
1783 $objname = "main::$objname" unless $objname =~ /::/;
1784 ($ppname = $objname) =~ s/^.*?:://;
1785 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1786 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1789 output_boilerplate();
1791 output_all($module_name || "init_module");
1795 return sub { cc_main() };
1805 B::CC - Perl compiler's optimized C translation backend
1809 perl -MO=CC[,OPTIONS] foo.pl
1813 This compiler backend takes Perl source and generates C source code
1814 corresponding to the flow of your program. In other words, this
1815 backend is somewhat a "real" compiler in the sense that many people
1816 think about compilers. Note however that, currently, it is a very
1817 poor compiler in that although it generates (mostly, or at least
1818 sometimes) correct code, it performs relatively few optimisations.
1819 This will change as the compiler develops. The result is that
1820 running an executable compiled with this backend may start up more
1821 quickly than running the original Perl program (a feature shared
1822 by the B<C> compiler backend--see F<B::C>) and may also execute
1823 slightly faster. This is by no means a good optimising compiler--yet.
1827 If there are any non-option arguments, they are taken to be
1828 names of objects to be saved (probably doesn't work properly yet).
1829 Without extra arguments, it saves the main program.
1835 Output to filename instead of STDOUT
1839 Verbose compilation (currently gives a few compilation statistics).
1843 Force end of options
1847 Force apparently unused subs from package Packname to be compiled.
1848 This allows programs to use eval "foo()" even when sub foo is never
1849 seen to be used at compile time. The down side is that any subs which
1850 really are never used also have code generated. This option is
1851 necessary, for example, if you have a signal handler foo which you
1852 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1853 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1854 options. The compiler tries to figure out which packages may possibly
1855 have subs in which need compiling but the current version doesn't do
1856 it very well. In particular, it is confused by nested packages (i.e.
1857 of the form C<A::B>) where package C<A> does not contain any subs.
1859 =item B<-mModulename>
1861 Instead of generating source for a runnable executable, generate
1862 source for an XSUB module. The boot_Modulename function (which
1863 DynaLoader can look for) does the appropriate initialisation and runs
1864 the main part of the Perl source that is being compiled.
1869 Debug options (concatenated or separate flags like C<perl -D>).
1873 Writes debugging output to STDERR just as it's about to write to the
1874 program's runtime (otherwise writes debugging info as comments in
1879 Outputs each OP as it's compiled
1883 Outputs the contents of the shadow stack at each OP
1887 Outputs the contents of the shadow pad of lexicals as it's loaded for
1888 each sub or the main program.
1892 Outputs the name of each fake PP function in the queue as it's about
1897 Output the filename and line number of each original line of Perl
1898 code as it's processed (C<pp_nextstate>).
1902 Outputs timing information of compilation stages.
1906 Force optimisations on or off one at a time.
1908 =item B<-ffreetmps-each-bblock>
1910 Delays FREETMPS from the end of each statement to the end of the each
1913 =item B<-ffreetmps-each-loop>
1915 Delays FREETMPS from the end of each statement to the end of the group
1916 of basic blocks forming a loop. At most one of the freetmps-each-*
1917 options can be used.
1919 =item B<-fomit-taint>
1921 Omits generating code for handling perl's tainting mechanism.
1925 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1926 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1927 sets B<-ffreetmps-each-loop>.
1933 perl -MO=CC,-O2,-ofoo.c foo.pl
1934 perl cc_harness -o foo foo.c
1936 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1937 library directory. The utility called C<perlcc> may also be used to
1938 help make use of this compiler.
1940 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1941 perl cc_harness -shared -c -o Foo.so Foo.c
1945 Plenty. Current status: experimental.
1949 These aren't really bugs but they are constructs which are heavily
1950 tied to perl's compile-and-go implementation and with which this
1951 compiler backend cannot cope.
1955 Standard perl calculates the target of "next", "last", and "redo"
1956 at run-time. The compiler calculates the targets at compile-time.
1957 For example, the program
1959 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1960 NUMBER: for ($i = 0; $i < 5; $i++) {
1969 with standard perl but gives a compile-time error with the compiler.
1971 =head2 Context of ".."
1973 The context (scalar or array) of the ".." operator determines whether
1974 it behaves as a range or a flip/flop. Standard perl delays until
1975 runtime the decision of which context it is in but the compiler needs
1976 to know the context at compile-time. For example,
1979 sub range { (shift @a)..(shift @a) }
1981 while (@a) { print scalar(range()) }
1983 generates the output
1987 with standard Perl but gives a compile-time error with compiled Perl.
1991 Compiled Perl programs use native C arithemtic much more frequently
1992 than standard perl. Operations on large numbers or on boundary
1993 cases may produce different behaviour.
1995 =head2 Deprecated features
1997 Features of standard perl such as C<$[> which have been deprecated
1998 in standard perl since Perl5 was released have not been implemented
2003 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>