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
57 foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
63 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
64 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
66 # Optimisation options. On the command line, use hyphens instead of
67 # underscores for compatibility with gcc-style options. We use
68 # underscores here because they are OK in (strict) barewords.
69 my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
70 my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
71 freetmps_each_loop => \$freetmps_each_loop,
72 omit_taint => \$omit_taint);
73 # perl patchlevel to generate code for (defaults to current patchlevel)
74 my $patchlevel = int(0.5 + 1000 * ($] - 5));
76 # Could rewrite push_runtime() and output_runtime() to use a
77 # temporary file if memory is at a premium.
78 my $ppname; # name of current fake PP function
80 my $declare_ref; # Hash ref keyed by C variable type of declarations.
82 my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
83 # tuples to be written out.
87 sub init_hash { map { $_ => 1 } @_ }
90 # Initialise the hashes for the default PP functions where we can avoid
91 # either write_back_stack, write_back_lexicals or invalidate_lexicals.
93 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
94 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
95 %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller pp_reset pp_rv2cv pp_entereval pp_require pp_dofile pp_entertry pp_enterloop pp_enteriter pp_entersub pp_enter);
101 runtime(map { chomp; "/* $_ */"} @_);
106 my ($type, $var) = @_;
107 push(@{$declare_ref->{$type}}, $var);
111 push(@$runtime_list_ref, @_);
112 warn join("\n", @_) . "\n" if $debug_runtime;
116 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
121 print qq(#include "cc_runtime.h"\n);
122 foreach $ppdata (@pp_list) {
123 my ($name, $runtime, $declare) = @$ppdata;
124 print "\nstatic\nPP($name)\n{\n";
125 my ($type, $varlist, $line);
126 while (($type, $varlist) = each %$declare) {
127 print "\t$type ", join(", ", @$varlist), ";\n";
129 foreach $line (@$runtime) {
139 push_runtime("\t$line");
145 $runtime_list_ref = [];
148 declare("I32", "oldsave");
149 declare("SV", "**svp");
150 map { declare("SV", "*$_") } qw(sv src dst left right);
151 declare("MAGIC", "*mg");
152 $decl->add("static OP * $ppname (ARGSproto);");
153 debug "init_pp: $ppname\n" if $debug_queue;
156 # Initialise runtime_callback function for Stackobj class
157 BEGIN { B::Stackobj::set_callback(\&runtime) }
159 # Initialise saveoptree_callback for B::C class
161 my ($name, $root, $start, @pl) = @_;
162 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
164 if ($name eq "*ignore*") {
167 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
169 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
170 $start = $fakeop->save;
171 debug "cc_queue: name $name returns $start\n" if $debug_queue;
174 BEGIN { B::C::set_callback(\&cc_queue) }
176 sub valid_int { $_[0]->{flags} & VALID_INT }
177 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
178 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
179 sub valid_sv { $_[0]->{flags} & VALID_SV }
181 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
182 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
183 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
184 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
185 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
187 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
188 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
189 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
190 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
193 return ((pop @stack)->as_bool);
195 # Careful: POPs has an auto-decrement and SvTRUE evaluates
196 # its argument more than once.
197 runtime("sv = POPs;");
202 sub write_back_lexicals {
203 my $avoid = shift || 0;
204 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
207 foreach $lex (@pad) {
208 next unless ref($lex);
209 $lex->write_back unless $lex->{flags} & $avoid;
213 sub write_back_stack {
215 return unless @stack;
216 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
217 foreach $obj (@stack) {
218 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
223 sub invalidate_lexicals {
224 my $avoid = shift || 0;
225 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
228 foreach $lex (@pad) {
229 next unless ref($lex);
230 $lex->invalidate unless $lex->{flags} & $avoid;
234 sub reload_lexicals {
236 foreach $lex (@pad) {
237 next unless ref($lex);
238 my $type = $lex->{type};
239 if ($type == T_INT) {
241 } elsif ($type == T_DOUBLE) {
250 package B::Pseudoreg;
252 # This class allocates pseudo-registers (OK, so they're C variables).
254 my %alloc; # Keyed by variable name. A value of 1 means the
255 # variable has been declared. A value of 2 means
258 sub new_scope { %alloc = () }
261 my ($class, $type, $prefix) = @_;
262 my ($ptr, $i, $varname, $status, $obj);
263 $prefix =~ s/^(\**)//;
267 $varname = "$prefix$i";
268 $status = $alloc{$varname};
269 } while $status == 2;
272 B::CC::declare($type, "$ptr$varname");
273 $alloc{$varname} = 2; # declared and in use
275 $obj = bless \$varname, $class;
280 $alloc{$$obj} = 1; # no longer in use but still declared
286 # This class gives a standard API for a perl object to shadow a
287 # C variable and only generate reloads/write-backs when necessary.
289 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
290 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
291 # Use $obj->invalidate whenever an unknown function may have
295 my ($class, $write_back) = @_;
296 # Object fields are perl shadow variable, validity flag
297 # (for *C* variable) and callback sub for write_back
298 # (passed perl shadow variable as argument).
299 bless [undef, 1, $write_back], $class;
302 my ($obj, $newval) = @_;
303 $obj->[1] = 0; # C variable no longer valid
309 $obj->[1] = 1; # C variable will now be valid
310 &{$obj->[2]}($obj->[0]);
313 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
315 my $curcop = new B::Shadow (sub {
316 my $opsym = shift->save;
317 runtime("PL_curcop = (COP*)$opsym;");
321 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
324 my $cxix = $#cxstack;
325 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
328 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
334 my $cxix = $#cxstack;
336 ($cxstack[$cxix]->{type} != CXt_LOOP ||
337 $cxstack[$cxix]->{label} ne $label)) {
340 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
346 my $file = $curcop->[0]->filegv->SV->PV;
347 my $line = $curcop->[0]->line;
350 warn sprintf("%s:%d: $format\n", $file, $line, @_);
352 warn sprintf("%s:%d: %s\n", $file, $line, $format);
357 # Load pad takes (the elements of) a PADLIST as arguments and loads
358 # up @pad with Stackobj-derived objects which represent those lexicals.
359 # If/when perl itself can generate type information (my int $foo) then
360 # we'll take advantage of that here. Until then, we'll use various hacks
361 # to tell the compiler when we want a lexical to be a particular type
362 # or to be a register.
365 my ($namelistav, $valuelistav) = @_;
367 my @namelist = $namelistav->ARRAY;
368 my @valuelist = $valuelistav->ARRAY;
371 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
372 # Temporary lexicals don't get named so it's possible for @valuelist
373 # to be strictly longer than @namelist. We count $ix up to the end of
374 # @valuelist but index into @namelist for the name. Any temporaries which
375 # run off the end of @namelist will make $namesv undefined and we treat
376 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
377 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
378 for ($ix = 1; $ix < @valuelist; $ix++) {
379 my $namesv = $namelist[$ix];
380 my $type = T_UNKNOWN;
383 my $class = class($namesv);
384 if (!defined($namesv) || $class eq "SPECIAL") {
385 # temporaries have &PL_sv_undef instead of a PVNV for a name
386 $flags = VALID_SV|TEMPORARY|REGISTER;
388 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
392 $flags = VALID_SV|VALID_INT;
393 } elsif ($2 eq "d") {
395 $flags = VALID_SV|VALID_DOUBLE;
397 $flags |= REGISTER if $3;
400 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
401 "i_$name", "d_$name");
403 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
409 for ($ix = 1; $ix <= $#pad; $ix++) {
410 my $type = $pad[$ix]->{type};
411 declare("IV", $type == T_INT ?
412 sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
413 declare("double", $type == T_DOUBLE ?
414 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
421 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
429 # XXX Preserve original label name for "real" labels?
430 return sprintf("lab_%x", $$op);
435 push_runtime(sprintf(" %s:", label($op)));
440 my $opsym = $op->save;
441 runtime("PL_op = $opsym;") unless $know_op;
447 my $ppname = $op->ppaddr;
448 my $sym = loadop($op);
449 runtime("DOOP($ppname);");
456 my $flags = $op->flags;
457 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
461 # Code generation for PP code
471 my $gimme = gimme($op);
472 if ($gimme != G_ARRAY) {
473 my $obj= new B::Stackobj::Const(sv_undef);
475 # XXX Change to push a constant sv_undef Stackobj onto @stack
477 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
485 runtime("PP_UNSTACK;");
491 my $next = $op->next;
493 unshift(@bblock_todo, $next);
495 my $bool = pop_bool();
497 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
499 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
507 my $next = $op->next;
509 unshift(@bblock_todo, $next);
511 my $bool = pop_bool @stack;
513 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
514 $bool, label($next)));
516 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
524 my $false = $op->false;
525 unshift(@bblock_todo, $false);
527 my $bool = pop_bool();
529 runtime(sprintf("if (!$bool) goto %s;", label($false)));
536 push(@stack, $pad[$ix]);
537 if ($op->flags & OPf_MOD) {
538 my $private = $op->private;
539 if ($private & OPpLVAL_INTRO) {
540 runtime("SAVECLEARSV(PL_curpad[$ix]);");
541 } elsif ($private & OPpDEREF) {
542 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
543 $ix, $private & OPpDEREF));
544 $pad[$ix]->invalidate;
553 my $obj = $constobj{$$sv};
554 if (!defined($obj)) {
555 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
565 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
566 runtime("TAINT_NOT;") unless $omit_taint;
567 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
568 if ($freetmps_each_bblock || $freetmps_each_loop) {
571 runtime("FREETMPS;");
578 $curcop->invalidate; # XXX?
579 return default_pp($op);
582 #default_pp will handle this:
583 #sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
584 #sub pp_bless { $curcop->write_back; default_pp(@_) }
585 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
586 # The following subs need $curcop->write_back if we decide to support arybase:
587 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
588 #sub pp_sort { $curcop->write_back; default_pp(@_) }
589 #sub pp_caller { $curcop->write_back; default_pp(@_) }
590 #sub pp_reset { $curcop->write_back; default_pp(@_) }
594 my $gvsym = $op->gv->save;
596 runtime("XPUSHs((SV*)$gvsym);");
602 my $gvsym = $op->gv->save;
604 if ($op->private & OPpLVAL_INTRO) {
605 runtime("XPUSHs(save_scalar($gvsym));");
607 runtime("XPUSHs(GvSV($gvsym));");
614 my $gvsym = $op->gv->save;
615 my $ix = $op->private;
616 my $flag = $op->flags & OPf_MOD;
618 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
619 "PUSHs(svp ? *svp : &PL_sv_undef);");
624 my ($op, $operator) = @_;
625 if ($op->flags & OPf_STACKED) {
626 my $right = pop_int();
628 my $left = top_int();
629 $stack[-1]->set_int(&$operator($left, $right));
631 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
634 my $targ = $pad[$op->targ];
635 my $right = new B::Pseudoreg ("IV", "riv");
636 my $left = new B::Pseudoreg ("IV", "liv");
637 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
638 $targ->set_int(&$operator($$left, $$right));
644 sub INTS_CLOSED () { 0x1 }
645 sub INT_RESULT () { 0x2 }
646 sub NUMERIC_RESULT () { 0x4 }
649 my ($op, $operator, $flags) = @_;
651 $force_int ||= ($flags & INT_RESULT);
652 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
653 && valid_int($stack[-2]) && valid_int($stack[-1]));
654 if ($op->flags & OPf_STACKED) {
655 my $right = pop_numeric();
657 my $left = top_numeric();
659 $stack[-1]->set_int(&$operator($left, $right));
661 $stack[-1]->set_numeric(&$operator($left, $right));
665 my $rightruntime = new B::Pseudoreg ("IV", "riv");
666 runtime(sprintf("$$rightruntime = %s;",$right));
667 runtime(sprintf("sv_setiv(TOPs, %s);",
668 &$operator("TOPi", $$rightruntime)));
670 my $rightruntime = new B::Pseudoreg ("double", "rnv");
671 runtime(sprintf("$$rightruntime = %s;",$right));
672 runtime(sprintf("sv_setnv(TOPs, %s);",
673 &$operator("TOPn",$$rightruntime)));
677 my $targ = $pad[$op->targ];
678 $force_int ||= ($targ->{type} == T_INT);
680 my $right = new B::Pseudoreg ("IV", "riv");
681 my $left = new B::Pseudoreg ("IV", "liv");
682 runtime(sprintf("$$right = %s; $$left = %s;",
683 pop_numeric(), pop_numeric));
684 $targ->set_int(&$operator($$left, $$right));
686 my $right = new B::Pseudoreg ("double", "rnv");
687 my $left = new B::Pseudoreg ("double", "lnv");
688 runtime(sprintf("$$right = %s; $$left = %s;",
689 pop_numeric(), pop_numeric));
690 $targ->set_numeric(&$operator($$left, $$right));
699 if ($op->flags & OPf_STACKED) {
700 my $right = pop_numeric();
702 my $left = top_numeric();
703 runtime sprintf("if (%s > %s){",$left,$right);
704 $stack[-1]->set_int(1);
705 $stack[-1]->write_back();
706 runtime sprintf("}else if (%s < %s ) {",$left,$right);
707 $stack[-1]->set_int(-1);
708 $stack[-1]->write_back();
709 runtime sprintf("}else if (%s == %s) {",$left,$right);
710 $stack[-1]->set_int(0);
711 $stack[-1]->write_back();
712 runtime sprintf("}else {");
713 $stack[-1]->set_sv("&PL_sv_undef");
716 my $rightruntime = new B::Pseudoreg ("double", "rnv");
717 runtime(sprintf("$$rightruntime = %s;",$right));
718 runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
719 runtime sprintf("sv_setiv(TOPs,1);");
720 runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
721 runtime sprintf("sv_setiv(TOPs,-1);");
722 runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
723 runtime sprintf("sv_setiv(TOPs,0);");
724 runtime sprintf(qq/}else {/);
725 runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
729 my $targ = $pad[$op->targ];
730 my $right = new B::Pseudoreg ("double", "rnv");
731 my $left = new B::Pseudoreg ("double", "lnv");
732 runtime(sprintf("$$right = %s; $$left = %s;",
733 pop_numeric(), pop_numeric));
734 runtime sprintf("if (%s > %s){",$$left,$$right);
737 runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
740 runtime sprintf("}else if (%s == %s) {",$$left,$$right);
743 runtime sprintf("}else {");
744 $targ->set_sv("&PL_sv_undef");
752 my ($op, $operator, $flags) = @_;
753 if ($op->flags & OPf_STACKED) {
754 my $right = pop_sv();
757 if ($flags & INT_RESULT) {
758 $stack[-1]->set_int(&$operator($left, $right));
759 } elsif ($flags & NUMERIC_RESULT) {
760 $stack[-1]->set_numeric(&$operator($left, $right));
762 # XXX Does this work?
763 runtime(sprintf("sv_setsv($left, %s);",
764 &$operator($left, $right)));
765 $stack[-1]->invalidate;
769 if ($flags & INT_RESULT) {
771 } elsif ($flags & NUMERIC_RESULT) {
776 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
779 my $targ = $pad[$op->targ];
780 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
781 if ($flags & INT_RESULT) {
782 $targ->set_int(&$operator("left", "right"));
783 } elsif ($flags & NUMERIC_RESULT) {
784 $targ->set_numeric(&$operator("left", "right"));
786 # XXX Does this work?
787 runtime(sprintf("sv_setsv(%s, %s);",
788 $targ->as_sv, &$operator("left", "right")));
797 my ($op, $operator) = @_;
798 my $right = new B::Pseudoreg ("IV", "riv");
799 my $left = new B::Pseudoreg ("IV", "liv");
800 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
801 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
802 $bool->set_int(&$operator($$left, $$right));
807 sub bool_numeric_binop {
808 my ($op, $operator) = @_;
809 my $right = new B::Pseudoreg ("double", "rnv");
810 my $left = new B::Pseudoreg ("double", "lnv");
811 runtime(sprintf("$$right = %s; $$left = %s;",
812 pop_numeric(), pop_numeric()));
813 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
814 $bool->set_numeric(&$operator($$left, $$right));
820 my ($op, $operator) = @_;
821 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
822 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
823 $bool->set_numeric(&$operator("left", "right"));
830 return sub { "$_[0] $opname $_[1]" }
835 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
839 my $plus_op = infix_op("+");
840 my $minus_op = infix_op("-");
841 my $multiply_op = infix_op("*");
842 my $divide_op = infix_op("/");
843 my $modulo_op = infix_op("%");
844 my $lshift_op = infix_op("<<");
845 my $rshift_op = infix_op(">>");
846 my $scmp_op = prefix_op("sv_cmp");
847 my $seq_op = prefix_op("sv_eq");
848 my $sne_op = prefix_op("!sv_eq");
849 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
850 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
851 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
852 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
853 my $eq_op = infix_op("==");
854 my $ne_op = infix_op("!=");
855 my $lt_op = infix_op("<");
856 my $gt_op = infix_op(">");
857 my $le_op = infix_op("<=");
858 my $ge_op = infix_op(">=");
861 # XXX The standard perl PP code has extra handling for
862 # some special case arguments of these operators.
864 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
865 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
866 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
867 sub pp_divide { numeric_binop($_[0], $divide_op) }
868 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
870 sub pp_left_shift { int_binop($_[0], $lshift_op) }
871 sub pp_right_shift { int_binop($_[0], $rshift_op) }
872 sub pp_i_add { int_binop($_[0], $plus_op) }
873 sub pp_i_subtract { int_binop($_[0], $minus_op) }
874 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
875 sub pp_i_divide { int_binop($_[0], $divide_op) }
876 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
878 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
879 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
880 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
881 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
882 sub pp_le { bool_numeric_binop($_[0], $le_op) }
883 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
885 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
886 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
887 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
888 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
889 sub pp_i_le { bool_int_binop($_[0], $le_op) }
890 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
892 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
893 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
894 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
895 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
896 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
897 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
898 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
904 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
909 ($src, $dst) = ($dst, $src) if $backwards;
910 my $type = $src->{type};
911 if ($type == T_INT) {
912 $dst->set_int($src->as_int);
913 } elsif ($type == T_DOUBLE) {
914 $dst->set_numeric($src->as_numeric);
916 $dst->set_sv($src->as_sv);
919 } elsif (@stack == 1) {
921 my $src = pop @stack;
922 my $type = $src->{type};
923 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
924 if ($type == T_INT) {
925 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
926 } elsif ($type == T_DOUBLE) {
927 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
929 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
931 runtime("SvSETMAGIC(TOPs);");
933 my $dst = $stack[-1];
934 my $type = $dst->{type};
935 runtime("sv = POPs;");
936 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
937 if ($type == T_INT) {
938 $dst->set_int("SvIV(sv)");
939 } elsif ($type == T_DOUBLE) {
940 $dst->set_double("SvNV(sv)");
942 runtime("SvSetMagicSV($dst->{sv}, sv);");
948 runtime("src = POPs; dst = TOPs;");
950 runtime("dst = POPs; src = TOPs;");
952 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
953 "SvSetSV(dst, src);",
963 my $obj = $stack[-1];
964 my $type = $obj->{type};
965 if ($type == T_INT || $type == T_DOUBLE) {
966 $obj->set_int($obj->as_int . " + 1");
968 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
972 runtime sprintf("PP_PREINC(TOPs);");
980 runtime("PUSHMARK(sp);");
987 my $gimme = gimme($op);
988 if ($gimme == G_ARRAY) { # sic
989 runtime("POPMARK;"); # need this even though not a "full" pp_list
991 runtime("PP_LIST($gimme);");
999 write_back_lexicals(REGISTER|TEMPORARY);
1001 my $sym = doop($op);
1002 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1003 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
1004 runtime("SPAGAIN;}");
1006 invalidate_lexicals(REGISTER|TEMPORARY);
1011 my $ppname = $op->ppaddr;
1012 write_back_lexicals() unless $skip_lexicals{$ppname};
1013 write_back_stack() unless $skip_stack{$ppname};
1015 # See comment in pp_grepwhile to see why!
1016 $init->add("((LISTOP*)$sym)->op_first = $sym;");
1017 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1018 runtime( sprintf("goto %s;",label($op->first)));
1026 my $ppname = $op->ppaddr;
1027 write_back_lexicals() unless $skip_lexicals{$ppname};
1028 write_back_stack() unless $skip_stack{$ppname};
1030 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
1031 invalidate_lexicals() unless $skip_invalidate{$ppname};
1041 write_back_lexicals(REGISTER|TEMPORARY);
1043 my $sym = doop($op);
1044 # XXX Is this the right way to distinguish between it returning
1045 # CvSTART(cv) (via doform) and pop_return()?
1046 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
1047 runtime("SPAGAIN;");
1049 invalidate_lexicals(REGISTER|TEMPORARY);
1055 $curcop->write_back;
1056 write_back_lexicals(REGISTER|TEMPORARY);
1058 my $sym = loadop($op);
1059 my $ppaddr = $op->ppaddr;
1060 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1062 invalidate_lexicals(REGISTER|TEMPORARY);
1066 sub pp_entereval { doeval(@_) }
1067 sub pp_require { doeval(@_) }
1068 sub pp_dofile { doeval(@_) }
1072 $curcop->write_back;
1073 write_back_lexicals(REGISTER|TEMPORARY);
1075 my $sym = doop($op);
1076 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1077 declare("JMPENV", $jmpbuf);
1078 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1079 invalidate_lexicals(REGISTER|TEMPORARY);
1086 runtime("PP_LEAVETRY;");
1092 if ($need_freetmps && $freetmps_each_loop) {
1093 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1100 my $nexttonext=$next->next;
1102 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1103 label($nexttonext)));
1104 return $op->next->other;
1109 if ($need_freetmps && $freetmps_each_loop) {
1110 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1114 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1115 # we need to be able to distinguish the two at runtime.
1119 my $nexttonext=$next->next;
1121 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1122 label($nexttonext)));
1123 return $op->next->other;
1128 my $next = $op->next;
1129 unshift(@bblock_todo, $next);
1130 write_back_lexicals();
1132 my $sym = doop($op);
1133 # pp_grepwhile can return either op_next or op_other and we need to
1134 # be able to distinguish the two at runtime. Since it's possible for
1135 # both ops to be "inlined", the fields could both be zero. To get
1136 # around that, we hack op_next to be our own op (purely because we
1137 # know it's a non-NULL pointer and can't be the same as op_other).
1138 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1139 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1150 write_back_lexicals(REGISTER|TEMPORARY);
1153 runtime("PUTBACK;", "return PL_op;");
1160 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1161 return default_pp($op);
1166 my $flags = $op->flags;
1167 if (!($flags & OPf_WANT)) {
1168 error("context of range unknown at compile-time");
1170 write_back_lexicals();
1172 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
1173 # We need to save our UNOP structure since pp_flop uses
1174 # it to find and adjust out targ. We don't need it ourselves.
1176 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1177 $op->targ, label($op->false));
1178 unshift(@bblock_todo, $op->false);
1185 my $flags = $op->flags;
1186 if (!($flags & OPf_WANT)) {
1187 error("context of flip unknown at compile-time");
1189 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1190 return $op->first->false;
1192 write_back_lexicals();
1194 # We need to save our UNOP structure since pp_flop uses
1195 # it to find and adjust out targ. We don't need it ourselves.
1198 my $rangeix = $op->first->targ;
1199 runtime(($op->private & OPpFLIP_LINENUM) ?
1200 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1201 : "if (SvTRUE(TOPs)) {");
1202 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1203 if ($op->flags & OPf_SPECIAL) {
1204 runtime("sv_setiv(PL_curpad[$ix], 1);");
1206 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1208 sprintf("\tgoto %s;", label($op->first->false)));
1211 qq{sv_setpv(PL_curpad[$ix], "");},
1212 "SETs(PL_curpad[$ix]);");
1226 my $nextop = $op->nextop;
1227 my $lastop = $op->lastop;
1228 my $redoop = $op->redoop;
1229 $curcop->write_back;
1230 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1234 "label" => $curcop->[0]->label,
1242 return default_pp($op);
1245 sub pp_enterloop { enterloop(@_) }
1246 sub pp_enteriter { enterloop(@_) }
1251 die "panic: leaveloop";
1253 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1255 return default_pp($op);
1261 if ($op->flags & OPf_SPECIAL) {
1262 $cxix = dopoptoloop();
1264 error('"next" used outside loop');
1265 return $op->next; # ignore the op
1268 $cxix = dopoptolabel($op->pv);
1270 error('Label not found at compile time for "next %s"', $op->pv);
1271 return $op->next; # ignore the op
1275 my $nextop = $cxstack[$cxix]->{nextop};
1276 push(@bblock_todo, $nextop);
1277 runtime(sprintf("goto %s;", label($nextop)));
1284 if ($op->flags & OPf_SPECIAL) {
1285 $cxix = dopoptoloop();
1287 error('"redo" used outside loop');
1288 return $op->next; # ignore the op
1291 $cxix = dopoptolabel($op->pv);
1293 error('Label not found at compile time for "redo %s"', $op->pv);
1294 return $op->next; # ignore the op
1298 my $redoop = $cxstack[$cxix]->{redoop};
1299 push(@bblock_todo, $redoop);
1300 runtime(sprintf("goto %s;", label($redoop)));
1307 if ($op->flags & OPf_SPECIAL) {
1308 $cxix = dopoptoloop();
1310 error('"last" used outside loop');
1311 return $op->next; # ignore the op
1314 $cxix = dopoptolabel($op->pv);
1316 error('Label not found at compile time for "last %s"', $op->pv);
1317 return $op->next; # ignore the op
1319 # XXX Add support for "last" to leave non-loop blocks
1320 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1321 error('Use of "last" for non-loop blocks is not yet implemented');
1322 return $op->next; # ignore the op
1326 my $lastop = $cxstack[$cxix]->{lastop}->next;
1327 push(@bblock_todo, $lastop);
1328 runtime(sprintf("goto %s;", label($lastop)));
1334 write_back_lexicals();
1336 my $sym = doop($op);
1337 my $replroot = $op->pmreplroot;
1339 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1340 $sym, label($replroot));
1341 $op->pmreplstart->save;
1342 push(@bblock_todo, $replroot);
1344 invalidate_lexicals();
1350 write_back_lexicals();
1353 my $pmop = $op->other;
1354 # warn sprintf("substcont: op = %s, pmop = %s\n",
1355 # peekop($op), peekop($pmop));#debug
1356 # my $pmopsym = objsym($pmop);
1357 my $pmopsym = $pmop->save; # XXX can this recurse?
1358 # warn "pmopsym = $pmopsym\n";#debug
1359 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1360 $pmopsym, label($pmop->pmreplstart));
1361 invalidate_lexicals();
1367 my $ppname = $op->ppaddr;
1368 if ($curcop and $need_curcop{$ppname}){
1369 $curcop->write_back;
1371 write_back_lexicals() unless $skip_lexicals{$ppname};
1372 write_back_stack() unless $skip_stack{$ppname};
1374 # XXX If the only way that ops can write to a TEMPORARY lexical is
1375 # when it's named in $op->targ then we could call
1376 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1377 # the temporaries. For now, we'll play it safe and write back the lot.
1378 invalidate_lexicals() unless $skip_invalidate{$ppname};
1384 my $ppname = $op->ppaddr;
1385 if (exists $ignore_op{$ppname}) {
1388 debug peek_stack() if $debug_stack;
1390 debug sprintf("%s [%s]\n",
1392 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1395 if (defined(&$ppname)) {
1397 return &$ppname($op);
1399 return default_pp($op);
1403 sub compile_bblock {
1405 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1409 $op = compile_op($op);
1410 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1411 write_back_stack(); # boo hoo: big loss
1417 my ($name, $root, $start, @padlist) = @_;
1421 B::Pseudoreg->new_scope;
1423 if ($debug_timings) {
1424 warn sprintf("Basic block analysis at %s\n", timing_info);
1426 $leaders = find_leaders($root, $start);
1427 my @leaders= keys %$leaders;
1428 if ($#leaders > -1) {
1429 @bblock_todo = ($start, values %$leaders) ;
1431 runtime("return PL_op?PL_op->op_next:0;");
1433 if ($debug_timings) {
1434 warn sprintf("Compilation at %s\n", timing_info);
1436 while (@bblock_todo) {
1437 $op = shift @bblock_todo;
1438 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1439 next if !defined($op) || !$$op || $done{$$op};
1440 #warn "...compiling it\n"; # debug
1443 $op = compile_bblock($op);
1444 if ($need_freetmps && $freetmps_each_bblock) {
1445 runtime("FREETMPS;");
1448 } while defined($op) && $$op && !$done{$$op};
1449 if ($need_freetmps && $freetmps_each_loop) {
1450 runtime("FREETMPS;");
1454 runtime("PUTBACK;","return PL_op;");
1455 } elsif ($done{$$op}) {
1456 runtime(sprintf("goto %s;", label($op)));
1459 if ($debug_timings) {
1460 warn sprintf("Saving runtime at %s\n", timing_info);
1462 declare_pad(@padlist) ;
1469 $start = cc_queue(@_) if @_;
1470 while ($ccinfo = shift @cc_todo) {
1477 my ($name, $cvref) = @_;
1478 my $cv = svref_2object($cvref);
1479 my @padlist = $cv->PADLIST->ARRAY;
1480 my $curpad_sym = $padlist[1]->save;
1481 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1485 my @comppadlist = comppadlist->ARRAY;
1486 my $curpad_nam = $comppadlist[0]->save;
1487 my $curpad_sym = $comppadlist[1]->save;
1488 my $init_av = init_av->save;
1489 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1490 # Do save_unused_subs before saving inc_hv
1494 my $inc_hv = svref_2object(\%INC)->save;
1495 my $inc_av = svref_2object(\@INC)->save;
1496 my $amagic_generate= amagic_generation;
1498 if (!defined($module)) {
1499 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1500 "PL_main_start = $start;",
1501 "PL_curpad = AvARRAY($curpad_sym);",
1502 "PL_initav = $init_av;",
1503 "GvHV(PL_incgv) = $inc_hv;",
1504 "GvAV(PL_incgv) = $inc_av;",
1505 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1506 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1507 "PL_amagic_generation= $amagic_generate;",
1511 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
1512 output_boilerplate();
1514 output_all("perl_init");
1518 if (defined($module)) {
1519 my $cmodule = $module;
1520 $cmodule =~ s/::/__/g;
1530 SAVESPTR(PL_curpad);
1532 PL_curpad = AvARRAY($curpad_sym);
1542 if ($debug_timings) {
1543 warn sprintf("Done at %s\n", timing_info);
1549 my ($option, $opt, $arg);
1551 while ($option = shift @options) {
1552 if ($option =~ /^-(.)(.*)/) {
1556 unshift @options, $option;
1559 if ($opt eq "-" && $arg eq "-") {
1562 } elsif ($opt eq "o") {
1563 $arg ||= shift @options;
1564 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1565 } elsif ($opt eq "n") {
1566 $arg ||= shift @options;
1567 $module_name = $arg;
1568 } elsif ($opt eq "u") {
1569 $arg ||= shift @options;
1570 mark_unused($arg,undef);
1571 } elsif ($opt eq "f") {
1572 $arg ||= shift @options;
1573 my $value = $arg !~ s/^no-//;
1575 my $ref = $optimise{$arg};
1576 if (defined($ref)) {
1579 warn qq(ignoring unknown optimisation option "$arg"\n);
1581 } elsif ($opt eq "O") {
1582 $arg = 1 if $arg eq "";
1584 foreach $ref (values %optimise) {
1588 $freetmps_each_loop = 1;
1591 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1593 } elsif ($opt eq "m") {
1594 $arg ||= shift @options;
1596 mark_unused($arg,undef);
1597 } elsif ($opt eq "p") {
1598 $arg ||= shift @options;
1600 } elsif ($opt eq "D") {
1601 $arg ||= shift @options;
1602 foreach $arg (split(//, $arg)) {
1605 } elsif ($arg eq "O") {
1607 } elsif ($arg eq "s") {
1609 } elsif ($arg eq "c") {
1611 } elsif ($arg eq "p") {
1613 } elsif ($arg eq "r") {
1615 } elsif ($arg eq "S") {
1617 } elsif ($arg eq "q") {
1619 } elsif ($arg eq "l") {
1621 } elsif ($arg eq "t") {
1628 $init = B::Section->get("init");
1629 $decl = B::Section->get("decl");
1633 my ($objname, $ppname);
1634 foreach $objname (@options) {
1635 $objname = "main::$objname" unless $objname =~ /::/;
1636 ($ppname = $objname) =~ s/^.*?:://;
1637 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1638 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1641 output_boilerplate();
1643 output_all($module_name || "init_module");
1647 return sub { cc_main() };
1657 B::CC - Perl compiler's optimized C translation backend
1661 perl -MO=CC[,OPTIONS] foo.pl
1665 This compiler backend takes Perl source and generates C source code
1666 corresponding to the flow of your program. In other words, this
1667 backend is somewhat a "real" compiler in the sense that many people
1668 think about compilers. Note however that, currently, it is a very
1669 poor compiler in that although it generates (mostly, or at least
1670 sometimes) correct code, it performs relatively few optimisations.
1671 This will change as the compiler develops. The result is that
1672 running an executable compiled with this backend may start up more
1673 quickly than running the original Perl program (a feature shared
1674 by the B<C> compiler backend--see F<B::C>) and may also execute
1675 slightly faster. This is by no means a good optimising compiler--yet.
1679 If there are any non-option arguments, they are taken to be
1680 names of objects to be saved (probably doesn't work properly yet).
1681 Without extra arguments, it saves the main program.
1687 Output to filename instead of STDOUT
1691 Verbose compilation (currently gives a few compilation statistics).
1695 Force end of options
1699 Force apparently unused subs from package Packname to be compiled.
1700 This allows programs to use eval "foo()" even when sub foo is never
1701 seen to be used at compile time. The down side is that any subs which
1702 really are never used also have code generated. This option is
1703 necessary, for example, if you have a signal handler foo which you
1704 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1705 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1706 options. The compiler tries to figure out which packages may possibly
1707 have subs in which need compiling but the current version doesn't do
1708 it very well. In particular, it is confused by nested packages (i.e.
1709 of the form C<A::B>) where package C<A> does not contain any subs.
1711 =item B<-mModulename>
1713 Instead of generating source for a runnable executable, generate
1714 source for an XSUB module. The boot_Modulename function (which
1715 DynaLoader can look for) does the appropriate initialisation and runs
1716 the main part of the Perl source that is being compiled.
1721 Debug options (concatenated or separate flags like C<perl -D>).
1725 Writes debugging output to STDERR just as it's about to write to the
1726 program's runtime (otherwise writes debugging info as comments in
1731 Outputs each OP as it's compiled
1735 Outputs the contents of the shadow stack at each OP
1739 Outputs the contents of the shadow pad of lexicals as it's loaded for
1740 each sub or the main program.
1744 Outputs the name of each fake PP function in the queue as it's about
1749 Output the filename and line number of each original line of Perl
1750 code as it's processed (C<pp_nextstate>).
1754 Outputs timing information of compilation stages.
1758 Force optimisations on or off one at a time.
1760 =item B<-ffreetmps-each-bblock>
1762 Delays FREETMPS from the end of each statement to the end of the each
1765 =item B<-ffreetmps-each-loop>
1767 Delays FREETMPS from the end of each statement to the end of the group
1768 of basic blocks forming a loop. At most one of the freetmps-each-*
1769 options can be used.
1771 =item B<-fomit-taint>
1773 Omits generating code for handling perl's tainting mechanism.
1777 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1778 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1779 sets B<-ffreetmps-each-loop>.
1785 perl -MO=CC,-O2,-ofoo.c foo.pl
1786 perl cc_harness -o foo foo.c
1788 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1789 library directory. The utility called C<perlcc> may also be used to
1790 help make use of this compiler.
1792 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1793 perl cc_harness -shared -c -o Foo.so Foo.c
1797 Plenty. Current status: experimental.
1801 These aren't really bugs but they are constructs which are heavily
1802 tied to perl's compile-and-go implementation and with which this
1803 compiler backend cannot cope.
1807 Standard perl calculates the target of "next", "last", and "redo"
1808 at run-time. The compiler calculates the targets at compile-time.
1809 For example, the program
1811 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1812 NUMBER: for ($i = 0; $i < 5; $i++) {
1821 with standard perl but gives a compile-time error with the compiler.
1823 =head2 Context of ".."
1825 The context (scalar or array) of the ".." operator determines whether
1826 it behaves as a range or a flip/flop. Standard perl delays until
1827 runtime the decision of which context it is in but the compiler needs
1828 to know the context at compile-time. For example,
1831 sub range { (shift @a)..(shift @a) }
1833 while (@a) { print scalar(range()) }
1835 generates the output
1839 with standard Perl but gives a compile-time error with compiled Perl.
1843 Compiled Perl programs use native C arithemtic much more frequently
1844 than standard perl. Operations on large numbers or on boundary
1845 cases may produce different behaviour.
1847 =head2 Deprecated features
1849 Features of standard perl such as C<$[> which have been deprecated
1850 in standard perl since Perl5 was released have not been implemented
1855 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>