B-C
view release on metacpan or search on metacpan
lib/B/CC.pm view on Meta::CPAN
Verbose compilation (prints a few compilation stages).
=item B<-->
Force end of options
=item B<-uPackname>
Force apparently unused subs from package Packname to be compiled.
This allows programs to use eval "foo()" even when sub foo is never
seen to be used at compile time. The down side is that any subs which
really are never used also have code generated. This option is
necessary, for example, if you have a signal handler foo which you
initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
options. The compiler tries to figure out which packages may possibly
have subs in which need compiling but the current version doesn't do
it very well. In particular, it is confused by nested packages (i.e.
of the form C<A::B>) where package C<A> does not contain any subs.
=item B<-UPackname> "unuse" skip Package
Ignore all subs from Package to be compiled.
Certain packages might not be needed at run-time, even if the pessimistic
walker detects it.
=item B<-mModulename>
Instead of generating source for a runnable executable, generate
source for an XSUB module. The boot_Modulename function (which
DynaLoader can look for) does the appropriate initialisation and runs
the main part of the Perl source that is being compiled.
=item B<-nInitname>
Provide a different init name for additional objects added via cmdline.
=item B<-strict>
With a DEBUGGING perl compile-time errors for range and flip without
compile-time context are only warnings.
With C<-strict> these warnings are fatal, otherwise only run-time errors occur.
=item B<-On>
Optimisation level (n = 0, 1, 2). B<-O> means B<-O1>.
The following L<B::C> optimisations are applied automatically:
optimize_warn_sv save_data_fh av-init2|av_init save_sig destruct
pv_copy_on_grow
B<-O1> sets B<-ffreetmps-each-bblock>.
B<-O2> adds B<-ffreetmps-each-loop>, C<-faelem> and B<-fno-destruct> from L<B::C>.
The following options must be set explicitly:
B<-fno-taint> or B<-fomit-taint>,
B<-fslow-signals>,
B<-no-autovivify>,
B<-fno-magic>.
=item B<-f>C<OPTIM>
Force optimisations on or off one at a time.
Unknown optimizations are passed down to L<B::C>.
=item B<-ffreetmps-each-bblock>
Delays FREETMPS from the end of each statement to the end of the each
basic block.
Enabled with B<-O1>.
=item B<-ffreetmps-each-loop>
Delays FREETMPS from the end of each statement to the end of the group
of basic blocks forming a loop. At most one of the freetmps-each-*
options can be used.
Enabled with B<-O2>.
=item B<-faelem>
Enable array element access optimizations, allowing unchecked
fast access under certain circumstances.
Enabled with B<-O2> and not-threaded perls only.
=item B<-fno-inline-ops>
Do not inline calls to certain small pp ops.
Most of the inlinable ops were already inlined.
Turns off inlining for some new ops.
AUTOMATICALLY inlined:
pp_null pp_stub pp_unstack pp_and pp_andassign pp_or pp_orassign pp_cond_expr
pp_padsv pp_const pp_nextstate pp_dbstate pp_rv2gv pp_sort pp_gv pp_gvsv
pp_aelemfast pp_ncmp pp_add pp_subtract pp_multiply pp_divide pp_modulo
pp_left_shift pp_right_shift pp_i_add pp_i_subtract pp_i_multiply pp_i_divide
pp_i_modulo pp_eq pp_ne pp_lt pp_gt pp_le pp_ge pp_i_eq pp_i_ne pp_i_lt
pp_i_gt pp_i_le pp_i_ge pp_scmp pp_slt pp_sgt pp_sle pp_sge pp_seq pp_sne
pp_sassign pp_preinc pp_pushmark pp_list pp_entersub pp_formline pp_goto
pp_enterwrite pp_leavesub pp_leavewrite pp_entergiven pp_leavegiven
pp_entereval pp_dofile pp_require pp_entertry pp_leavetry pp_grepstart
pp_mapstart pp_grepwhile pp_mapwhile pp_return pp_range pp_flip pp_flop
pp_enterloop pp_enteriter pp_leaveloop pp_next pp_redo pp_last pp_subst
pp_substcont
DONE with -finline-ops:
pp_enter pp_reset pp_regcreset pp_stringify
TODO with -finline-ops:
pp_anoncode pp_wantarray pp_srefgen pp_refgen pp_ref pp_trans pp_schop pp_chop
pp_schomp pp_chomp pp_not pp_sprintf pp_anonlist pp_shift pp_once pp_lock
pp_rcatline pp_close pp_time pp_alarm pp_av2arylen: no lvalue, pp_length: no
magic
=item B<-fomit-taint>
Omits generating code for handling perl's tainting mechanism.
=item B<-fslow-signals>
Add PERL_ASYNC_CHECK after every op as in the old Perl runloop before 5.13.
perl "Safe signals" check the state of incoming signals after every op.
See L<http://perldoc.perl.org/perlipc.html#Deferred-Signals-(Safe-Signals)>
We trade safety for more speed and delay the execution of non-IO signals
(IO signals are already handled in PerlIO) from after every single Perl op
to the same ops as used in 5.14.
Only with -fslow-signals we get the old slow and safe behaviour.
=item B<-fno-name-magic>
With the default C<-fname-magic> we infer the SCALAR type for specially named
locals vars and most ops use C vars then, not the perl vars.
Arithmetic and comparison is inlined. Scalar magic is bypassed.
With C<-fno-name-magic> do not infer a local variable type from its name:
B<_i> suffix for int, B<_d> for double/num, B<_ir> for register int
See the experimental C<-ftype-attr> type attributes.
Currently supported are B<int> and B<num> only. See </load_pad>.
=item B<-ftype-attr> (DOES NOT WORK YET)
Experimentally support B<type attributes> for B<int> and B<num>,
SCALAR only so far.
For most ops new C vars are used then, not the fat perl vars.
Very awkward to use until the basic type classes are supported from
within core or use types.
Enabled with B<-O2>. See L<TYPES> and </load_pad>.
=item B<-fno-autovivify>
Do not vivify array and soon also hash elements when accessing them.
Beware: Vivified elements default to undef, unvivified elements are
invalid.
This is the same as the pragma "no autovivification" and allows
very fast array accesses, 4-6 times faster, without the overhead of
L<autovivification>.
=item B<-fno-magic>
Assume certain data being optimized is never tied or is holding other magic.
This mainly holds for arrays being optimized, but in the future hashes also.
=item B<-D>
Debug options (concatenated or separate flags like C<perl -D>).
Verbose debugging options are crucial, because the interactive
debugger L<Od> adds a lot of ballast to the resulting code.
=item B<-Dr>
Writes debugging output to STDERR just as it's about to write to the
lib/B/CC.pm view on Meta::CPAN
output_all output_boilerplate output_main output_main_rest fixup_ppaddr
save_sig svop_or_padop_pv inc_cleanup curcv set_curcv cross_config);
use B::Bblock qw(find_leaders);
use B::Stackobj qw(:types :flags);
use B::C::Config;
# use attributes qw(get reftype);
@B::OP::ISA = qw(B); # support -Do
@B::LISTOP::ISA = qw(B::BINOP B); # support -Do
push @B::OP::ISA, 'B::NULLOP' if exists $main::B::{'NULLOP'};
# These should probably be elsewhere
# Flags for $op->flags
my $module; # module name (when compiled with -m)
my $cross; # cross config.sh path
my %done; # hash keyed by $$op of leaders of basic blocks
# which have already been done.
my $leaders; # ref to hash of basic block leaders. Keys are $$op
# addresses, values are the $op objects themselves.
my @bblock_todo; # list of leaders of basic blocks that need visiting
# sometime.
my @cc_todo; # list of tuples defining what PP code needs to be
# saved (e.g. CV, main or PMOP repl code). Each tuple
# is [$name, $root, $start, @padlist]. PMOP repl code
# tuples inherit padlist.
my %cc_pp_sub; # hashed names of pp_sub functions already saved
my @stack; # shadows perl's stack when contents are known.
# Values are objects derived from class B::Stackobj
my @pad; # Lexicals in current pad as Stackobj-derived objects
my @padlist; # Copy of current padlist so PMOP repl code can find it
my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
# This covers only a small part of the perl cxstack
my $labels; # hashref to array of op labels
my %constobj; # OP_CONST constants as Stackobj-derived objects
# keyed by $$sv.
my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
# block or even to the end of each loop of blocks,
# depending on optimisation options.
my $know_op = 0; # Set when C variable op already holds the right op
# (from an immediately preceding DOOP(ppname)).
my $errors = 0; # Number of errors encountered
my $op_count = 0; # for B::compile_stats on verbose
my %no_stack; # PP names which don't need save pp restore stack
my %skip_stack; # PP names which don't need write_back_stack (empty)
my %skip_lexicals; # PP names which don't need write_back_lexicals
my %skip_invalidate; # PP names which don't need invalidate_lexicals
my %ignore_op; # ops which do nothing except returning op_next
my %need_curcop; # ops which need PL_curcop
my $package_pv; # sv->pv of previous op for method_named
my %lexstate; # state of padsvs at the start of a bblock
my ( $verbose, $check );
my ( $entertry_defined, $vivify_ref_defined );
my ( $init_name, %debug, $strict );
# Optimisation options. On the command line, use hyphens instead of
# underscores for compatibility with gcc-style options. We use
# underscores here because they are OK in (strict) barewords.
# Disable with -fno-
my ( $freetmps_each_bblock, $freetmps_each_loop, $inline_ops, $opt_taint, $opt_omit_taint,
$opt_slow_signals, $opt_name_magic, $opt_type_attr, $opt_autovivify, $opt_magic,
$opt_aelem, %c_optimise );
$inline_ops = 1 unless $^O eq 'MSWin32'; # Win32 cannot link to unexported pp_op() XXX
$opt_name_magic = 1;
my %optimise = (
freetmps_each_bblock => \$freetmps_each_bblock, # -O1
freetmps_each_loop => \$freetmps_each_loop, # -O2
aelem => \$opt_aelem, # -O2
inline_ops => \$inline_ops, # not on Win32
omit_taint => \$opt_omit_taint,
taint => \$opt_taint,
slow_signals => \$opt_slow_signals,
name_magic => \$opt_name_magic,
type_attr => \$opt_type_attr,
autovivify => \$opt_autovivify,
magic => \$opt_magic,
);
my %async_signals = map { $_ => 1 } # 5.14 ops which do PERL_ASYNC_CHECK
qw(wait waitpid nextstate and cond_expr unstack or subst dorassign);
$async_signals{$_} = 1 for # more 5.16 ops which do PERL_ASYNC_CHECK
qw(substcont next redo goto leavewhen);
# perl patchlevel to generate code for (defaults to current patchlevel)
my $patchlevel = int( 0.5 + 1000 * ( $] - 5 ) ); # XXX unused?
my $MULTI = $Config{usemultiplicity};
my $ITHREADS = $Config{useithreads};
my $PERL510 = ( $] >= 5.009005 );
my $PERL512 = ( $] >= 5.011 );
my $SVt_PVLV = $PERL510 ? 10 : 9;
my $SVt_PVAV = $PERL510 ? 11 : 10;
# use sub qw(CXt_LOOP_PLAIN CXt_LOOP);
BEGIN {
if ($PERL512) {
sub CXt_LOOP_PLAIN {5} # CXt_LOOP_FOR CXt_LOOP_LAZYSV CXt_LOOP_LAZYIV
} else {
sub CXt_LOOP {3}
}
sub CxTYPE_no_LOOP {
$PERL512
? ( $_[0]->{type} < 4 or $_[0]->{type} > 7 )
: $_[0]->{type} != 3
}
if ($] < 5.008) {
eval "sub SVs_RMG {0x8000};";
} else {
B->import('SVs_RMG');
}
if ($] <= 5.010) {
eval "sub PMf_ONCE() {0xff}; # unused";
} elsif ($] >= 5.018) { # PMf_ONCE not exported
eval q[sub PMf_ONCE(){ 0x10000 }];
} elsif ($] >= 5.014) {
eval q[sub PMf_ONCE(){ 0x8000 }];
} elsif ($] >= 5.012) {
eval q[sub PMf_ONCE(){ 0x0080 }];
} else { # 5.10. not used with <= 5.8
eval q[sub PMf_ONCE(){ 0x0002 }];
}
}
# Could rewrite push_runtime() and output_runtime() to use a
# temporary file if memory is at a premium.
my $ppname; # name of current fake PP function
my $runtime_list_ref;
my $declare_ref; # Hash ref keyed by C variable type of declarations.
my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
# tuples to be written out.
my ( $init, $decl );
lib/B/CC.pm view on Meta::CPAN
}
}
return $op->next;
}
# coverage: 1-5,7-14,18-23,25,27-32
sub pp_const {
my $op = shift;
my $sv = $op->sv;
my $obj;
# constant could be in the pad (under useithreads)
if ($$sv) {
$obj = $constobj{$$sv};
if ( !defined($obj) ) {
$obj = $constobj{$$sv} = B::Stackobj::Const->new($sv);
}
}
else {
$obj = $pad[ $op->targ ];
}
# XXX looks like method_named has only const as prev op
if ($op->next
and $op->next->can('name')
and $op->next->name eq 'method_named'
) {
$package_pv = svop_or_padop_pv($op);
debug "save package_pv \"$package_pv\" for method_name\n" if $debug{op};
}
push( @stack, $obj );
return $op->next;
}
# coverage: 1-39, fails in 33
sub pp_nextstate {
my $op = shift;
if ($labels->{'nextstate'}->[-1] and $labels->{'nextstate'}->[-1] == $op) {
debug sprintf("pop_label nextstate: cxstack label %s\n", $curcop->[0]->label) if $debug{cxstack};
pop_label 'nextstate';
} else {
write_label($op);
}
$curcop->load($op);
loadop($op);
#testcc 48: protect CopFILE_free and CopSTASH_free in END block (#296)
if ($ppname =~ /^pp_sub_END(_\d+)?$/ and $ITHREADS) {
runtime("#ifdef USE_ITHREADS",
"CopFILE((COP*)PL_op) = NULL;");
if ($] >= 5.018) {
runtime("CopSTASH_set((COP*)PL_op, NULL);");
} elsif ($] >= 5.016 and $] <= 5.017) {
runtime("CopSTASHPV_set((COP*)PL_op, NULL, 0);");
} else {
runtime("CopSTASHPV_set((COP*)PL_op, NULL);");
}
runtime("#endif");
}
@stack = ();
debug( sprintf( "%s:%d\n", $op->file, $op->line ) ) if $debug{lineno};
debug( sprintf( "CopLABEL %s\n", $op->label ) ) if $op->label and $debug{cxstack};
runtime("TAINT_NOT;") if $opt_taint; # TODO Not always needed (resets PL_taint = 0)
runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); # TODO reset sp not needed always
if ( $freetmps_each_bblock || $freetmps_each_loop ) {
$need_freetmps = 1;
}
else {
runtime("FREETMPS;"); # TODO Not always needed
}
return $op->next;
}
# Like pp_nextstate, but used instead when the debugger is active.
sub pp_dbstate { pp_nextstate(@_) }
#default_pp will handle this:
#sub pp_bless { $curcop->write_back; default_pp(@_) }
#sub pp_repeat { $curcop->write_back; default_pp(@_) }
# The following subs need $curcop->write_back if we decide to support arybase:
# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
#sub pp_caller { $curcop->write_back; default_pp(@_) }
# coverage: ny
sub bad_pp_reset {
if ($inline_ops) {
my $op = shift;
warn "inlining reset\n" if $debug{op};
$curcop->write_back if $curcop;
runtime '{ /* pp_reset */';
runtime ' const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;';
runtime ' sv_reset(tmps, CopSTASH(PL_curcop));}';
runtime 'PUSHs(&PL_sv_yes);';
return $op->next;
} else {
default_pp(@_);
}
}
# coverage: 20
sub pp_regcreset {
if ($inline_ops) {
my $op = shift;
warn "inlining regcreset\n" if $debug{op};
$curcop->write_back if $curcop;
runtime 'PL_reginterp_cnt = 0; /* pp_regcreset */';
runtime 'TAINT_NOT;' if $opt_taint;
return $op->next;
} else {
default_pp(@_);
}
}
# coverage: 103
sub pp_stringify {
if ($inline_ops and $] >= 5.008) {
my $op = shift;
warn "inlining stringify\n" if $debug{op};
my $sv = top_sv();
my $ix = $op->targ;
my $targ = $pad[$ix];
runtime "sv_copypv(PL_curpad[$ix], $sv);\t/* pp_stringify */";
$stack[-1] = $targ if @stack;
return $op->next;
} else {
default_pp(@_);
}
}
# coverage: 9,10,27
sub bad_pp_anoncode {
if ($inline_ops) {
my $op = shift;
warn "inlining anoncode\n" if $debug{op};
my $ix = $op->targ;
my $ppname = "pp_" . $op->name;
write_back_lexicals() unless $skip_lexicals{$ppname};
write_back_stack() unless $skip_stack{$ppname};
# XXX finish me. this works only with >= 5.10
runtime '{ /* pp_anoncode */',
' CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));',
' if (CvCLONE(cv))',
' cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(Perl_cv_clone(aTHX_ cv))));',
' EXTEND(SP,1);',
' PUSHs(MUTABLE_SV(cv));',
'}';
invalidate_lexicals() unless $skip_invalidate{$ppname};
return $op->next;
} else {
default_pp(@_);
}
}
# coverage: 35
# XXX TODO get prev op. For now saved in pp_const.
sub pp_method_named {
my ( $op ) = @_;
my $name = svop_or_padop_pv($op);
# The pkg PV is at [PL_stack_base+TOPMARK+1], the previous op->sv->PV.
my $stash = $package_pv ? $package_pv."::" : "main::";
$name = $stash . $name;
if (exists &$name) {
debug "save method_name \"$name\"\n" if $debug{op};
svref_2object( \&{$name} )->save;
} else {
debug "skip saving non-existing method_name \"$name\"\n" if $debug{op}; #CC 50
}
lib/B/CC.pm view on Meta::CPAN
sub pp_le { bool_numeric_binop( $_[0], $le_op ) }
sub pp_ge { bool_numeric_binop( $_[0], $ge_op ) }
sub pp_i_eq { bool_int_binop( $_[0], $eq_op ) }
sub pp_i_ne { bool_int_binop( $_[0], $ne_op ) }
sub pp_i_lt { bool_int_binop( $_[0], $lt_op ) }
sub pp_i_gt { bool_int_binop( $_[0], $gt_op ) }
sub pp_i_le { bool_int_binop( $_[0], $le_op ) }
sub pp_i_ge { bool_int_binop( $_[0], $ge_op ) }
sub pp_scmp { sv_binop( $_[0], $scmp_op, INT_RESULT ) }
sub pp_slt { bool_sv_binop( $_[0], $slt_op ) }
sub pp_sgt { bool_sv_binop( $_[0], $sgt_op ) }
sub pp_sle { bool_sv_binop( $_[0], $sle_op ) }
sub pp_sge { bool_sv_binop( $_[0], $sge_op ) }
sub pp_seq { bool_sv_binop( $_[0], $seq_op ) }
sub pp_sne { bool_sv_binop( $_[0], $sne_op ) }
# sub pp_sin { numeric_unop( $_[0], prefix_op("Perl_sin"), NUMERIC_RESULT ) }
# sub pp_cos { numeric_unop( $_[0], prefix_op("Perl_cos"), NUMERIC_RESULT ) }
# sub pp_exp { numeric_unop( $_[0], prefix_op("Perl_exp"), NUMERIC_RESULT ) }
# sub pp_abs { numeric_unop( $_[0], prefix_op("abs") ) }
# sub pp_negate { numeric_unop( $_[0], sub { "- $_[0]" }; ) }
# pow has special perl logic
## sub pp_pow { numeric_binop( $_[0], prefix_op("Perl_pow"), NUMERIC_RESULT ) }
#XXX log and sqrt need to check negative args
# sub pp_sqrt { numeric_unop( $_[0], prefix_op("Perl_sqrt"), NUMERIC_RESULT ) }
# sub pp_log { numeric_unop( $_[0], prefix_op("Perl_log"), NUMERIC_RESULT ) }
# sub pp_atan2 { numeric_binop( $_[0], prefix_op("Perl_atan2"), NUMERIC_RESULT ) }
}
# coverage: 3,4,9,10,11,12,17,18,20,21,23
sub pp_sassign {
my $op = shift;
my $backwards = $op->private & OPpASSIGN_BACKWARDS;
debug( sprintf( "sassign->private=0x%x\n", $op->private ) ) if $debug{op};
my ( $dst, $src );
runtime("/* pp_sassign */") if $verbose;
if ( @stack >= 2 ) {
$dst = pop @stack;
$src = pop @stack;
( $src, $dst ) = ( $dst, $src ) if $backwards;
my $type = $src->{type};
if ( $type == T_INT ) {
$dst->set_int( $src->as_int, $src->{flags} & VALID_UNSIGNED );
}
elsif ( $type == T_NUM ) {
$dst->set_numeric( $src->as_numeric );
}
else {
$dst->set_sv( $src->as_sv );
}
push( @stack, $dst );
}
elsif ( @stack == 1 ) {
if ($backwards) {
my $src = pop @stack;
my $type = $src->{type};
runtime("if (PL_tainting && PL_tainted) TAINT_NOT;") if $opt_taint;
if ( $type == T_INT ) {
if ( $src->{flags} & VALID_UNSIGNED ) {
runtime sprintf( "sv_setuv(TOPs, %s);", $src->as_int );
}
else {
runtime sprintf( "sv_setiv(TOPs, %s);", $src->as_int );
}
}
elsif ( $type == T_NUM ) {
runtime sprintf( "sv_setnv(TOPs, %s);", $src->as_double );
}
else {
runtime sprintf( "sv_setsv(TOPs, %s);", $src->as_sv );
}
runtime("SvSETMAGIC(TOPs);") if $opt_magic;
}
else {
my $dst = $stack[-1];
my $type = $dst->{type};
runtime("sv = POPs;");
runtime("MAYBE_TAINT_SASSIGN_SRC(sv);") if $opt_taint;
if ( $type == T_INT ) {
$dst->set_int("SvIV(sv)");
}
elsif ( $type == T_NUM ) {
$dst->set_double("SvNV(sv)");
}
else {
$opt_magic
? runtime("SvSetMagicSV($dst->{sv}, sv);")
: runtime("SvSetSV($dst->{sv}, sv);");
$dst->invalidate;
}
}
}
else {
# empty perl stack, both at run-time
if ($backwards) {
runtime("src = POPs; dst = TOPs;");
}
else {
runtime("dst = POPs; src = TOPs;");
}
runtime(
$opt_taint ? "MAYBE_TAINT_SASSIGN_SRC(src);" : "",
"SvSetSV(dst, src);",
$opt_magic ? "SvSETMAGIC(dst);" : "",
"SETs(dst);"
);
}
return $op->next;
}
# coverage: ny
sub pp_preinc {
my $op = shift;
if ( @stack >= 1 ) {
my $obj = $stack[-1];
my $type = $obj->{type};
if ( $type == T_INT || $type == T_NUM ) {
$obj->set_int( $obj->as_int . " + 1" );
}
else {
runtime sprintf( "PP_PREINC(%s);", $obj->as_sv );
$obj->invalidate();
}
}
else {
runtime sprintf("PP_PREINC(TOPs);");
}
return $op->next;
}
# coverage: 1-32,35
sub pp_pushmark {
my $op = shift;
# runtime(sprintf("/* %s */", $op->name)) if $verbose;
write_back_stack();
runtime("PUSHMARK(sp);");
return $op->next;
}
# coverage: 28
sub pp_list {
my $op = shift;
runtime(sprintf("/* %s */", $op->name)) if $verbose;
write_back_stack();
my $gimme = gimme($op);
if ( not defined $gimme ) {
runtime("PP_LIST(block_gimme());");
} elsif ( $gimme == G_ARRAY ) { # sic
runtime("POPMARK;"); # need this even though not a "full" pp_list
}
else {
runtime("PP_LIST($gimme);");
}
return $op->next;
}
# coverage: 6,8,9,10,24,26,27,31,35
sub pp_entersub {
my $op = shift;
runtime(sprintf("/* %s */", $op->name)) if $verbose;
$curcop->write_back if $curcop;
write_back_lexicals( REGISTER | TEMPORARY );
lib/B/CC.pm view on Meta::CPAN
print "/* using B::CC $B::CC::VERSION backend */\n";
output_boilerplate();
print "\n";
output_all("perl_init");
output_runtime();
print "\n";
output_main_rest();
if ( defined($module) ) {
my $cmodule = $module ||= 'main';
$cmodule =~ s/::/__/g;
print <<"EOT";
#include "XSUB.h"
XS(boot_$cmodule)
{
dVAR;
dXSARGS;
perl_init();
ENTER;
SAVETMPS;
SAVEVPTR(PL_curpad);
SAVEVPTR(PL_op);
PL_curpad = AvARRAY($curpad_sym);
PL_op = $start;
pp_main(aTHX);
FREETMPS;
LEAVE;
ST(0) = &PL_sv_yes;
XSRETURN(1);
}
EOT
} else {
output_main();
}
if ( $debug{timings} ) {
warn sprintf( "Done at %s\n", timing_info );
}
}
sub compile_stats {
my $s = "Total number of OPs processed: $op_count\n";
$s .= "Total number of unresolved symbols: $B::C::unresolved_count\n"
if $B::C::unresolved_count;
return $s;
}
# Accessible via use B::CC '-ftype-attr'; in user code, or -MB::CC=-O2 on the cmdline
sub import {
my @options = @_;
# Allow debugging in CHECK blocks without Od
$DB::single = 1 if defined &DB::DB;
my ( $option, $opt, $arg );
# init with -O0
foreach my $ref ( values %optimise ) {
$$ref = 0;
}
$B::C::fold = 0 if $] >= 5.013009; # utf8::Cased tables
$B::C::warnings = 0 if $] >= 5.013005; # Carp warnings categories and B
$B::C::destruct = 0 unless $] < 5.008; # fast_destruct
$opt_taint = 1;
$opt_magic = 1; # only makes sense with -fno-magic
$opt_autovivify = 1; # only makes sense with -fno-autovivify
OPTION:
while ( $option = shift @options ) {
if ( $option =~ /^-(cross)=(.*)/ ) {
$opt = $1;
$arg = $2;
}
elsif ( $option =~ /^-(.)(.*)/ ) {
$opt = $1;
$arg = $2;
}
else {
unshift @options, $option;
last OPTION;
}
if ( $opt eq "-" && $arg eq "-" ) {
shift @options;
last OPTION;
}
elsif ( $opt eq "o" ) {
$arg ||= shift @options;
open( STDOUT, ">$arg" ) or return "open '>$arg': $!\n";
}
elsif ( $opt eq "c" ) {
$check = 1;
$B::C::check = 1;
}
elsif ( $opt eq "v" ) {
$verbose = 1;
B::C::verbose(1); # crashed in C _save_common_middle(B::FAKEOP)
}
elsif ( $opt eq "u" ) {
$arg ||= shift @options;
eval "require $arg;";
mark_unused( $arg, 1 );
}
elsif ( $opt eq "U" ) {
$arg ||= shift @options;
mark_skip( $arg );
}
elsif ( $opt eq "strict" ) {
$arg ||= shift @options;
$strict++;
}
elsif ( $opt eq "f" ) {
$arg ||= shift @options;
my $value = $arg !~ s/^no-//;
$arg =~ s/-/_/g;
my $ref = $optimise{$arg};
if ( defined($ref) ) {
$$ref = $value;
}
else {
# Pass down to B::C
my $ref = $B::C::option_map{$arg};
if ( defined($ref) ) {
$$ref = $value;
$c_optimise{$ref}++;
}
lib/B/CC.pm view on Meta::CPAN
}
if ( $arg >= 1 ) {
$opt_type_attr = 1;
$freetmps_each_bblock = 1 unless $freetmps_each_loop;
}
}
elsif ( $opt eq "n" ) {
$arg ||= shift @options;
$init_name = $arg;
}
elsif ( $opt eq "m" ) {
$module = $arg;
mark_unused( $arg, undef );
}
elsif ( $opt eq "cross" ) {
$cross = $arg;
cross_config($cross); # overrides %B::C::Config::Config
}
#elsif ( $opt eq "p" ) {
# $arg ||= shift @options;
# $patchlevel = $arg;
#}
elsif ( $opt eq "D" ) {
$arg ||= shift @options;
$verbose++;
# note that we should not clash too much with the B::C debug map
# because we set theirs also
my %debug_map = (O => 'op',
T => 'stack', # was S
c => 'cxstack',
a => 'pad', # was p
r => 'runtime',
w => 'shadow', # was s
q => 'queue',
l => 'lineno',
t => 'timings',
b => 'bblock');
$arg = join('',keys %debug_map).'Fsp' if $arg eq 'full';
foreach $arg ( split( //, $arg ) ) {
if ( $arg eq "o" ) {
B->debug(1);
}
elsif ( $debug_map{$arg} ) {
$debug{ $debug_map{$arg} }++;
}
elsif ( $arg eq "F" and eval "require B::Flags;" ) {
$debug{flags}++;
$B::C::debug{flags}++;
}
elsif ( exists $B::C::debug_map{$arg} ) {
$B::C::verbose++;
$B::C::debug{ $B::C::debug_map{$arg} }++;
}
else {
warn qq(Warning: ignoring unknown -D option "$arg"\n);
}
}
}
}
$strict++ if !$strict and $Config{ccflags} !~ m/-DDEBUGGING/;
if ($opt_omit_taint) {
$opt_taint = 0;
warn "Warning: -fomit_taint is deprecated. Use -fno-taint instead.\n";
}
# rgs didn't want opcodes to be added to Opcode. So I had to add it to a
# seperate Opcodes package.
eval { require Opcodes; };
if (!$@ and $Opcodes::VERSION) {
my $MAXO = Opcodes::opcodes();
for (0..$MAXO-1) {
no strict 'refs';
my $ppname = "pp_".Opcodes::opname($_);
# opflags n: no args, no return values. don't need save/restore stack
# But pp_enter, pp_leave use/change global stack.
next if $ppname eq 'pp_enter' || $ppname eq 'pp_leave';
$no_stack{$ppname} = 1
if Opcodes::opflags($_) & 512;
# XXX More Opcodes options to be added later
}
}
#if ($debug{op}) {
# warn "no_stack: ",join(" ",sort keys %no_stack),"\n";
#}
mark_skip(qw(B::C B::C::Config B::CC B::Asmdata B::FAKEOP
B::Pseudoreg B::Shadow B::C::InitSection
O B::Stackobj B::Stackobj::Bool B::Stackobj::Padsv
B::Stackobj::Const B::Stackobj::Aelem B::Bblock));
$B::C::all_bc_deps{$_}++ for qw(Opcodes Opcode B::Concise attributes double int num str string subs);
mark_skip(qw(DB Term::ReadLine)) if defined &DB::DB;
# Set some B::C optimizations.
# optimize_ppaddr is not needed with B::CC as CC does it even better.
for (qw(optimize_warn_sv save_data_fh av_init save_sig destruct const_strings)) {
no strict 'refs';
${"B::C::$_"} = 1 unless $c_optimise{$_};
}
$B::C::destruct = 0 unless $c_optimise{destruct} and $] > 5.008;
$B::C::stash = 0 unless $c_optimise{stash};
if (!$B::C::Config::have_independent_comalloc) {
$B::C::av_init = 1 unless $c_optimise{av_init};
$B::C::av_init2 = 0 unless $c_optimise{av_init2};
} else {
$B::C::av_init = 0 unless $c_optimise{av_init};
$B::C::av_init2 = 1 unless $c_optimise{av_init2};
}
init_type_attrs() if $opt_type_attr; # but too late for -MB::CC=-O2 on import. attrs are checked before
@options;
}
# -MO=CC entry point
sub compile {
my @options = @_;
@options = import(@options);
init_sections();
$init = B::C::Section->get("init");
$decl = B::C::Section->get("decl");
# just some subs or main?
if (@options) {
return sub {
( run in 0.493 second using v1.01-cache-2.11-cpan-39bf76dae61 )