In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b1826b71659a2c08e5ace047d74b3724d6311bd8?hp=bf01568a4bfab00fb5180c6b243ef3c90ca3ebd6>
- Log ----------------------------------------------------------------- commit b1826b71659a2c08e5ace047d74b3724d6311bd8 Author: Nicholas Clark <[email protected]> Date: Sat Oct 23 19:26:53 2010 +0100 Convert B to use ExtUtils::Constant::ProxySubs for its constants. Previously it was using a Perl script to generate C code with pairs of newCONSTSUB(stash,"Foo_BAR",newSViv(Foo_BAR)); av_push(export_ok,newSVpvn("Foo_BAR",7)); for each constant it exported from C to Perl. Now it uses a loop to process a table. Object code is size reduced by about 42K on this system (almost 20%) M MANIFEST M ext/B/B.xs M ext/B/Makefile.PL D ext/B/defsubs_h.PL commit 1c8d11ca3d0ce8bc11562f159b94c2c7e62dea6c Author: Nicholas Clark <[email protected]> Date: Sat Oct 23 19:00:49 2010 +0100 For PROXYSUBS, add an option to push all constants' names onto an array. Typically this would be 'EXPORT_OK', to add all constants to the @EXPORT_OK array for this package. M cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm commit cfe266414f3e8904e82a5303767315c497dd135c Author: Nicholas Clark <[email protected]> Date: Sat Oct 23 18:41:04 2010 +0100 For PROXYSUBS, allow an explicit XS_SUBNAME of undef to suppress its generation. M cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm commit c6036734eafb3703ba420e2f73cc4a296899d10d Author: Nicholas Clark <[email protected]> Date: Sat Oct 23 18:06:42 2010 +0100 Change concise.t to use Storable to test stash/src rendering of constant subs. This allows B to be refactored to change the implementation of its constants. Storable strives to main compatibility with 5.004 (or so), so unlikely to be refactored soon. M ext/B/t/concise.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 - .../lib/ExtUtils/Constant/ProxySubs.pm | 71 ++++++++++--- ext/B/B.xs | 5 +- ext/B/Makefile.PL | 84 +++++++++++----- ext/B/defsubs_h.PL | 105 -------------------- ext/B/t/concise.t | 13 ++- 6 files changed, 125 insertions(+), 154 deletions(-) delete mode 100644 ext/B/defsubs_h.PL diff --git a/MANIFEST b/MANIFEST index b07c12b..95fff9f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3072,7 +3072,6 @@ ext/B/B/Showlex.pm Compiler Showlex backend ext/B/B/Terse.pm Compiler Terse backend ext/B/B/Xref.pm Compiler Xref backend ext/B/B.xs Compiler backend external subroutines -ext/B/defsubs_h.PL Generator for constant subroutines ext/B/hints/darwin.pl Hints for named architecture ext/B/hints/openbsd.pl Hints for named architecture ext/B/Makefile.PL Compiler backend makefile writer diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm index 15c679f..c252fc3 100644 --- a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm +++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm @@ -123,7 +123,7 @@ sub partition_names { } sub boottime_iterator { - my ($self, $type, $iterator, $hash, $subname) = @_; + my ($self, $type, $iterator, $hash, $subname, $push) = @_; my $extractor = $type_from_struct{$type}; die "Can't find extractor code for type $type" unless defined $extractor; @@ -133,12 +133,22 @@ sub boottime_iterator { my $athx = $self->C_constant_prefix_param(); - return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); + if ($push) { + return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); + do { + he = $subname($athx $hash, $iterator->name, + $iterator->namelen, %s); + av_push(push, newSVhek(HeKEY_hek(he))); + } while ((++$iterator)->name); +EOBOOT + } else { + return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); do { $subname($athx $hash, $iterator->name, $iterator->namelen, %s); } while ((++$iterator)->name); EOBOOT + } } sub name_len_value_macro { @@ -163,11 +173,15 @@ sub WriteConstants { my $self = shift; my $ARGS = {...@_}; - my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package) - = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)}; + my ($c_fh, $xs_fh, $c_subname, $default_type, $package) + = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)}; + + my $xs_subname + = exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant'; my $options = $ARGS->{PROXYSUBS}; $options = {} unless ref $options; + my $push = $options->{push}; my $explosives = $options->{croak_on_read}; my $croak_on_error = $options->{croak_on_error}; my $autoload = $options->{autoload}; @@ -182,10 +196,16 @@ sub WriteConstants { if $exclusive > 1; } # Strictly it requires Perl_caller_cx - carp ("PROXYSUBS options 'croak_on_error' requires v5.13.5 or later") + carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later") if $croak_on_error && $^V < v5.13.5; - - $xs_subname ||= 'constant'; + # Strictly this is actually 5.8.9, but it's not well tested there + my $can_do_pcs = $] >= 5.009; + # Until someone patches this (with test cases) + carp ("PROXYSUBS option 'push' requires v5.10 or later") + if $push && !$can_do_pcs; + # Until someone patches this (with test cases) + carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together") + if $explosives && $push; # If anyone is insane enough to suggest a package name containing % my $package_sprintf_safe = $package; @@ -210,8 +230,7 @@ sub WriteConstants { my $pthx = $self->C_constant_prefix_param_defintion(); my $athx = $self->C_constant_prefix_param(); my $symbol_table = C_stringify($package) . '::'; - - my $can_do_pcs = $] >= 5.009; + $push = C_stringify($package . '::' . $push) if $push; my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; print $c_fh $self->header(); @@ -229,9 +248,11 @@ sub WriteConstants { EOC } + my $return_type = $push ? 'HE *' : 'void'; + print $c_fh <<"EOADD"; -static void +static $return_type ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { EOADD if (!$can_do_pcs) { @@ -240,12 +261,16 @@ EOADD EO_NOPCS } else { print $c_fh <<"EO_PCS"; - SV **sv = hv_fetch(hash, name, namelen, TRUE); - if (!sv) { + HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL, + 0); + SV *sv; + + if (!he) { Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::", name); } - if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) { + sv = HeVAL(he); + if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) { /* Someone has been here before us - have to make a real sub. */ EO_PCS } @@ -256,9 +281,9 @@ EOADD if ($can_do_pcs) { print $c_fh <<'EO_PCS'; } else { - SvUPGRADE(*sv, SVt_RV); - SvRV_set(*sv, value); - SvROK_on(*sv); + SvUPGRADE(sv, SVt_RV); + SvRV_set(sv, value); + SvROK_on(sv); SvREADONLY_on(value); } EO_PCS @@ -267,6 +292,7 @@ EO_PCS } EO_NOPCS } + print $c_fh " return he;\n" if $push; print $c_fh <<'EOADD'; } @@ -350,6 +376,12 @@ BOOT: #endif HV *symbol_table = get_hv("$symbol_table", GV_ADD); EOBOOT + if ($push) { + print $xs_fh <<"EOC"; + AV *push = get_av(\"$push\", GV_ADD); + HE *he; +EOC + } my %iterator; @@ -416,7 +448,7 @@ EOBOOT foreach my $type (sort keys %$found) { print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 'symbol_table', - $add_symbol_subname); + $add_symbol_subname, $push); } print $xs_fh <<"EOBOOT"; @@ -492,6 +524,9 @@ EXPLODE #endif DONT + print $xs_fh " av_push(push, newSVhek(hek));\n" + if $push; + print $xs_fh <<"EOBOOT"; } while ((++value_for_notfound)->name); } @@ -557,6 +592,8 @@ EOBOOT EOBOOT } + return if !defined $xs_subname; + if ($croak_on_error || $autoload) { print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA'; diff --git a/ext/B/B.xs b/ext/B/B.xs index e0cda16..004b5eb 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -589,8 +589,12 @@ typedef HE *B__HE; typedef struct refcounted_he *B__RHE; #endif +#include "const-c.inc" + MODULE = B PACKAGE = B PREFIX = B_ +INCLUDE: const-xs.inc + PROTOTYPES: DISABLE BOOT: @@ -608,7 +612,6 @@ BOOT: #if PERL_VERSION <= 8 # define OPpPAD_STATE 0 #endif -#include "defsubs.h" } #define B_main_cv() PL_main_cv diff --git a/ext/B/Makefile.PL b/ext/B/Makefile.PL index 594e71e..d026a71 100644 --- a/ext/B/Makefile.PL +++ b/ext/B/Makefile.PL @@ -1,42 +1,76 @@ use ExtUtils::MakeMaker; +use ExtUtils::Constant 0.23 'WriteConstants'; use File::Spec; +use strict; +use warnings; + my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV; WriteMakefile( NAME => "B", VERSION_FROM => "B.pm", - PL_FILES => { 'defsubs_h.PL' => 'defsubs.h' }, - clean => { - FILES => "defsubs.h" - } + realclean => {FILES=> 'const-c.inc const-xs.inc'}, ); -package MY; -sub headerpath { - if ($core) { - return File::Spec->catdir(File::Spec->updir, - File::Spec->updir); - } else { +my $headerpath; +if ($core) { + $headerpath = File::Spec->catdir(File::Spec->updir, File::Spec->updir); +} else { require Config; - return File::Spec->catdir($Config::Config{archlibexp}, "CORE"); - } + $headerpath = File::Spec->catdir($Config::Config{archlibexp}, "CORE"); } -sub MY::postamble { - my $headerpath = headerpath(); - my @headers = map { File::Spec->catfile($headerpath, $_) } qw(op.h cop.h); +my @names = qw(CVf_ANON CVf_CLONE CVf_CLONED CVf_CONST CVf_LVALUE CVf_METHOD + CVf_NODEBUG CVf_UNIQUE CVf_WEAKOUTSIDE + GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV GVf_IMPORTED_SV + HEf_SVKEY + SVTYPEMASK SVt_PVGV SVt_PVHV + SVf_FAKE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK SVf_READONLY + SVf_ROK SVp_IOK SVp_NOK SVp_POK SVpad_OUR SVs_RMG SVs_SMG + PAD_FAKELEX_ANON PAD_FAKELEX_MULTI); -" -B\$(OBJ_EXT) : defsubs.h +if ($] >= 5.009) { + push @names, 'CVf_ISXSUB'; +} else { + # Constant not present after 5.8.x + push @names, 'AVf_REAL'; + # This is only present in 5.10, but it's useful to B::Deparse to be able + # to import a dummy value from B + push @names, 'OPpPAD_STATE'; +} -defsubs.h :: @headers defsubs_h.PL - \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) defsubs_h.PL defsubs.h $headerpath -" +if ($] < 5.011) { + # Constant not present after 5.10.x + push @names, 'CVf_LOCKED'; } -sub MY::processPL { - my $text = shift->SUPER::processPL(@_); - # Append our extra parameter - $text =~ s/^\t.*defsubs_h\.PL.*/$& . ' ' . headerpath()/me; - $text; +# First element in each tuple is the file; second is a regex snippet +# giving the prefix to limit the names of symbols to define that come +# from that file. If none, all symbols will be defined whose values +# match the pattern below. +foreach my $tuple (['op_reg_common.h','(?:(?:RXf_)?PMf_)'], + ['op.h'], + ['cop.h'], + ['regexp.h','RXf_']) { + my $file = $tuple->[0]; + my $pfx = $tuple->[1] || ''; + my $path = File::Spec->catfile($headerpath, $file); + open my $fh, '<', $path or die "Cannot open $path: $!"; + while (<$fh>) { + push @names, $1 if (/ \#define \s+ ( $pfx \w+ ) \s+ + ( [()|\dx]+ # Parens, '|', digits, 'x' + | \(? \d+ \s* << .*? # digits left shifted by anything + ) \s* (?: $| \/ \* ) # ending at comment or $ + /x); + } + close $fh; } + +# Currently only SVt_PVGV and SVt_PVHV aren't macros, but everything we name +# should exist, so ensure that the C compile breaks if anything does not. +WriteConstants( + PROXYSUBS => {push => 'EXPORT_OK'}, + NAME => 'B', + NAMES => [map {{name=>$_, macro=>1}} @names], + XS_SUBNAME => undef, +); diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL deleted file mode 100644 index b6d8aaa..0000000 --- a/ext/B/defsubs_h.PL +++ /dev/null @@ -1,105 +0,0 @@ -# Do not remove the following line; MakeMaker relies on it to identify -# this file as a template for defsubs.h -# Extracting defsubs.h (with variable substitutions) -#!perl -w -use File::Spec; -my (undef, $headerpath) = @ARGV; -my ($out) = __FILE__ =~ /(^.*)\.PL/i; -$out =~ s/_h$/.h/; -unlink $out if -l $out; -open(OUT,">$out") || die "Cannot open $out:$!"; -print "Extracting $out...\n"; -print OUT <<"END"; -/* - !!! Don't modify this file - it's autogenerated from $0 !!! - */ -END - -foreach my $const (qw( - CVf_ANON - CVf_CLONE - CVf_CLONED - CVf_CONST - CVf_LVALUE - CVf_METHOD - CVf_NODEBUG - CVf_UNIQUE - CVf_WEAKOUTSIDE - GVf_IMPORTED_AV - GVf_IMPORTED_CV - GVf_IMPORTED_HV - GVf_IMPORTED_SV - HEf_SVKEY - SVTYPEMASK - SVf_FAKE - SVf_IOK - SVf_IVisUV - SVf_NOK - SVf_POK - SVf_READONLY - SVf_ROK - SVp_IOK - SVp_NOK - SVp_POK - SVpad_OUR - SVs_RMG - SVs_SMG - SVt_PVGV - SVt_PVHV - PAD_FAKELEX_ANON - PAD_FAKELEX_MULTI - )) - { - doconst($const); - } - -if ($] < 5.009) { - # This is only present in 5.10, but it's useful to B::Deparse to be able - # to import a dummy value from B - doconst(OPpPAD_STATE); -} - -if ($] >= 5.009) { - # Constant not present in 5.8.x - doconst(CVf_ISXSUB); -} else { - # Constant not present after 5.8.x - doconst(AVf_REAL); -} - -if ($] < 5.011) { - # Constant not present after 5.10.x - doconst(CVf_LOCKED); -} - -# First element in each tuple is the file; second is a regex snippet -# giving the prefix to limit the names of symbols to define that come -# from that file. If none, all symbols will be defined whose values -# match the pattern below. -foreach my $tuple (['op_reg_common.h','(?:(?:RXf_)?PMf_)'],['op.h'],['cop.h'],['regexp.h','RXf_']) - { - my $file = $tuple->[0]; - my $pfx = $tuple->[1] || ''; - my $path = File::Spec->catfile($headerpath, $file); - open(OPH,"$path") || die "Cannot open $path:$!"; - while (<OPH>) - { - doconst($1) if (/ \#define \s+ ( $pfx \w+ ) \s+ - ( [()|\dx]+ # Parens, '|', digits, 'x' - | \(? \d+ \s* << .*? # digits left shifted by anything - ) \s* (?: $| \/ \* ) # ending at comment or $ - /x); - } - close(OPH); - } -close(OUT); - -sub doconst -{ - my $sym = shift; - my $l = length($sym); - print OUT <<"END"; - newCONSTSUB(stash,"$sym",newSViv($sym)); - av_push(export_ok,newSVpvn("$sym",$l)); -END -} diff --git a/ext/B/t/concise.t b/ext/B/t/concise.t index 2b67222..a6a1a78 100644 --- a/ext/B/t/concise.t +++ b/ext/B/t/concise.t @@ -392,15 +392,18 @@ like($out, qr/FUNC: \*B::Concise::concise_cv_obj/, like($out, qr/FUNC: \*B::Concise::walk_output/, "stash rendering includes Concise::walk_output"); -like($out, qr/FUNC: \*B::Concise::PAD_FAKELEX_MULTI/, +like($out, qr/\# 4\d\d: \s+ \$l->concise\(\$level\);/, + "src-line rendering works"); + +$out = runperl ( switches => ["-MStorable", "-MO=Concise,-stash=Storable,-src"], + prog => '-e 1', stderr => 1 ); + +like($out, qr/FUNC: \*Storable::BIN_MAJOR/, "stash rendering includes constant sub: PAD_FAKELEX_MULTI"); -like($out, qr/PAD_FAKELEX_MULTI is a constant sub, optimized to a IV/, +like($out, qr/BIN_MAJOR is a constant sub, optimized to a IV/, "stash rendering identifies it as constant"); -like($out, qr/\# 4\d\d: \s+ \$l->concise\(\$level\);/, - "src-line rendering works"); - $out = runperl ( switches => ["-MO=Concise,-stash=ExtUtils::Mksymlists,-src,-exec"], prog => '-e 1', stderr => 1 ); -- Perl5 Master Repository
