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.
11 use B qw(main_start main_root class comppadlist peekop svref_2object
12 timing_info init_av sv_undef amagic_generation
13 OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
14 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
15 OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
16 CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
18 use B::C qw(save_unused_subs objsym init_sections mark_unused
19 output_all output_boilerplate output_main);
20 use B::Bblock qw(find_leaders);
21 use B::Stackobj qw(:types :flags);
23 # These should probably be elsewhere
24 # Flags for $op->flags
26 my $module; # module name (when compiled with -m)
27 my %done; # hash keyed by $$op of leaders of basic blocks
28 # which have already been done.
29 my $leaders; # ref to hash of basic block leaders. Keys are $$op
30 # addresses, values are the $op objects themselves.
31 my @bblock_todo; # list of leaders of basic blocks that need visiting
33 my @cc_todo; # list of tuples defining what PP code needs to be
34 # saved (e.g. CV, main or PMOP repl code). Each tuple
35 # is [$name, $root, $start, @padlist]. PMOP repl code
36 # tuples inherit padlist.
37 my @stack; # shadows perl's stack when contents are known.
38 # Values are objects derived from class B::Stackobj
39 my @pad; # Lexicals in current pad as Stackobj-derived objects
40 my @padlist; # Copy of current padlist so PMOP repl code can find it
41 my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
42 my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
43 my %constobj; # OP_CONST constants as Stackobj-derived objects
45 my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
46 # block or even to the end of each loop of blocks,
47 # depending on optimisation options.
48 my $know_op = 0; # Set when C variable op already holds the right op
49 # (from an immediately preceding DOOP(ppname)).
50 my $errors = 0; # Number of errors encountered
51 my %skip_stack; # Hash of PP names which don't need write_back_stack
52 my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
53 my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
54 my %ignore_op; # Hash of ops which do nothing except returning op_next
55 my %need_curcop; # Hash of ops which need PL_curcop
57 my %lexstate; #state of padsvs at the start of a bblock
60 foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
66 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
67 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
69 # Optimisation options. On the command line, use hyphens instead of
70 # underscores for compatibility with gcc-style options. We use
71 # underscores here because they are OK in (strict) barewords.
72 my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
73 my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
74 freetmps_each_loop => \$freetmps_each_loop,
75 omit_taint => \$omit_taint);
76 # perl patchlevel to generate code for (defaults to current patchlevel)
77 my $patchlevel = int(0.5 + 1000 * ($] - 5));
79 # Could rewrite push_runtime() and output_runtime() to use a
80 # temporary file if memory is at a premium.
81 my $ppname; # name of current fake PP function
83 my $declare_ref; # Hash ref keyed by C variable type of declarations.
85 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
86 # tuples to be written out.
90 sub init_hash { map { $_ => 1 } @_ }
93 # Initialise the hashes for the default PP functions where we can avoid
94 # either write_back_stack, write_back_lexicals or invalidate_lexicals.
96 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
97 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
98 %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
99 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
100 pp_entertry pp_enterloop pp_enteriter pp_entersub
104 if ($debug_runtime) {
108 runtime(map { chomp; "/* $_ */"} @tmp);
113 my ($type, $var) = @_;
114 push(@{$declare_ref->{$type}}, $var);
118 push(@$runtime_list_ref, @_);
119 warn join("\n", @_) . "\n" if $debug_runtime;
123 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
128 print qq(#include "cc_runtime.h"\n);
129 foreach $ppdata (@pp_list) {
130 my ($name, $runtime, $declare) = @$ppdata;
131 print "\nstatic\nCCPP($name)\n{\n";
132 my ($type, $varlist, $line);
133 while (($type, $varlist) = each %$declare) {
134 print "\t$type ", join(", ", @$varlist), ";\n";
136 foreach $line (@$runtime) {
146 push_runtime("\t$line");
152 $runtime_list_ref = [];
155 declare("I32", "oldsave");
156 declare("SV", "**svp");
157 map { declare("SV", "*$_") } qw(sv src dst left right);
158 declare("MAGIC", "*mg");
159 $decl->add("static OP * $ppname (pTHX);");
160 debug "init_pp: $ppname\n" if $debug_queue;
163 # Initialise runtime_callback function for Stackobj class
164 BEGIN { B::Stackobj::set_callback(\&runtime) }
166 # Initialise saveoptree_callback for B::C class
168 my ($name, $root, $start, @pl) = @_;
169 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
171 if ($name eq "*ignore*") {
174 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
176 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
177 $start = $fakeop->save;
178 debug "cc_queue: name $name returns $start\n" if $debug_queue;
181 BEGIN { B::C::set_callback(\&cc_queue) }
183 sub valid_int { $_[0]->{flags} & VALID_INT }
184 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
185 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
186 sub valid_sv { $_[0]->{flags} & VALID_SV }
188 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
189 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
190 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
191 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
192 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
194 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
195 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
196 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
197 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
200 return ((pop @stack)->as_bool);
202 # Careful: POPs has an auto-decrement and SvTRUE evaluates
203 # its argument more than once.
204 runtime("sv = POPs;");
209 sub write_back_lexicals {
210 my $avoid = shift || 0;
211 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
214 foreach $lex (@pad) {
215 next unless ref($lex);
216 $lex->write_back unless $lex->{flags} & $avoid;
220 sub save_or_restore_lexical_state {
222 unless( exists $lexstate{$bblock}){
223 foreach my $lex (@pad) {
224 next unless ref($lex);
225 ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
229 foreach my $lex (@pad) {
230 next unless ref($lex);
231 my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ;
232 next if ( $old_flags eq $lex->{flags});
233 if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){
236 if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
239 if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
246 sub write_back_stack {
248 return unless @stack;
249 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
250 foreach $obj (@stack) {
251 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
256 sub invalidate_lexicals {
257 my $avoid = shift || 0;
258 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
261 foreach $lex (@pad) {
262 next unless ref($lex);
263 $lex->invalidate unless $lex->{flags} & $avoid;
267 sub reload_lexicals {
269 foreach $lex (@pad) {
270 next unless ref($lex);
271 my $type = $lex->{type};
272 if ($type == T_INT) {
274 } elsif ($type == T_DOUBLE) {
283 package B::Pseudoreg;
285 # This class allocates pseudo-registers (OK, so they're C variables).
287 my %alloc; # Keyed by variable name. A value of 1 means the
288 # variable has been declared. A value of 2 means
291 sub new_scope { %alloc = () }
294 my ($class, $type, $prefix) = @_;
295 my ($ptr, $i, $varname, $status, $obj);
296 $prefix =~ s/^(\**)//;
300 $varname = "$prefix$i";
301 $status = $alloc{$varname};
302 } while $status == 2;
305 B::CC::declare($type, "$ptr$varname");
306 $alloc{$varname} = 2; # declared and in use
308 $obj = bless \$varname, $class;
313 $alloc{$$obj} = 1; # no longer in use but still declared
319 # This class gives a standard API for a perl object to shadow a
320 # C variable and only generate reloads/write-backs when necessary.
322 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
323 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
324 # Use $obj->invalidate whenever an unknown function may have
328 my ($class, $write_back) = @_;
329 # Object fields are perl shadow variable, validity flag
330 # (for *C* variable) and callback sub for write_back
331 # (passed perl shadow variable as argument).
332 bless [undef, 1, $write_back], $class;
335 my ($obj, $newval) = @_;
336 $obj->[1] = 0; # C variable no longer valid
342 $obj->[1] = 1; # C variable will now be valid
343 &{$obj->[2]}($obj->[0]);
346 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
348 my $curcop = new B::Shadow (sub {
349 my $opsym = shift->save;
350 runtime("PL_curcop = (COP*)$opsym;");
354 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
357 my $cxix = $#cxstack;
358 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
361 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
367 my $cxix = $#cxstack;
369 ($cxstack[$cxix]->{type} != CXt_LOOP ||
370 $cxstack[$cxix]->{label} ne $label)) {
373 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
379 my $file = $curcop->[0]->file;
380 my $line = $curcop->[0]->line;
383 warn sprintf("%s:%d: $format\n", $file, $line, @_);
385 warn sprintf("%s:%d: %s\n", $file, $line, $format);
390 # Load pad takes (the elements of) a PADLIST as arguments and loads
391 # up @pad with Stackobj-derived objects which represent those lexicals.
392 # If/when perl itself can generate type information (my int $foo) then
393 # we'll take advantage of that here. Until then, we'll use various hacks
394 # to tell the compiler when we want a lexical to be a particular type
395 # or to be a register.
398 my ($namelistav, $valuelistav) = @_;
400 my @namelist = $namelistav->ARRAY;
401 my @valuelist = $valuelistav->ARRAY;
404 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
405 # Temporary lexicals don't get named so it's possible for @valuelist
406 # to be strictly longer than @namelist. We count $ix up to the end of
407 # @valuelist but index into @namelist for the name. Any temporaries which
408 # run off the end of @namelist will make $namesv undefined and we treat
409 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
410 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
411 for ($ix = 1; $ix < @valuelist; $ix++) {
412 my $namesv = $namelist[$ix];
413 my $type = T_UNKNOWN;
416 my $class = class($namesv);
417 if (!defined($namesv) || $class eq "SPECIAL") {
418 # temporaries have &PL_sv_undef instead of a PVNV for a name
419 $flags = VALID_SV|TEMPORARY|REGISTER;
421 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
425 $flags = VALID_SV|VALID_INT;
426 } elsif ($2 eq "d") {
428 $flags = VALID_SV|VALID_DOUBLE;
430 $flags |= REGISTER if $3;
433 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
434 "i_$name", "d_$name");
436 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
442 for ($ix = 1; $ix <= $#pad; $ix++) {
443 my $type = $pad[$ix]->{type};
444 declare("IV", $type == T_INT ?
445 sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
446 declare("double", $type == T_DOUBLE ?
447 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
454 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
462 # XXX Preserve original label name for "real" labels?
463 return sprintf("lab_%x", $$op);
468 push_runtime(sprintf(" %s:", label($op)));
473 my $opsym = $op->save;
474 runtime("PL_op = $opsym;") unless $know_op;
480 my $ppname = $op->ppaddr;
481 my $sym = loadop($op);
482 runtime("DOOP($ppname);");
489 my $flags = $op->flags;
490 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
494 # Code generation for PP code
504 my $gimme = gimme($op);
505 if ($gimme != G_ARRAY) {
506 my $obj= new B::Stackobj::Const(sv_undef);
508 # XXX Change to push a constant sv_undef Stackobj onto @stack
510 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
518 runtime("PP_UNSTACK;");
524 my $next = $op->next;
526 unshift(@bblock_todo, $next);
528 my $bool = pop_bool();
530 save_or_restore_lexical_state($$next);
531 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
533 save_or_restore_lexical_state($$next);
534 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
542 my $next = $op->next;
544 unshift(@bblock_todo, $next);
546 my $bool = pop_bool @stack;
548 save_or_restore_lexical_state($$next);
549 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
550 $bool, label($next)));
552 save_or_restore_lexical_state($$next);
553 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
561 my $false = $op->next;
562 unshift(@bblock_todo, $false);
564 my $bool = pop_bool();
566 save_or_restore_lexical_state($$false);
567 runtime(sprintf("if (!$bool) goto %s;", label($false)));
574 push(@stack, $pad[$ix]);
575 if ($op->flags & OPf_MOD) {
576 my $private = $op->private;
577 if ($private & OPpLVAL_INTRO) {
578 runtime("SAVECLEARSV(PL_curpad[$ix]);");
579 } elsif ($private & OPpDEREF) {
580 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
581 $ix, $private & OPpDEREF));
582 $pad[$ix]->invalidate;
592 # constant could be in the pad (under useithreads)
594 $obj = $constobj{$$sv};
595 if (!defined($obj)) {
596 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
600 $obj = $pad[$op->targ];
610 debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
611 runtime("TAINT_NOT;") unless $omit_taint;
612 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
613 if ($freetmps_each_bblock || $freetmps_each_loop) {
616 runtime("FREETMPS;");
623 $curcop->invalidate; # XXX?
624 return default_pp($op);
627 #default_pp will handle this:
628 #sub pp_bless { $curcop->write_back; default_pp(@_) }
629 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
630 # The following subs need $curcop->write_back if we decide to support arybase:
631 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
632 #sub pp_caller { $curcop->write_back; default_pp(@_) }
633 #sub pp_reset { $curcop->write_back; default_pp(@_) }
638 write_back_lexicals() unless $skip_lexicals{$ppname};
639 write_back_stack() unless $skip_stack{$ppname};
641 if ($op->private & OPpDEREF) {
642 $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
643 $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
650 my $ppname = $op->ppaddr;
651 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
652 #this indicates the sort BLOCK Array case
653 #ugly surgery required.
654 my $root=$op->first->sibling->first;
655 my $start=$root->first;
657 $op->first->sibling->save;
659 my $sym=$start->save;
660 my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
661 $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
664 write_back_lexicals();
673 if ($Config{useithreads}) {
674 $gvsym = $pad[$op->padix]->as_sv;
677 $gvsym = $op->gv->save;
680 runtime("XPUSHs((SV*)$gvsym);");
687 if ($Config{useithreads}) {
688 $gvsym = $pad[$op->padix]->as_sv;
691 $gvsym = $op->gv->save;
694 if ($op->private & OPpLVAL_INTRO) {
695 runtime("XPUSHs(save_scalar($gvsym));");
697 runtime("XPUSHs(GvSV($gvsym));");
705 if ($Config{useithreads}) {
706 $gvsym = $pad[$op->padix]->as_sv;
709 $gvsym = $op->gv->save;
711 my $ix = $op->private;
712 my $flag = $op->flags & OPf_MOD;
714 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
715 "PUSHs(svp ? *svp : &PL_sv_undef);");
720 my ($op, $operator) = @_;
721 if ($op->flags & OPf_STACKED) {
722 my $right = pop_int();
724 my $left = top_int();
725 $stack[-1]->set_int(&$operator($left, $right));
727 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
730 my $targ = $pad[$op->targ];
731 my $right = new B::Pseudoreg ("IV", "riv");
732 my $left = new B::Pseudoreg ("IV", "liv");
733 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
734 $targ->set_int(&$operator($$left, $$right));
740 sub INTS_CLOSED () { 0x1 }
741 sub INT_RESULT () { 0x2 }
742 sub NUMERIC_RESULT () { 0x4 }
745 my ($op, $operator, $flags) = @_;
747 $force_int ||= ($flags & INT_RESULT);
748 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
749 && valid_int($stack[-2]) && valid_int($stack[-1]));
750 if ($op->flags & OPf_STACKED) {
751 my $right = pop_numeric();
753 my $left = top_numeric();
755 $stack[-1]->set_int(&$operator($left, $right));
757 $stack[-1]->set_numeric(&$operator($left, $right));
761 my $rightruntime = new B::Pseudoreg ("IV", "riv");
762 runtime(sprintf("$$rightruntime = %s;",$right));
763 runtime(sprintf("sv_setiv(TOPs, %s);",
764 &$operator("TOPi", $$rightruntime)));
766 my $rightruntime = new B::Pseudoreg ("double", "rnv");
767 runtime(sprintf("$$rightruntime = %s;",$right));
768 runtime(sprintf("sv_setnv(TOPs, %s);",
769 &$operator("TOPn",$$rightruntime)));
773 my $targ = $pad[$op->targ];
774 $force_int ||= ($targ->{type} == T_INT);
776 my $right = new B::Pseudoreg ("IV", "riv");
777 my $left = new B::Pseudoreg ("IV", "liv");
778 runtime(sprintf("$$right = %s; $$left = %s;",
779 pop_numeric(), pop_numeric));
780 $targ->set_int(&$operator($$left, $$right));
782 my $right = new B::Pseudoreg ("double", "rnv");
783 my $left = new B::Pseudoreg ("double", "lnv");
784 runtime(sprintf("$$right = %s; $$left = %s;",
785 pop_numeric(), pop_numeric));
786 $targ->set_numeric(&$operator($$left, $$right));
795 if ($op->flags & OPf_STACKED) {
796 my $right = pop_numeric();
798 my $left = top_numeric();
799 runtime sprintf("if (%s > %s){",$left,$right);
800 $stack[-1]->set_int(1);
801 $stack[-1]->write_back();
802 runtime sprintf("}else 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(0);
807 $stack[-1]->write_back();
808 runtime sprintf("}else {");
809 $stack[-1]->set_sv("&PL_sv_undef");
812 my $rightruntime = new B::Pseudoreg ("double", "rnv");
813 runtime(sprintf("$$rightruntime = %s;",$right));
814 runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
815 runtime sprintf("sv_setiv(TOPs,1);");
816 runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
817 runtime sprintf("sv_setiv(TOPs,-1);");
818 runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
819 runtime sprintf("sv_setiv(TOPs,0);");
820 runtime sprintf(qq/}else {/);
821 runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
825 my $targ = $pad[$op->targ];
826 my $right = new B::Pseudoreg ("double", "rnv");
827 my $left = new B::Pseudoreg ("double", "lnv");
828 runtime(sprintf("$$right = %s; $$left = %s;",
829 pop_numeric(), pop_numeric));
830 runtime sprintf("if (%s > %s){",$$left,$$right);
833 runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
836 runtime sprintf("}else if (%s == %s) {",$$left,$$right);
839 runtime sprintf("}else {");
840 $targ->set_sv("&PL_sv_undef");
848 my ($op, $operator, $flags) = @_;
849 if ($op->flags & OPf_STACKED) {
850 my $right = pop_sv();
853 if ($flags & INT_RESULT) {
854 $stack[-1]->set_int(&$operator($left, $right));
855 } elsif ($flags & NUMERIC_RESULT) {
856 $stack[-1]->set_numeric(&$operator($left, $right));
858 # XXX Does this work?
859 runtime(sprintf("sv_setsv($left, %s);",
860 &$operator($left, $right)));
861 $stack[-1]->invalidate;
865 if ($flags & INT_RESULT) {
867 } elsif ($flags & NUMERIC_RESULT) {
872 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
875 my $targ = $pad[$op->targ];
876 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
877 if ($flags & INT_RESULT) {
878 $targ->set_int(&$operator("left", "right"));
879 } elsif ($flags & NUMERIC_RESULT) {
880 $targ->set_numeric(&$operator("left", "right"));
882 # XXX Does this work?
883 runtime(sprintf("sv_setsv(%s, %s);",
884 $targ->as_sv, &$operator("left", "right")));
893 my ($op, $operator) = @_;
894 my $right = new B::Pseudoreg ("IV", "riv");
895 my $left = new B::Pseudoreg ("IV", "liv");
896 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
897 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
898 $bool->set_int(&$operator($$left, $$right));
903 sub bool_numeric_binop {
904 my ($op, $operator) = @_;
905 my $right = new B::Pseudoreg ("double", "rnv");
906 my $left = new B::Pseudoreg ("double", "lnv");
907 runtime(sprintf("$$right = %s; $$left = %s;",
908 pop_numeric(), pop_numeric()));
909 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
910 $bool->set_numeric(&$operator($$left, $$right));
916 my ($op, $operator) = @_;
917 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
918 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
919 $bool->set_numeric(&$operator("left", "right"));
926 return sub { "$_[0] $opname $_[1]" }
931 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
935 my $plus_op = infix_op("+");
936 my $minus_op = infix_op("-");
937 my $multiply_op = infix_op("*");
938 my $divide_op = infix_op("/");
939 my $modulo_op = infix_op("%");
940 my $lshift_op = infix_op("<<");
941 my $rshift_op = infix_op(">>");
942 my $scmp_op = prefix_op("sv_cmp");
943 my $seq_op = prefix_op("sv_eq");
944 my $sne_op = prefix_op("!sv_eq");
945 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
946 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
947 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
948 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
949 my $eq_op = infix_op("==");
950 my $ne_op = infix_op("!=");
951 my $lt_op = infix_op("<");
952 my $gt_op = infix_op(">");
953 my $le_op = infix_op("<=");
954 my $ge_op = infix_op(">=");
957 # XXX The standard perl PP code has extra handling for
958 # some special case arguments of these operators.
960 sub pp_add { numeric_binop($_[0], $plus_op) }
961 sub pp_subtract { numeric_binop($_[0], $minus_op) }
962 sub pp_multiply { numeric_binop($_[0], $multiply_op) }
963 sub pp_divide { numeric_binop($_[0], $divide_op) }
964 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
966 sub pp_left_shift { int_binop($_[0], $lshift_op) }
967 sub pp_right_shift { int_binop($_[0], $rshift_op) }
968 sub pp_i_add { int_binop($_[0], $plus_op) }
969 sub pp_i_subtract { int_binop($_[0], $minus_op) }
970 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
971 sub pp_i_divide { int_binop($_[0], $divide_op) }
972 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
974 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
975 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
976 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
977 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
978 sub pp_le { bool_numeric_binop($_[0], $le_op) }
979 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
981 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
982 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
983 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
984 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
985 sub pp_i_le { bool_int_binop($_[0], $le_op) }
986 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
988 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
989 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
990 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
991 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
992 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
993 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
994 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
1000 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
1005 ($src, $dst) = ($dst, $src) if $backwards;
1006 my $type = $src->{type};
1007 if ($type == T_INT) {
1008 $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
1009 } elsif ($type == T_DOUBLE) {
1010 $dst->set_numeric($src->as_numeric);
1012 $dst->set_sv($src->as_sv);
1015 } elsif (@stack == 1) {
1017 my $src = pop @stack;
1018 my $type = $src->{type};
1019 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
1020 if ($type == T_INT) {
1021 if ($src->{flags} & VALID_UNSIGNED){
1022 runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
1024 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
1026 } elsif ($type == T_DOUBLE) {
1027 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
1029 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
1031 runtime("SvSETMAGIC(TOPs);");
1033 my $dst = $stack[-1];
1034 my $type = $dst->{type};
1035 runtime("sv = POPs;");
1036 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
1037 if ($type == T_INT) {
1038 $dst->set_int("SvIV(sv)");
1039 } elsif ($type == T_DOUBLE) {
1040 $dst->set_double("SvNV(sv)");
1042 runtime("SvSetMagicSV($dst->{sv}, sv);");
1048 runtime("src = POPs; dst = TOPs;");
1050 runtime("dst = POPs; src = TOPs;");
1052 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
1053 "SvSetSV(dst, src);",
1063 my $obj = $stack[-1];
1064 my $type = $obj->{type};
1065 if ($type == T_INT || $type == T_DOUBLE) {
1066 $obj->set_int($obj->as_int . " + 1");
1068 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
1072 runtime sprintf("PP_PREINC(TOPs);");
1081 runtime("PUSHMARK(sp);");
1088 my $gimme = gimme($op);
1089 if ($gimme == G_ARRAY) { # sic
1090 runtime("POPMARK;"); # need this even though not a "full" pp_list
1092 runtime("PP_LIST($gimme);");
1099 $curcop->write_back;
1100 write_back_lexicals(REGISTER|TEMPORARY);
1102 my $sym = doop($op);
1103 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1104 runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
1105 runtime("SPAGAIN;}");
1107 invalidate_lexicals(REGISTER|TEMPORARY);
1112 my $ppname = $op->ppaddr;
1113 write_back_lexicals() unless $skip_lexicals{$ppname};
1114 write_back_stack() unless $skip_stack{$ppname};
1116 # See comment in pp_grepwhile to see why!
1117 $init->add("((LISTOP*)$sym)->op_first = $sym;");
1118 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1119 save_or_restore_lexical_state(${$op->first});
1120 runtime( sprintf("goto %s;",label($op->first)));
1128 my $ppname = $op->ppaddr;
1129 write_back_lexicals() unless $skip_lexicals{$ppname};
1130 write_back_stack() unless $skip_stack{$ppname};
1132 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
1133 invalidate_lexicals() unless $skip_invalidate{$ppname};
1142 write_back_lexicals() unless $skip_lexicals{$ppname};
1143 write_back_stack() unless $skip_stack{$ppname};
1144 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
1145 runtime("\tPUTBACK;return 0;");
1152 write_back_lexicals(REGISTER|TEMPORARY);
1154 my $sym = doop($op);
1155 # XXX Is this the right way to distinguish between it returning
1156 # CvSTART(cv) (via doform) and pop_return()?
1157 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
1158 runtime("SPAGAIN;");
1160 invalidate_lexicals(REGISTER|TEMPORARY);
1166 $curcop->write_back;
1167 write_back_lexicals(REGISTER|TEMPORARY);
1169 my $sym = loadop($op);
1170 my $ppaddr = $op->ppaddr;
1171 #runtime(qq/printf("$ppaddr type eval\n");/);
1172 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1174 invalidate_lexicals(REGISTER|TEMPORARY);
1178 sub pp_entereval { doeval(@_) }
1179 sub pp_dofile { doeval(@_) }
1181 #pp_require is protected by pp_entertry, so no protection for it.
1184 $curcop->write_back;
1185 write_back_lexicals(REGISTER|TEMPORARY);
1187 my $sym = doop($op);
1188 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1189 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
1190 runtime("SPAGAIN;}");
1192 invalidate_lexicals(REGISTER|TEMPORARY);
1199 $curcop->write_back;
1200 write_back_lexicals(REGISTER|TEMPORARY);
1202 my $sym = doop($op);
1203 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1204 declare("JMPENV", $jmpbuf);
1205 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1206 invalidate_lexicals(REGISTER|TEMPORARY);
1213 runtime("PP_LEAVETRY;");
1219 if ($need_freetmps && $freetmps_each_loop) {
1220 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1227 my $nexttonext=$next->next;
1229 save_or_restore_lexical_state($$nexttonext);
1230 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1231 label($nexttonext)));
1232 return $op->next->other;
1237 if ($need_freetmps && $freetmps_each_loop) {
1238 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1242 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1243 # we need to be able to distinguish the two at runtime.
1247 my $nexttonext=$next->next;
1249 save_or_restore_lexical_state($$nexttonext);
1250 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1251 label($nexttonext)));
1252 return $op->next->other;
1257 my $next = $op->next;
1258 unshift(@bblock_todo, $next);
1259 write_back_lexicals();
1261 my $sym = doop($op);
1262 # pp_grepwhile can return either op_next or op_other and we need to
1263 # be able to distinguish the two at runtime. Since it's possible for
1264 # both ops to be "inlined", the fields could both be zero. To get
1265 # around that, we hack op_next to be our own op (purely because we
1266 # know it's a non-NULL pointer and can't be the same as op_other).
1267 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1268 save_or_restore_lexical_state($$next);
1269 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1280 write_back_lexicals(REGISTER|TEMPORARY);
1283 runtime("PUTBACK;", "return PL_op;");
1290 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1291 return default_pp($op);
1296 my $flags = $op->flags;
1297 if (!($flags & OPf_WANT)) {
1298 error("context of range unknown at compile-time");
1300 write_back_lexicals();
1302 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
1303 # We need to save our UNOP structure since pp_flop uses
1304 # it to find and adjust out targ. We don't need it ourselves.
1306 save_or_restore_lexical_state(${$op->other});
1307 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1308 $op->targ, label($op->other));
1309 unshift(@bblock_todo, $op->other);
1316 my $flags = $op->flags;
1317 if (!($flags & OPf_WANT)) {
1318 error("context of flip unknown at compile-time");
1320 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1321 return $op->first->other;
1323 write_back_lexicals();
1325 # We need to save our UNOP structure since pp_flop uses
1326 # it to find and adjust out targ. We don't need it ourselves.
1329 my $rangeix = $op->first->targ;
1330 runtime(($op->private & OPpFLIP_LINENUM) ?
1331 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1332 : "if (SvTRUE(TOPs)) {");
1333 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1334 if ($op->flags & OPf_SPECIAL) {
1335 runtime("sv_setiv(PL_curpad[$ix], 1);");
1337 save_or_restore_lexical_state(${$op->first->other});
1338 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1340 sprintf("\tgoto %s;", label($op->first->other)));
1343 qq{sv_setpv(PL_curpad[$ix], "");},
1344 "SETs(PL_curpad[$ix]);");
1358 my $nextop = $op->nextop;
1359 my $lastop = $op->lastop;
1360 my $redoop = $op->redoop;
1361 $curcop->write_back;
1362 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1366 "label" => $curcop->[0]->label,
1374 return default_pp($op);
1377 sub pp_enterloop { enterloop(@_) }
1378 sub pp_enteriter { enterloop(@_) }
1383 die "panic: leaveloop";
1385 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1387 return default_pp($op);
1393 if ($op->flags & OPf_SPECIAL) {
1394 $cxix = dopoptoloop();
1396 error('"next" used outside loop');
1397 return $op->next; # ignore the op
1400 $cxix = dopoptolabel($op->pv);
1402 error('Label not found at compile time for "next %s"', $op->pv);
1403 return $op->next; # ignore the op
1407 my $nextop = $cxstack[$cxix]->{nextop};
1408 push(@bblock_todo, $nextop);
1409 save_or_restore_lexical_state($$nextop);
1410 runtime(sprintf("goto %s;", label($nextop)));
1417 if ($op->flags & OPf_SPECIAL) {
1418 $cxix = dopoptoloop();
1420 error('"redo" used outside loop');
1421 return $op->next; # ignore the op
1424 $cxix = dopoptolabel($op->pv);
1426 error('Label not found at compile time for "redo %s"', $op->pv);
1427 return $op->next; # ignore the op
1431 my $redoop = $cxstack[$cxix]->{redoop};
1432 push(@bblock_todo, $redoop);
1433 save_or_restore_lexical_state($$redoop);
1434 runtime(sprintf("goto %s;", label($redoop)));
1441 if ($op->flags & OPf_SPECIAL) {
1442 $cxix = dopoptoloop();
1444 error('"last" used outside loop');
1445 return $op->next; # ignore the op
1448 $cxix = dopoptolabel($op->pv);
1450 error('Label not found at compile time for "last %s"', $op->pv);
1451 return $op->next; # ignore the op
1453 # XXX Add support for "last" to leave non-loop blocks
1454 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1455 error('Use of "last" for non-loop blocks is not yet implemented');
1456 return $op->next; # ignore the op
1460 my $lastop = $cxstack[$cxix]->{lastop}->next;
1461 push(@bblock_todo, $lastop);
1462 save_or_restore_lexical_state($$lastop);
1463 runtime(sprintf("goto %s;", label($lastop)));
1469 write_back_lexicals();
1471 my $sym = doop($op);
1472 my $replroot = $op->pmreplroot;
1474 save_or_restore_lexical_state($$replroot);
1475 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1476 $sym, label($replroot));
1477 $op->pmreplstart->save;
1478 push(@bblock_todo, $replroot);
1480 invalidate_lexicals();
1486 write_back_lexicals();
1489 my $pmop = $op->other;
1490 # warn sprintf("substcont: op = %s, pmop = %s\n",
1491 # peekop($op), peekop($pmop));#debug
1492 # my $pmopsym = objsym($pmop);
1493 my $pmopsym = $pmop->save; # XXX can this recurse?
1494 # warn "pmopsym = $pmopsym\n";#debug
1495 save_or_restore_lexical_state(${$pmop->pmreplstart});
1496 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1497 $pmopsym, label($pmop->pmreplstart));
1498 invalidate_lexicals();
1504 my $ppname = "pp_" . $op->name;
1505 if ($curcop and $need_curcop{$ppname}){
1506 $curcop->write_back;
1508 write_back_lexicals() unless $skip_lexicals{$ppname};
1509 write_back_stack() unless $skip_stack{$ppname};
1511 # XXX If the only way that ops can write to a TEMPORARY lexical is
1512 # when it's named in $op->targ then we could call
1513 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1514 # the temporaries. For now, we'll play it safe and write back the lot.
1515 invalidate_lexicals() unless $skip_invalidate{$ppname};
1521 my $ppname = "pp_" . $op->name;
1522 if (exists $ignore_op{$ppname}) {
1525 debug peek_stack() if $debug_stack;
1527 debug sprintf("%s [%s]\n",
1529 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1532 if (defined(&$ppname)) {
1534 return &$ppname($op);
1536 return default_pp($op);
1540 sub compile_bblock {
1542 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1543 save_or_restore_lexical_state($$op);
1547 $op = compile_op($op);
1548 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1549 write_back_stack(); # boo hoo: big loss
1555 my ($name, $root, $start, @padlist) = @_;
1558 #warn "repeat=>".ref($start)."$name,\n";#debug
1559 $decl->add(sprintf("#define $name %s",$done{$$start}));
1565 B::Pseudoreg->new_scope;
1567 if ($debug_timings) {
1568 warn sprintf("Basic block analysis at %s\n", timing_info);
1570 $leaders = find_leaders($root, $start);
1571 my @leaders= keys %$leaders;
1572 if ($#leaders > -1) {
1573 @bblock_todo = ($start, values %$leaders) ;
1575 runtime("return PL_op?PL_op->op_next:0;");
1577 if ($debug_timings) {
1578 warn sprintf("Compilation at %s\n", timing_info);
1580 while (@bblock_todo) {
1581 $op = shift @bblock_todo;
1582 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1583 next if !defined($op) || !$$op || $done{$$op};
1584 #warn "...compiling it\n"; # debug
1586 $done{$$op} = $name;
1587 $op = compile_bblock($op);
1588 if ($need_freetmps && $freetmps_each_bblock) {
1589 runtime("FREETMPS;");
1592 } while defined($op) && $$op && !$done{$$op};
1593 if ($need_freetmps && $freetmps_each_loop) {
1594 runtime("FREETMPS;");
1598 runtime("PUTBACK;","return PL_op;");
1599 } elsif ($done{$$op}) {
1600 save_or_restore_lexical_state($$op);
1601 runtime(sprintf("goto %s;", label($op)));
1604 if ($debug_timings) {
1605 warn sprintf("Saving runtime at %s\n", timing_info);
1607 declare_pad(@padlist) ;
1614 $start = cc_queue(@_) if @_;
1615 while ($ccinfo = shift @cc_todo) {
1622 my ($name, $cvref) = @_;
1623 my $cv = svref_2object($cvref);
1624 my @padlist = $cv->PADLIST->ARRAY;
1625 my $curpad_sym = $padlist[1]->save;
1626 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1630 my @comppadlist = comppadlist->ARRAY;
1631 my $curpad_nam = $comppadlist[0]->save;
1632 my $curpad_sym = $comppadlist[1]->save;
1633 my $init_av = init_av->save;
1634 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1635 # Do save_unused_subs before saving inc_hv
1639 my $inc_hv = svref_2object(\%INC)->save;
1640 my $inc_av = svref_2object(\@INC)->save;
1641 my $amagic_generate= amagic_generation;
1643 if (!defined($module)) {
1644 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1645 "PL_main_start = $start;",
1646 "PL_curpad = AvARRAY($curpad_sym);",
1647 "PL_initav = (AV *) $init_av;",
1648 "GvHV(PL_incgv) = $inc_hv;",
1649 "GvAV(PL_incgv) = $inc_av;",
1650 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1651 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1652 "PL_amagic_generation= $amagic_generate;",
1656 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
1657 output_boilerplate();
1659 output_all("perl_init");
1663 if (defined($module)) {
1664 my $cmodule = $module;
1665 $cmodule =~ s/::/__/g;
1675 SAVEVPTR(PL_curpad);
1677 PL_curpad = AvARRAY($curpad_sym);
1687 if ($debug_timings) {
1688 warn sprintf("Done at %s\n", timing_info);
1694 my ($option, $opt, $arg);
1696 while ($option = shift @options) {
1697 if ($option =~ /^-(.)(.*)/) {
1701 unshift @options, $option;
1704 if ($opt eq "-" && $arg eq "-") {
1707 } elsif ($opt eq "o") {
1708 $arg ||= shift @options;
1709 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1710 } elsif ($opt eq "n") {
1711 $arg ||= shift @options;
1712 $module_name = $arg;
1713 } elsif ($opt eq "u") {
1714 $arg ||= shift @options;
1715 mark_unused($arg,undef);
1716 } elsif ($opt eq "f") {
1717 $arg ||= shift @options;
1718 my $value = $arg !~ s/^no-//;
1720 my $ref = $optimise{$arg};
1721 if (defined($ref)) {
1724 warn qq(ignoring unknown optimisation option "$arg"\n);
1726 } elsif ($opt eq "O") {
1727 $arg = 1 if $arg eq "";
1729 foreach $ref (values %optimise) {
1733 $freetmps_each_loop = 1;
1736 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1738 } elsif ($opt eq "m") {
1739 $arg ||= shift @options;
1741 mark_unused($arg,undef);
1742 } elsif ($opt eq "p") {
1743 $arg ||= shift @options;
1745 } elsif ($opt eq "D") {
1746 $arg ||= shift @options;
1747 foreach $arg (split(//, $arg)) {
1750 } elsif ($arg eq "O") {
1752 } elsif ($arg eq "s") {
1754 } elsif ($arg eq "c") {
1756 } elsif ($arg eq "p") {
1758 } elsif ($arg eq "r") {
1760 } elsif ($arg eq "S") {
1762 } elsif ($arg eq "q") {
1764 } elsif ($arg eq "l") {
1766 } elsif ($arg eq "t") {
1773 $init = B::Section->get("init");
1774 $decl = B::Section->get("decl");
1778 my ($objname, $ppname);
1779 foreach $objname (@options) {
1780 $objname = "main::$objname" unless $objname =~ /::/;
1781 ($ppname = $objname) =~ s/^.*?:://;
1782 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1783 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1786 output_boilerplate();
1788 output_all($module_name || "init_module");
1792 return sub { cc_main() };
1802 B::CC - Perl compiler's optimized C translation backend
1806 perl -MO=CC[,OPTIONS] foo.pl
1810 This compiler backend takes Perl source and generates C source code
1811 corresponding to the flow of your program. In other words, this
1812 backend is somewhat a "real" compiler in the sense that many people
1813 think about compilers. Note however that, currently, it is a very
1814 poor compiler in that although it generates (mostly, or at least
1815 sometimes) correct code, it performs relatively few optimisations.
1816 This will change as the compiler develops. The result is that
1817 running an executable compiled with this backend may start up more
1818 quickly than running the original Perl program (a feature shared
1819 by the B<C> compiler backend--see F<B::C>) and may also execute
1820 slightly faster. This is by no means a good optimising compiler--yet.
1824 If there are any non-option arguments, they are taken to be
1825 names of objects to be saved (probably doesn't work properly yet).
1826 Without extra arguments, it saves the main program.
1832 Output to filename instead of STDOUT
1836 Verbose compilation (currently gives a few compilation statistics).
1840 Force end of options
1844 Force apparently unused subs from package Packname to be compiled.
1845 This allows programs to use eval "foo()" even when sub foo is never
1846 seen to be used at compile time. The down side is that any subs which
1847 really are never used also have code generated. This option is
1848 necessary, for example, if you have a signal handler foo which you
1849 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1850 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1851 options. The compiler tries to figure out which packages may possibly
1852 have subs in which need compiling but the current version doesn't do
1853 it very well. In particular, it is confused by nested packages (i.e.
1854 of the form C<A::B>) where package C<A> does not contain any subs.
1856 =item B<-mModulename>
1858 Instead of generating source for a runnable executable, generate
1859 source for an XSUB module. The boot_Modulename function (which
1860 DynaLoader can look for) does the appropriate initialisation and runs
1861 the main part of the Perl source that is being compiled.
1866 Debug options (concatenated or separate flags like C<perl -D>).
1870 Writes debugging output to STDERR just as it's about to write to the
1871 program's runtime (otherwise writes debugging info as comments in
1876 Outputs each OP as it's compiled
1880 Outputs the contents of the shadow stack at each OP
1884 Outputs the contents of the shadow pad of lexicals as it's loaded for
1885 each sub or the main program.
1889 Outputs the name of each fake PP function in the queue as it's about
1894 Output the filename and line number of each original line of Perl
1895 code as it's processed (C<pp_nextstate>).
1899 Outputs timing information of compilation stages.
1903 Force optimisations on or off one at a time.
1905 =item B<-ffreetmps-each-bblock>
1907 Delays FREETMPS from the end of each statement to the end of the each
1910 =item B<-ffreetmps-each-loop>
1912 Delays FREETMPS from the end of each statement to the end of the group
1913 of basic blocks forming a loop. At most one of the freetmps-each-*
1914 options can be used.
1916 =item B<-fomit-taint>
1918 Omits generating code for handling perl's tainting mechanism.
1922 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1923 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1924 sets B<-ffreetmps-each-loop>.
1930 perl -MO=CC,-O2,-ofoo.c foo.pl
1931 perl cc_harness -o foo foo.c
1933 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1934 library directory. The utility called C<perlcc> may also be used to
1935 help make use of this compiler.
1937 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1938 perl cc_harness -shared -c -o Foo.so Foo.c
1942 Plenty. Current status: experimental.
1946 These aren't really bugs but they are constructs which are heavily
1947 tied to perl's compile-and-go implementation and with which this
1948 compiler backend cannot cope.
1952 Standard perl calculates the target of "next", "last", and "redo"
1953 at run-time. The compiler calculates the targets at compile-time.
1954 For example, the program
1956 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1957 NUMBER: for ($i = 0; $i < 5; $i++) {
1966 with standard perl but gives a compile-time error with the compiler.
1968 =head2 Context of ".."
1970 The context (scalar or array) of the ".." operator determines whether
1971 it behaves as a range or a flip/flop. Standard perl delays until
1972 runtime the decision of which context it is in but the compiler needs
1973 to know the context at compile-time. For example,
1976 sub range { (shift @a)..(shift @a) }
1978 while (@a) { print scalar(range()) }
1980 generates the output
1984 with standard Perl but gives a compile-time error with compiled Perl.
1988 Compiled Perl programs use native C arithemtic much more frequently
1989 than standard perl. Operations on large numbers or on boundary
1990 cases may produce different behaviour.
1992 =head2 Deprecated features
1994 Features of standard perl such as C<$[> which have been deprecated
1995 in standard perl since Perl5 was released have not been implemented
2000 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>