From 64bb7586561259fcc353586ee951814f41b49333 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Thu, 22 Dec 2005 23:57:27 +0000 Subject: [PATCH 1/1] Use inlineable proxy constant subs for POSIX. There may be trouble ahead, as it seems that not all POSIX "constants" are. I wonder if too many systems are going to have too many variations to make this viable. p4raw-id: //depot/perl@26455 --- ext/POSIX/Makefile.PL | 6 +- lib/ExtUtils/Constant/Base.pm | 3 +- lib/ExtUtils/Constant/ProxySubs.pm | 114 ++++++++++++++++++++++++++++--------- 3 files changed, 93 insertions(+), 30 deletions(-) diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 8630f2d..8c871c1 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -38,7 +38,7 @@ my @names = F_WRLCK HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LINK_MAX LONG_MAX LONG_MIN - L_ctermid L_cuserid L_tmpnam MAX_CANON MAX_INPUT MB_CUR_MAX MB_LEN_MAX + L_ctermid L_cuserid L_tmpnam MAX_CANON MAX_INPUT MB_LEN_MAX NAME_MAX NCCS NGROUPS_MAX NOFLSH OPEN_MAX OPOST O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC O_WRONLY PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK SCHAR_MAX @@ -57,6 +57,7 @@ my @names = _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION), + {name=>"MB_CUR_MAX", not_constant=>1}, {name=>"EXIT_FAILURE", default=>["IV", "1"]}, {name=>"EXIT_SUCCESS", default=>["IV", "0"]}, {name=>"SIG_DFL", value=>"(IV)SIG_DFL"}, @@ -67,6 +68,7 @@ my @names = {name=>"NULL", value=>"0"}, {name=>"_POSIX_JOB_CONTROL", type=>"YES", default=>["IV", "0"]}, {name=>"_POSIX_SAVED_IDS", type=>"YES", default=>["IV", "0"]}, + {name=>'FLT_ROUNDS', type=>"NV", not_constant=>1}, {name=>"HUGE_VAL", type=>"NV", macro=>[<<'END', "#endif\n"], #if (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) || defined(HUGE_VAL) @@ -89,7 +91,6 @@ push @names, {name=>$_, type=>"NV"} DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX - FLT_ROUNDS LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)); @@ -102,6 +103,7 @@ push @names, {name=>$_, type=>"IV", default=>["IV", "0"]} )); WriteConstants( + PROXYSUBS => 1, NAME => 'POSIX', NAMES => \@names, ); diff --git a/lib/ExtUtils/Constant/Base.pm b/lib/ExtUtils/Constant/Base.pm index e188075..69dde25 100644 --- a/lib/ExtUtils/Constant/Base.pm +++ b/lib/ExtUtils/Constant/Base.pm @@ -682,7 +682,8 @@ sub normalise_items $item->{macro} = $macro if defined $macro; undef $value if defined $value and $value eq $name; $item->{value} = $value if defined $value; - foreach my $key (qw(default pre post def_pre def_post weight)) { + foreach my $key (qw(default pre post def_pre def_post weight + not_constant)) { my $value = $orig->{$key}; $item->{$key} = $value if defined $value; # warn "$key $value"; diff --git a/lib/ExtUtils/Constant/ProxySubs.pm b/lib/ExtUtils/Constant/ProxySubs.pm index 9578db3..95b5e59 100644 --- a/lib/ExtUtils/Constant/ProxySubs.pm +++ b/lib/ExtUtils/Constant/ProxySubs.pm @@ -1,8 +1,8 @@ package ExtUtils::Constant::ProxySubs; use strict; -use vars qw($VERSION @ISA %type_to_struct %type_to_sv %type_to_C_value - %type_is_a_problem %type_num_args); +use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv + %type_to_C_value %type_is_a_problem %type_num_args); use Carp; require ExtUtils::Constant::XS; use ExtUtils::Constant::Utils qw(C_stringify); @@ -14,27 +14,53 @@ $VERSION = '0.01'; %type_to_struct = ( IV => '{const char *name; I32 namelen; IV value;}', + NV => '{const char *name; I32 namelen; NV value;}', + UV => '{const char *name; I32 namelen; UV value;}', + YES => '{const char *name; I32 namelen;}', + NO => '{const char *name; I32 namelen;}', '' => '{const char *name; I32 namelen;} ', ); +%type_from_struct = + ( + IV => sub { $_[0] . '->value' }, + NV => sub { $_[0] . '->value' }, + UV => sub { $_[0] . '->value' }, + YES => sub {}, + NO => sub {}, + '' => sub {}, + ); + %type_to_sv = ( - IV => sub { 'newSViv(' . $_[0] . '->value)' }, + IV => sub { "newSViv($_[0])" }, + NV => sub { "newSVnv($_[0])" }, + UV => sub { "newSVuv($_[0])" }, + YES => sub { '&PL_sv_yes' }, + NO => sub { '&PL_sv_no' }, '' => sub { '&PL_sv_yes' }, ); %type_to_C_value = ( + YES => sub {}, + NO => sub {}, '' => sub {}, ); +sub type_to_C_value { + my ($self, $type) = @_; + return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_}; +} + %type_is_a_problem = ( SV => 1, ); while (my ($type, $value) = each %XS_TypeSet) { - $type_num_args{$type} = ref $value ? scalar @$value : 1; + $type_num_args{$type} + = defined $value ? ref $value ? scalar @$value : 1 : 0; } $type_num_args{''} = 0; @@ -61,7 +87,8 @@ sub partition_names { or !$self->macro_to_ifdef($self->macro_from_name($item)); } - if ($item->{pre} or $item->{post} or $type_is_a_problem{$item->{type}}) { + if ($item->{pre} or $item->{post} or $item->{not_constant} + or $type_is_a_problem{$item->{type}}) { push @trouble, $item; } else { push @{$found{$item->{type}}}, $item; @@ -73,13 +100,16 @@ sub partition_names { sub boottime_iterator { my ($self, $type, $iterator, $hash, $subname) = @_; + my $extractor = $type_from_struct{$type}; + die "Can't find extractor code for type $type" + unless defined $extractor; my $generator = $type_to_sv{$type}; die "Can't find generator code for type $type" unless defined $generator; my $athx = $self->C_constant_prefix_param(); - return sprintf <<"EOBOOT", &$generator($iterator); + return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); while ($iterator->name) { $subname($athx $hash, $iterator->name, $iterator->namelen, %s); @@ -88,6 +118,24 @@ sub boottime_iterator { EOBOOT } +sub name_len_value_macro { + my ($self, $item) = @_; + my $name = $item->{name}; + my $value = $item->{value}; + $value = $item->{name} unless defined $value; + + my $namelen = length $name; + if ($name =~ tr/\0-\377// != $namelen) { + # the hash API signals UTF-8 by passing the length negated. + utf8::encode($name); + $namelen = -length $name; + } + $name = C_stringify($name); + + my $macro = $self->macro_from_name($item); + ($name, $namelen, $value, $macro); +} + sub WriteConstants { my $self = shift; my $ARGS = shift; @@ -114,18 +162,16 @@ sub WriteConstants { my ($found, $notfound, $trouble) = $self->partition_names($default_type, @items); - die "Can't cope with trouble yet" if @$trouble; - my $pthx = $self->C_constant_prefix_param_defintion(); my $athx = $self->C_constant_prefix_param(); my $symbol_table = C_stringify($package) . '::'; - print $c_fh <<"EOADD"; + print $c_fh $self->header(), <<"EOADD"; void ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { SV *rv = newRV_noinc(value); if (!hv_store(hash, name, namelen, rv, TRUE)) { SvREFCNT_dec(rv); - Perl_croak("Couldn't add key '%s' to %%%s", name, "$package"); + Perl_croak($athx "Couldn't add key '%s' to %%%s::", name, "$package"); } } @@ -149,8 +195,7 @@ EOBOOT foreach my $type (sort keys %$found) { my $struct = $type_to_struct{$type}; - my $type_to_value = $type_to_C_value{$type} - || sub {return map {ref $_ ? @$_ : $_} @_}; + my $type_to_value = $self->type_to_C_value($type); my $number_of_args = $type_num_args{$type}; die "Can't find structure definition for type $type" unless defined $struct; @@ -167,19 +212,9 @@ EOBOOT foreach my $item (@{$found->{$type}}) { - my $name = $item->{name}; - my $value = $item->{value}; - $value = $item->{name} unless defined $value; - - my $namelen = length $name; - if ($name =~ tr/\0-\377// != $namelen) { - # the hash API signals UTF-8 by passing the length negated. - utf8::encode($name); - $namelen = -length $name; - } - $name = C_stringify($name); + my ($name, $namelen, $value, $macro) + = $self->name_len_value_macro($item); - my $macro = $self->macro_from_name($item); my $ifdef = $self->macro_to_ifdef($macro); if (!$ifdef && $item->{invert_macro}) { carp("Attempting to supply a default for '$name' which has no conditional macro"); @@ -220,14 +255,39 @@ EOBOOT while (value_for_notfound->name) { if (!hv_store(${c_subname}_missing, value_for_notfound->name, value_for_notfound->namelen, &PL_sv_yes, TRUE)) - Perl_croak("Couldn't add key '%s' to missing_hash", + Perl_croak($athx "Couldn't add key '%s' to missing_hash", value_for_notfound->name); ++value_for_notfound; } - } EOBOOT - print $xs_fh <name_len_value_macro($item); + my $ifdef = $self->macro_to_ifdef($macro); + my $type = $item->{type}; + my $type_to_value = $self->type_to_C_value($type); + + print $xs_fh $ifdef; + if ($item->{invert_macro}) { + print $xs_fh + " /* This is the default value: */\n" if $type; + print $xs_fh "#else\n"; + } + my $generator = $type_to_sv{$type}; + die "Can't find generator code for type $type" + unless defined $generator; + + printf $xs_fh <<"EOBOOT", $name, &$generator(&$type_to_value($value)); + ${c_subname}_add_symbol($athx symbol_table, "%s", + $namelen, %s); +EOBOOT + + print $xs_fh $self->macro_to_endif($macro); + } + + print $xs_fh <