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
96 pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
97 pp_entertry pp_enterloop pp_enteriter pp_entersub
101 if ($debug_runtime) {
104 runtime(map { chomp; "/* $_ */"} @_);
109 my ($type, $var) = @_;
110 push(@{$declare_ref->{$type}}, $var);
114 push(@$runtime_list_ref, @_);
115 warn join("\n", @_) . "\n" if $debug_runtime;
119 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
124 print qq(#include "cc_runtime.h"\n);
125 foreach $ppdata (@pp_list) {
126 my ($name, $runtime, $declare) = @$ppdata;
127 print "\nstatic\nPP($name)\n{\n";
128 my ($type, $varlist, $line);
129 while (($type, $varlist) = each %$declare) {
130 print "\t$type ", join(", ", @$varlist), ";\n";
132 foreach $line (@$runtime) {
142 push_runtime("\t$line");
148 $runtime_list_ref = [];
151 declare("I32", "oldsave");
152 declare("SV", "**svp");
153 map { declare("SV", "*$_") } qw(sv src dst left right);
154 declare("MAGIC", "*mg");
155 $decl->add("static OP * $ppname (pTHX);");
156 debug "init_pp: $ppname\n" if $debug_queue;
159 # Initialise runtime_callback function for Stackobj class
160 BEGIN { B::Stackobj::set_callback(\&runtime) }
162 # Initialise saveoptree_callback for B::C class
164 my ($name, $root, $start, @pl) = @_;
165 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
167 if ($name eq "*ignore*") {
170 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
172 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
173 $start = $fakeop->save;
174 debug "cc_queue: name $name returns $start\n" if $debug_queue;
177 BEGIN { B::C::set_callback(\&cc_queue) }
179 sub valid_int { $_[0]->{flags} & VALID_INT }
180 sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
181 sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
182 sub valid_sv { $_[0]->{flags} & VALID_SV }
184 sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
185 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
186 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
187 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
188 sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
190 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
191 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
192 sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
193 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
196 return ((pop @stack)->as_bool);
198 # Careful: POPs has an auto-decrement and SvTRUE evaluates
199 # its argument more than once.
200 runtime("sv = POPs;");
205 sub write_back_lexicals {
206 my $avoid = shift || 0;
207 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
210 foreach $lex (@pad) {
211 next unless ref($lex);
212 $lex->write_back unless $lex->{flags} & $avoid;
216 sub write_back_stack {
218 return unless @stack;
219 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
220 foreach $obj (@stack) {
221 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
226 sub invalidate_lexicals {
227 my $avoid = shift || 0;
228 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
231 foreach $lex (@pad) {
232 next unless ref($lex);
233 $lex->invalidate unless $lex->{flags} & $avoid;
237 sub reload_lexicals {
239 foreach $lex (@pad) {
240 next unless ref($lex);
241 my $type = $lex->{type};
242 if ($type == T_INT) {
244 } elsif ($type == T_DOUBLE) {
253 package B::Pseudoreg;
255 # This class allocates pseudo-registers (OK, so they're C variables).
257 my %alloc; # Keyed by variable name. A value of 1 means the
258 # variable has been declared. A value of 2 means
261 sub new_scope { %alloc = () }
264 my ($class, $type, $prefix) = @_;
265 my ($ptr, $i, $varname, $status, $obj);
266 $prefix =~ s/^(\**)//;
270 $varname = "$prefix$i";
271 $status = $alloc{$varname};
272 } while $status == 2;
275 B::CC::declare($type, "$ptr$varname");
276 $alloc{$varname} = 2; # declared and in use
278 $obj = bless \$varname, $class;
283 $alloc{$$obj} = 1; # no longer in use but still declared
289 # This class gives a standard API for a perl object to shadow a
290 # C variable and only generate reloads/write-backs when necessary.
292 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
293 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
294 # Use $obj->invalidate whenever an unknown function may have
298 my ($class, $write_back) = @_;
299 # Object fields are perl shadow variable, validity flag
300 # (for *C* variable) and callback sub for write_back
301 # (passed perl shadow variable as argument).
302 bless [undef, 1, $write_back], $class;
305 my ($obj, $newval) = @_;
306 $obj->[1] = 0; # C variable no longer valid
312 $obj->[1] = 1; # C variable will now be valid
313 &{$obj->[2]}($obj->[0]);
316 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
318 my $curcop = new B::Shadow (sub {
319 my $opsym = shift->save;
320 runtime("PL_curcop = (COP*)$opsym;");
324 # Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
327 my $cxix = $#cxstack;
328 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
331 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
337 my $cxix = $#cxstack;
339 ($cxstack[$cxix]->{type} != CXt_LOOP ||
340 $cxstack[$cxix]->{label} ne $label)) {
343 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
349 my $file = $curcop->[0]->filegv->SV->PV;
350 my $line = $curcop->[0]->line;
353 warn sprintf("%s:%d: $format\n", $file, $line, @_);
355 warn sprintf("%s:%d: %s\n", $file, $line, $format);
360 # Load pad takes (the elements of) a PADLIST as arguments and loads
361 # up @pad with Stackobj-derived objects which represent those lexicals.
362 # If/when perl itself can generate type information (my int $foo) then
363 # we'll take advantage of that here. Until then, we'll use various hacks
364 # to tell the compiler when we want a lexical to be a particular type
365 # or to be a register.
368 my ($namelistav, $valuelistav) = @_;
370 my @namelist = $namelistav->ARRAY;
371 my @valuelist = $valuelistav->ARRAY;
374 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
375 # Temporary lexicals don't get named so it's possible for @valuelist
376 # to be strictly longer than @namelist. We count $ix up to the end of
377 # @valuelist but index into @namelist for the name. Any temporaries which
378 # run off the end of @namelist will make $namesv undefined and we treat
379 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
380 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
381 for ($ix = 1; $ix < @valuelist; $ix++) {
382 my $namesv = $namelist[$ix];
383 my $type = T_UNKNOWN;
386 my $class = class($namesv);
387 if (!defined($namesv) || $class eq "SPECIAL") {
388 # temporaries have &PL_sv_undef instead of a PVNV for a name
389 $flags = VALID_SV|TEMPORARY|REGISTER;
391 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
395 $flags = VALID_SV|VALID_INT;
396 } elsif ($2 eq "d") {
398 $flags = VALID_SV|VALID_DOUBLE;
400 $flags |= REGISTER if $3;
403 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
404 "i_$name", "d_$name");
406 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
412 for ($ix = 1; $ix <= $#pad; $ix++) {
413 my $type = $pad[$ix]->{type};
414 declare("IV", $type == T_INT ?
415 sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
416 declare("double", $type == T_DOUBLE ?
417 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
424 sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
432 # XXX Preserve original label name for "real" labels?
433 return sprintf("lab_%x", $$op);
438 push_runtime(sprintf(" %s:", label($op)));
443 my $opsym = $op->save;
444 runtime("PL_op = $opsym;") unless $know_op;
450 my $ppname = $op->ppaddr;
451 my $sym = loadop($op);
452 runtime("DOOP($ppname);");
459 my $flags = $op->flags;
460 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
464 # Code generation for PP code
474 my $gimme = gimme($op);
475 if ($gimme != G_ARRAY) {
476 my $obj= new B::Stackobj::Const(sv_undef);
478 # XXX Change to push a constant sv_undef Stackobj onto @stack
480 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
488 runtime("PP_UNSTACK;");
494 my $next = $op->next;
496 unshift(@bblock_todo, $next);
498 my $bool = pop_bool();
500 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
502 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
510 my $next = $op->next;
512 unshift(@bblock_todo, $next);
514 my $bool = pop_bool @stack;
516 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
517 $bool, label($next)));
519 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
527 my $false = $op->next;
528 unshift(@bblock_todo, $false);
530 my $bool = pop_bool();
532 runtime(sprintf("if (!$bool) goto %s;", label($false)));
539 push(@stack, $pad[$ix]);
540 if ($op->flags & OPf_MOD) {
541 my $private = $op->private;
542 if ($private & OPpLVAL_INTRO) {
543 runtime("SAVECLEARSV(PL_curpad[$ix]);");
544 } elsif ($private & OPpDEREF) {
545 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
546 $ix, $private & OPpDEREF));
547 $pad[$ix]->invalidate;
556 my $obj = $constobj{$$sv};
557 if (!defined($obj)) {
558 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
568 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
569 runtime("TAINT_NOT;") unless $omit_taint;
570 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
571 if ($freetmps_each_bblock || $freetmps_each_loop) {
574 runtime("FREETMPS;");
581 $curcop->invalidate; # XXX?
582 return default_pp($op);
585 #default_pp will handle this:
586 #sub pp_bless { $curcop->write_back; default_pp(@_) }
587 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
588 # The following subs need $curcop->write_back if we decide to support arybase:
589 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
590 #sub pp_caller { $curcop->write_back; default_pp(@_) }
591 #sub pp_reset { $curcop->write_back; default_pp(@_) }
596 write_back_lexicals() unless $skip_lexicals{$ppname};
597 write_back_stack() unless $skip_stack{$ppname};
599 if ($op->private & OPpDEREF) {
600 $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
601 $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
608 my $ppname = $op->ppaddr;
609 if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
610 #this indicates the sort BLOCK Array case
611 #ugly surgery required.
612 my $root=$op->first->sibling->first;
613 my $start=$root->first;
615 $op->first->sibling->save;
617 my $sym=$start->save;
618 my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
619 $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
622 write_back_lexicals();
629 my $gvsym = $op->gv->save;
631 runtime("XPUSHs((SV*)$gvsym);");
637 my $gvsym = $op->gv->save;
639 if ($op->private & OPpLVAL_INTRO) {
640 runtime("XPUSHs(save_scalar($gvsym));");
642 runtime("XPUSHs(GvSV($gvsym));");
649 my $gvsym = $op->gv->save;
650 my $ix = $op->private;
651 my $flag = $op->flags & OPf_MOD;
653 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
654 "PUSHs(svp ? *svp : &PL_sv_undef);");
659 my ($op, $operator) = @_;
660 if ($op->flags & OPf_STACKED) {
661 my $right = pop_int();
663 my $left = top_int();
664 $stack[-1]->set_int(&$operator($left, $right));
666 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
669 my $targ = $pad[$op->targ];
670 my $right = new B::Pseudoreg ("IV", "riv");
671 my $left = new B::Pseudoreg ("IV", "liv");
672 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
673 $targ->set_int(&$operator($$left, $$right));
679 sub INTS_CLOSED () { 0x1 }
680 sub INT_RESULT () { 0x2 }
681 sub NUMERIC_RESULT () { 0x4 }
684 my ($op, $operator, $flags) = @_;
686 $force_int ||= ($flags & INT_RESULT);
687 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
688 && valid_int($stack[-2]) && valid_int($stack[-1]));
689 if ($op->flags & OPf_STACKED) {
690 my $right = pop_numeric();
692 my $left = top_numeric();
694 $stack[-1]->set_int(&$operator($left, $right));
696 $stack[-1]->set_numeric(&$operator($left, $right));
700 my $rightruntime = new B::Pseudoreg ("IV", "riv");
701 runtime(sprintf("$$rightruntime = %s;",$right));
702 runtime(sprintf("sv_setiv(TOPs, %s);",
703 &$operator("TOPi", $$rightruntime)));
705 my $rightruntime = new B::Pseudoreg ("double", "rnv");
706 runtime(sprintf("$$rightruntime = %s;",$right));
707 runtime(sprintf("sv_setnv(TOPs, %s);",
708 &$operator("TOPn",$$rightruntime)));
712 my $targ = $pad[$op->targ];
713 $force_int ||= ($targ->{type} == T_INT);
715 my $right = new B::Pseudoreg ("IV", "riv");
716 my $left = new B::Pseudoreg ("IV", "liv");
717 runtime(sprintf("$$right = %s; $$left = %s;",
718 pop_numeric(), pop_numeric));
719 $targ->set_int(&$operator($$left, $$right));
721 my $right = new B::Pseudoreg ("double", "rnv");
722 my $left = new B::Pseudoreg ("double", "lnv");
723 runtime(sprintf("$$right = %s; $$left = %s;",
724 pop_numeric(), pop_numeric));
725 $targ->set_numeric(&$operator($$left, $$right));
734 if ($op->flags & OPf_STACKED) {
735 my $right = pop_numeric();
737 my $left = top_numeric();
738 runtime sprintf("if (%s > %s){",$left,$right);
739 $stack[-1]->set_int(1);
740 $stack[-1]->write_back();
741 runtime sprintf("}else if (%s < %s ) {",$left,$right);
742 $stack[-1]->set_int(-1);
743 $stack[-1]->write_back();
744 runtime sprintf("}else if (%s == %s) {",$left,$right);
745 $stack[-1]->set_int(0);
746 $stack[-1]->write_back();
747 runtime sprintf("}else {");
748 $stack[-1]->set_sv("&PL_sv_undef");
751 my $rightruntime = new B::Pseudoreg ("double", "rnv");
752 runtime(sprintf("$$rightruntime = %s;",$right));
753 runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
754 runtime sprintf("sv_setiv(TOPs,1);");
755 runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
756 runtime sprintf("sv_setiv(TOPs,-1);");
757 runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
758 runtime sprintf("sv_setiv(TOPs,0);");
759 runtime sprintf(qq/}else {/);
760 runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
764 my $targ = $pad[$op->targ];
765 my $right = new B::Pseudoreg ("double", "rnv");
766 my $left = new B::Pseudoreg ("double", "lnv");
767 runtime(sprintf("$$right = %s; $$left = %s;",
768 pop_numeric(), pop_numeric));
769 runtime sprintf("if (%s > %s){",$$left,$$right);
772 runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
775 runtime sprintf("}else if (%s == %s) {",$$left,$$right);
778 runtime sprintf("}else {");
779 $targ->set_sv("&PL_sv_undef");
787 my ($op, $operator, $flags) = @_;
788 if ($op->flags & OPf_STACKED) {
789 my $right = pop_sv();
792 if ($flags & INT_RESULT) {
793 $stack[-1]->set_int(&$operator($left, $right));
794 } elsif ($flags & NUMERIC_RESULT) {
795 $stack[-1]->set_numeric(&$operator($left, $right));
797 # XXX Does this work?
798 runtime(sprintf("sv_setsv($left, %s);",
799 &$operator($left, $right)));
800 $stack[-1]->invalidate;
804 if ($flags & INT_RESULT) {
806 } elsif ($flags & NUMERIC_RESULT) {
811 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
814 my $targ = $pad[$op->targ];
815 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
816 if ($flags & INT_RESULT) {
817 $targ->set_int(&$operator("left", "right"));
818 } elsif ($flags & NUMERIC_RESULT) {
819 $targ->set_numeric(&$operator("left", "right"));
821 # XXX Does this work?
822 runtime(sprintf("sv_setsv(%s, %s);",
823 $targ->as_sv, &$operator("left", "right")));
832 my ($op, $operator) = @_;
833 my $right = new B::Pseudoreg ("IV", "riv");
834 my $left = new B::Pseudoreg ("IV", "liv");
835 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
836 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
837 $bool->set_int(&$operator($$left, $$right));
842 sub bool_numeric_binop {
843 my ($op, $operator) = @_;
844 my $right = new B::Pseudoreg ("double", "rnv");
845 my $left = new B::Pseudoreg ("double", "lnv");
846 runtime(sprintf("$$right = %s; $$left = %s;",
847 pop_numeric(), pop_numeric()));
848 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
849 $bool->set_numeric(&$operator($$left, $$right));
855 my ($op, $operator) = @_;
856 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
857 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
858 $bool->set_numeric(&$operator("left", "right"));
865 return sub { "$_[0] $opname $_[1]" }
870 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
874 my $plus_op = infix_op("+");
875 my $minus_op = infix_op("-");
876 my $multiply_op = infix_op("*");
877 my $divide_op = infix_op("/");
878 my $modulo_op = infix_op("%");
879 my $lshift_op = infix_op("<<");
880 my $rshift_op = infix_op(">>");
881 my $scmp_op = prefix_op("sv_cmp");
882 my $seq_op = prefix_op("sv_eq");
883 my $sne_op = prefix_op("!sv_eq");
884 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
885 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
886 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
887 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
888 my $eq_op = infix_op("==");
889 my $ne_op = infix_op("!=");
890 my $lt_op = infix_op("<");
891 my $gt_op = infix_op(">");
892 my $le_op = infix_op("<=");
893 my $ge_op = infix_op(">=");
896 # XXX The standard perl PP code has extra handling for
897 # some special case arguments of these operators.
899 sub pp_add { numeric_binop($_[0], $plus_op) }
900 sub pp_subtract { numeric_binop($_[0], $minus_op) }
901 sub pp_multiply { numeric_binop($_[0], $multiply_op) }
902 sub pp_divide { numeric_binop($_[0], $divide_op) }
903 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
905 sub pp_left_shift { int_binop($_[0], $lshift_op) }
906 sub pp_right_shift { int_binop($_[0], $rshift_op) }
907 sub pp_i_add { int_binop($_[0], $plus_op) }
908 sub pp_i_subtract { int_binop($_[0], $minus_op) }
909 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
910 sub pp_i_divide { int_binop($_[0], $divide_op) }
911 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
913 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
914 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
915 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
916 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
917 sub pp_le { bool_numeric_binop($_[0], $le_op) }
918 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
920 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
921 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
922 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
923 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
924 sub pp_i_le { bool_int_binop($_[0], $le_op) }
925 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
927 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
928 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
929 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
930 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
931 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
932 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
933 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
939 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
944 ($src, $dst) = ($dst, $src) if $backwards;
945 my $type = $src->{type};
946 if ($type == T_INT) {
947 $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
948 } elsif ($type == T_DOUBLE) {
949 $dst->set_numeric($src->as_numeric);
951 $dst->set_sv($src->as_sv);
954 } elsif (@stack == 1) {
956 my $src = pop @stack;
957 my $type = $src->{type};
958 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
959 if ($type == T_INT) {
960 if ($src->{flags} & VALID_UNSIGNED){
961 runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
963 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
965 } elsif ($type == T_DOUBLE) {
966 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
968 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
970 runtime("SvSETMAGIC(TOPs);");
972 my $dst = $stack[-1];
973 my $type = $dst->{type};
974 runtime("sv = POPs;");
975 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
976 if ($type == T_INT) {
977 $dst->set_int("SvIV(sv)");
978 } elsif ($type == T_DOUBLE) {
979 $dst->set_double("SvNV(sv)");
981 runtime("SvSetMagicSV($dst->{sv}, sv);");
987 runtime("src = POPs; dst = TOPs;");
989 runtime("dst = POPs; src = TOPs;");
991 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
992 "SvSetSV(dst, src);",
1002 my $obj = $stack[-1];
1003 my $type = $obj->{type};
1004 if ($type == T_INT || $type == T_DOUBLE) {
1005 $obj->set_int($obj->as_int . " + 1");
1007 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
1011 runtime sprintf("PP_PREINC(TOPs);");
1019 runtime("PUSHMARK(sp);");
1026 my $gimme = gimme($op);
1027 if ($gimme == G_ARRAY) { # sic
1028 runtime("POPMARK;"); # need this even though not a "full" pp_list
1030 runtime("PP_LIST($gimme);");
1037 $curcop->write_back;
1038 write_back_lexicals(REGISTER|TEMPORARY);
1040 my $sym = doop($op);
1041 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1042 runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
1043 runtime("SPAGAIN;}");
1045 invalidate_lexicals(REGISTER|TEMPORARY);
1050 my $ppname = $op->ppaddr;
1051 write_back_lexicals() unless $skip_lexicals{$ppname};
1052 write_back_stack() unless $skip_stack{$ppname};
1054 # See comment in pp_grepwhile to see why!
1055 $init->add("((LISTOP*)$sym)->op_first = $sym;");
1056 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
1057 runtime( sprintf("goto %s;",label($op->first)));
1065 my $ppname = $op->ppaddr;
1066 write_back_lexicals() unless $skip_lexicals{$ppname};
1067 write_back_stack() unless $skip_stack{$ppname};
1069 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
1070 invalidate_lexicals() unless $skip_invalidate{$ppname};
1079 write_back_lexicals() unless $skip_lexicals{$ppname};
1080 write_back_stack() unless $skip_stack{$ppname};
1081 runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
1082 runtime("\tPUTBACK;return 0;");
1089 write_back_lexicals(REGISTER|TEMPORARY);
1091 my $sym = doop($op);
1092 # XXX Is this the right way to distinguish between it returning
1093 # CvSTART(cv) (via doform) and pop_return()?
1094 #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
1095 runtime("SPAGAIN;");
1097 invalidate_lexicals(REGISTER|TEMPORARY);
1103 $curcop->write_back;
1104 write_back_lexicals(REGISTER|TEMPORARY);
1106 my $sym = loadop($op);
1107 my $ppaddr = $op->ppaddr;
1108 #runtime(qq/printf("$ppaddr type eval\n");/);
1109 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
1111 invalidate_lexicals(REGISTER|TEMPORARY);
1115 sub pp_entereval { doeval(@_) }
1116 sub pp_dofile { doeval(@_) }
1118 #pp_require is protected by pp_entertry, so no protection for it.
1121 $curcop->write_back;
1122 write_back_lexicals(REGISTER|TEMPORARY);
1124 my $sym = doop($op);
1125 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
1126 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
1127 runtime("SPAGAIN;}");
1129 invalidate_lexicals(REGISTER|TEMPORARY);
1136 $curcop->write_back;
1137 write_back_lexicals(REGISTER|TEMPORARY);
1139 my $sym = doop($op);
1140 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
1141 declare("JMPENV", $jmpbuf);
1142 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1143 invalidate_lexicals(REGISTER|TEMPORARY);
1150 runtime("PP_LEAVETRY;");
1156 if ($need_freetmps && $freetmps_each_loop) {
1157 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1164 my $nexttonext=$next->next;
1166 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1167 label($nexttonext)));
1168 return $op->next->other;
1173 if ($need_freetmps && $freetmps_each_loop) {
1174 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1178 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1179 # we need to be able to distinguish the two at runtime.
1183 my $nexttonext=$next->next;
1185 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1186 label($nexttonext)));
1187 return $op->next->other;
1192 my $next = $op->next;
1193 unshift(@bblock_todo, $next);
1194 write_back_lexicals();
1196 my $sym = doop($op);
1197 # pp_grepwhile can return either op_next or op_other and we need to
1198 # be able to distinguish the two at runtime. Since it's possible for
1199 # both ops to be "inlined", the fields could both be zero. To get
1200 # around that, we hack op_next to be our own op (purely because we
1201 # know it's a non-NULL pointer and can't be the same as op_other).
1202 $init->add("((LOGOP*)$sym)->op_next = $sym;");
1203 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
1214 write_back_lexicals(REGISTER|TEMPORARY);
1217 runtime("PUTBACK;", "return PL_op;");
1224 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1225 return default_pp($op);
1230 my $flags = $op->flags;
1231 if (!($flags & OPf_WANT)) {
1232 error("context of range unknown at compile-time");
1234 write_back_lexicals();
1236 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
1237 # We need to save our UNOP structure since pp_flop uses
1238 # it to find and adjust out targ. We don't need it ourselves.
1240 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
1241 $op->targ, label($op->other));
1242 unshift(@bblock_todo, $op->other);
1249 my $flags = $op->flags;
1250 if (!($flags & OPf_WANT)) {
1251 error("context of flip unknown at compile-time");
1253 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
1254 return $op->first->other;
1256 write_back_lexicals();
1258 # We need to save our UNOP structure since pp_flop uses
1259 # it to find and adjust out targ. We don't need it ourselves.
1262 my $rangeix = $op->first->targ;
1263 runtime(($op->private & OPpFLIP_LINENUM) ?
1264 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
1265 : "if (SvTRUE(TOPs)) {");
1266 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
1267 if ($op->flags & OPf_SPECIAL) {
1268 runtime("sv_setiv(PL_curpad[$ix], 1);");
1270 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
1272 sprintf("\tgoto %s;", label($op->first->other)));
1275 qq{sv_setpv(PL_curpad[$ix], "");},
1276 "SETs(PL_curpad[$ix]);");
1290 my $nextop = $op->nextop;
1291 my $lastop = $op->lastop;
1292 my $redoop = $op->redoop;
1293 $curcop->write_back;
1294 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1298 "label" => $curcop->[0]->label,
1306 return default_pp($op);
1309 sub pp_enterloop { enterloop(@_) }
1310 sub pp_enteriter { enterloop(@_) }
1315 die "panic: leaveloop";
1317 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1319 return default_pp($op);
1325 if ($op->flags & OPf_SPECIAL) {
1326 $cxix = dopoptoloop();
1328 error('"next" used outside loop');
1329 return $op->next; # ignore the op
1332 $cxix = dopoptolabel($op->pv);
1334 error('Label not found at compile time for "next %s"', $op->pv);
1335 return $op->next; # ignore the op
1339 my $nextop = $cxstack[$cxix]->{nextop};
1340 push(@bblock_todo, $nextop);
1341 runtime(sprintf("goto %s;", label($nextop)));
1348 if ($op->flags & OPf_SPECIAL) {
1349 $cxix = dopoptoloop();
1351 error('"redo" used outside loop');
1352 return $op->next; # ignore the op
1355 $cxix = dopoptolabel($op->pv);
1357 error('Label not found at compile time for "redo %s"', $op->pv);
1358 return $op->next; # ignore the op
1362 my $redoop = $cxstack[$cxix]->{redoop};
1363 push(@bblock_todo, $redoop);
1364 runtime(sprintf("goto %s;", label($redoop)));
1371 if ($op->flags & OPf_SPECIAL) {
1372 $cxix = dopoptoloop();
1374 error('"last" used outside loop');
1375 return $op->next; # ignore the op
1378 $cxix = dopoptolabel($op->pv);
1380 error('Label not found at compile time for "last %s"', $op->pv);
1381 return $op->next; # ignore the op
1383 # XXX Add support for "last" to leave non-loop blocks
1384 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1385 error('Use of "last" for non-loop blocks is not yet implemented');
1386 return $op->next; # ignore the op
1390 my $lastop = $cxstack[$cxix]->{lastop}->next;
1391 push(@bblock_todo, $lastop);
1392 runtime(sprintf("goto %s;", label($lastop)));
1398 write_back_lexicals();
1400 my $sym = doop($op);
1401 my $replroot = $op->pmreplroot;
1403 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
1404 $sym, label($replroot));
1405 $op->pmreplstart->save;
1406 push(@bblock_todo, $replroot);
1408 invalidate_lexicals();
1414 write_back_lexicals();
1417 my $pmop = $op->other;
1418 # warn sprintf("substcont: op = %s, pmop = %s\n",
1419 # peekop($op), peekop($pmop));#debug
1420 # my $pmopsym = objsym($pmop);
1421 my $pmopsym = $pmop->save; # XXX can this recurse?
1422 # warn "pmopsym = $pmopsym\n";#debug
1423 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
1424 $pmopsym, label($pmop->pmreplstart));
1425 invalidate_lexicals();
1431 my $ppname = $op->ppaddr;
1432 if ($curcop and $need_curcop{$ppname}){
1433 $curcop->write_back;
1435 write_back_lexicals() unless $skip_lexicals{$ppname};
1436 write_back_stack() unless $skip_stack{$ppname};
1438 # XXX If the only way that ops can write to a TEMPORARY lexical is
1439 # when it's named in $op->targ then we could call
1440 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1441 # the temporaries. For now, we'll play it safe and write back the lot.
1442 invalidate_lexicals() unless $skip_invalidate{$ppname};
1448 my $ppname = $op->ppaddr;
1449 if (exists $ignore_op{$ppname}) {
1452 debug peek_stack() if $debug_stack;
1454 debug sprintf("%s [%s]\n",
1456 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1459 if (defined(&$ppname)) {
1461 return &$ppname($op);
1463 return default_pp($op);
1467 sub compile_bblock {
1469 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1473 $op = compile_op($op);
1474 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1475 write_back_stack(); # boo hoo: big loss
1481 my ($name, $root, $start, @padlist) = @_;
1485 B::Pseudoreg->new_scope;
1487 if ($debug_timings) {
1488 warn sprintf("Basic block analysis at %s\n", timing_info);
1490 $leaders = find_leaders($root, $start);
1491 my @leaders= keys %$leaders;
1492 if ($#leaders > -1) {
1493 @bblock_todo = ($start, values %$leaders) ;
1495 runtime("return PL_op?PL_op->op_next:0;");
1497 if ($debug_timings) {
1498 warn sprintf("Compilation at %s\n", timing_info);
1500 while (@bblock_todo) {
1501 $op = shift @bblock_todo;
1502 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1503 next if !defined($op) || !$$op || $done{$$op};
1504 #warn "...compiling it\n"; # debug
1507 $op = compile_bblock($op);
1508 if ($need_freetmps && $freetmps_each_bblock) {
1509 runtime("FREETMPS;");
1512 } while defined($op) && $$op && !$done{$$op};
1513 if ($need_freetmps && $freetmps_each_loop) {
1514 runtime("FREETMPS;");
1518 runtime("PUTBACK;","return PL_op;");
1519 } elsif ($done{$$op}) {
1520 runtime(sprintf("goto %s;", label($op)));
1523 if ($debug_timings) {
1524 warn sprintf("Saving runtime at %s\n", timing_info);
1526 declare_pad(@padlist) ;
1533 $start = cc_queue(@_) if @_;
1534 while ($ccinfo = shift @cc_todo) {
1541 my ($name, $cvref) = @_;
1542 my $cv = svref_2object($cvref);
1543 my @padlist = $cv->PADLIST->ARRAY;
1544 my $curpad_sym = $padlist[1]->save;
1545 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1549 my @comppadlist = comppadlist->ARRAY;
1550 my $curpad_nam = $comppadlist[0]->save;
1551 my $curpad_sym = $comppadlist[1]->save;
1552 my $init_av = init_av->save;
1553 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
1554 # Do save_unused_subs before saving inc_hv
1558 my $inc_hv = svref_2object(\%INC)->save;
1559 my $inc_av = svref_2object(\@INC)->save;
1560 my $amagic_generate= amagic_generation;
1562 if (!defined($module)) {
1563 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1564 "PL_main_start = $start;",
1565 "PL_curpad = AvARRAY($curpad_sym);",
1566 "PL_initav = (AV *) $init_av;",
1567 "GvHV(PL_incgv) = $inc_hv;",
1568 "GvAV(PL_incgv) = $inc_av;",
1569 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1570 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1571 "PL_amagic_generation= $amagic_generate;",
1575 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
1576 output_boilerplate();
1578 output_all("perl_init");
1582 if (defined($module)) {
1583 my $cmodule = $module;
1584 $cmodule =~ s/::/__/g;
1594 SAVESPTR(PL_curpad);
1596 PL_curpad = AvARRAY($curpad_sym);
1606 if ($debug_timings) {
1607 warn sprintf("Done at %s\n", timing_info);
1613 my ($option, $opt, $arg);
1615 while ($option = shift @options) {
1616 if ($option =~ /^-(.)(.*)/) {
1620 unshift @options, $option;
1623 if ($opt eq "-" && $arg eq "-") {
1626 } elsif ($opt eq "o") {
1627 $arg ||= shift @options;
1628 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
1629 } elsif ($opt eq "n") {
1630 $arg ||= shift @options;
1631 $module_name = $arg;
1632 } elsif ($opt eq "u") {
1633 $arg ||= shift @options;
1634 mark_unused($arg,undef);
1635 } elsif ($opt eq "f") {
1636 $arg ||= shift @options;
1637 my $value = $arg !~ s/^no-//;
1639 my $ref = $optimise{$arg};
1640 if (defined($ref)) {
1643 warn qq(ignoring unknown optimisation option "$arg"\n);
1645 } elsif ($opt eq "O") {
1646 $arg = 1 if $arg eq "";
1648 foreach $ref (values %optimise) {
1652 $freetmps_each_loop = 1;
1655 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1657 } elsif ($opt eq "m") {
1658 $arg ||= shift @options;
1660 mark_unused($arg,undef);
1661 } elsif ($opt eq "p") {
1662 $arg ||= shift @options;
1664 } elsif ($opt eq "D") {
1665 $arg ||= shift @options;
1666 foreach $arg (split(//, $arg)) {
1669 } elsif ($arg eq "O") {
1671 } elsif ($arg eq "s") {
1673 } elsif ($arg eq "c") {
1675 } elsif ($arg eq "p") {
1677 } elsif ($arg eq "r") {
1679 } elsif ($arg eq "S") {
1681 } elsif ($arg eq "q") {
1683 } elsif ($arg eq "l") {
1685 } elsif ($arg eq "t") {
1692 $init = B::Section->get("init");
1693 $decl = B::Section->get("decl");
1697 my ($objname, $ppname);
1698 foreach $objname (@options) {
1699 $objname = "main::$objname" unless $objname =~ /::/;
1700 ($ppname = $objname) =~ s/^.*?:://;
1701 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1702 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1705 output_boilerplate();
1707 output_all($module_name || "init_module");
1711 return sub { cc_main() };
1721 B::CC - Perl compiler's optimized C translation backend
1725 perl -MO=CC[,OPTIONS] foo.pl
1729 This compiler backend takes Perl source and generates C source code
1730 corresponding to the flow of your program. In other words, this
1731 backend is somewhat a "real" compiler in the sense that many people
1732 think about compilers. Note however that, currently, it is a very
1733 poor compiler in that although it generates (mostly, or at least
1734 sometimes) correct code, it performs relatively few optimisations.
1735 This will change as the compiler develops. The result is that
1736 running an executable compiled with this backend may start up more
1737 quickly than running the original Perl program (a feature shared
1738 by the B<C> compiler backend--see F<B::C>) and may also execute
1739 slightly faster. This is by no means a good optimising compiler--yet.
1743 If there are any non-option arguments, they are taken to be
1744 names of objects to be saved (probably doesn't work properly yet).
1745 Without extra arguments, it saves the main program.
1751 Output to filename instead of STDOUT
1755 Verbose compilation (currently gives a few compilation statistics).
1759 Force end of options
1763 Force apparently unused subs from package Packname to be compiled.
1764 This allows programs to use eval "foo()" even when sub foo is never
1765 seen to be used at compile time. The down side is that any subs which
1766 really are never used also have code generated. This option is
1767 necessary, for example, if you have a signal handler foo which you
1768 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1769 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1770 options. The compiler tries to figure out which packages may possibly
1771 have subs in which need compiling but the current version doesn't do
1772 it very well. In particular, it is confused by nested packages (i.e.
1773 of the form C<A::B>) where package C<A> does not contain any subs.
1775 =item B<-mModulename>
1777 Instead of generating source for a runnable executable, generate
1778 source for an XSUB module. The boot_Modulename function (which
1779 DynaLoader can look for) does the appropriate initialisation and runs
1780 the main part of the Perl source that is being compiled.
1785 Debug options (concatenated or separate flags like C<perl -D>).
1789 Writes debugging output to STDERR just as it's about to write to the
1790 program's runtime (otherwise writes debugging info as comments in
1795 Outputs each OP as it's compiled
1799 Outputs the contents of the shadow stack at each OP
1803 Outputs the contents of the shadow pad of lexicals as it's loaded for
1804 each sub or the main program.
1808 Outputs the name of each fake PP function in the queue as it's about
1813 Output the filename and line number of each original line of Perl
1814 code as it's processed (C<pp_nextstate>).
1818 Outputs timing information of compilation stages.
1822 Force optimisations on or off one at a time.
1824 =item B<-ffreetmps-each-bblock>
1826 Delays FREETMPS from the end of each statement to the end of the each
1829 =item B<-ffreetmps-each-loop>
1831 Delays FREETMPS from the end of each statement to the end of the group
1832 of basic blocks forming a loop. At most one of the freetmps-each-*
1833 options can be used.
1835 =item B<-fomit-taint>
1837 Omits generating code for handling perl's tainting mechanism.
1841 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1842 Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1843 sets B<-ffreetmps-each-loop>.
1849 perl -MO=CC,-O2,-ofoo.c foo.pl
1850 perl cc_harness -o foo foo.c
1852 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1853 library directory. The utility called C<perlcc> may also be used to
1854 help make use of this compiler.
1856 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1857 perl cc_harness -shared -c -o Foo.so Foo.c
1861 Plenty. Current status: experimental.
1865 These aren't really bugs but they are constructs which are heavily
1866 tied to perl's compile-and-go implementation and with which this
1867 compiler backend cannot cope.
1871 Standard perl calculates the target of "next", "last", and "redo"
1872 at run-time. The compiler calculates the targets at compile-time.
1873 For example, the program
1875 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1876 NUMBER: for ($i = 0; $i < 5; $i++) {
1885 with standard perl but gives a compile-time error with the compiler.
1887 =head2 Context of ".."
1889 The context (scalar or array) of the ".." operator determines whether
1890 it behaves as a range or a flip/flop. Standard perl delays until
1891 runtime the decision of which context it is in but the compiler needs
1892 to know the context at compile-time. For example,
1895 sub range { (shift @a)..(shift @a) }
1897 while (@a) { print scalar(range()) }
1899 generates the output
1903 with standard Perl but gives a compile-time error with compiled Perl.
1907 Compiled Perl programs use native C arithemtic much more frequently
1908 than standard perl. Operations on large numbers or on boundary
1909 cases may produce different behaviour.
1911 =head2 Deprecated features
1913 Features of standard perl such as C<$[> which have been deprecated
1914 in standard perl since Perl5 was released have not been implemented
1919 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>