Change 30263 by [EMAIL PROTECTED] on 2007/02/13 19:23:41
Integrate:
[ 27059]
Change PL_perlio_fd_refcnt from a fixed size static array to a pointer
to a dynamic array.
[ 27166]
Fix change 27059 so that it actually works with >16 file descriptors.
With programmers like these, we need Stadler & Waldorf on code review.
Affected files ...
... //depot/maint-5.8/perl/embed.h#155 edit
... //depot/maint-5.8/perl/embedvar.h#60 integrate
... //depot/maint-5.8/perl/perlapi.h#52 integrate
... //depot/maint-5.8/perl/perlio.c#103 integrate
... //depot/maint-5.8/perl/perlvars.h#20 integrate
... //depot/maint-5.8/perl/proto.h#199 edit
Differences ...
==== //depot/maint-5.8/perl/embed.h#155 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#154~30196~ 2007-02-10 11:13:38.000000000 -0800
+++ perl/embed.h 2007-02-13 11:23:41.000000000 -0800
@@ -1688,11 +1688,6 @@
#ifdef PERL_CORE
#define my_swabn Perl_my_swabn
#endif
-#define gv_fetchpvn_flags Perl_gv_fetchpvn_flags
-#define gv_fetchsv Perl_gv_fetchsv
-#ifdef PERL_CORE
-#define is_gv_magical_sv Perl_is_gv_magical_sv
-#endif
#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
@@ -1755,6 +1750,11 @@
#endif
#ifndef HAS_STRLCPY
#endif
+#define gv_fetchpvn_flags Perl_gv_fetchpvn_flags
+#define gv_fetchsv Perl_gv_fetchsv
+#ifdef PERL_CORE
+#define is_gv_magical_sv Perl_is_gv_magical_sv
+#endif
#ifndef SPRINTF_RETURNS_STRLEN
#endif
#define ck_anoncode Perl_ck_anoncode
@@ -3786,11 +3786,6 @@
#ifdef PERL_CORE
#define my_swabn Perl_my_swabn
#endif
-#define gv_fetchpvn_flags(a,b,c,d) Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
-#define gv_fetchsv(a,b,c) Perl_gv_fetchsv(aTHX_ a,b,c)
-#ifdef PERL_CORE
-#define is_gv_magical_sv(a,b) Perl_is_gv_magical_sv(aTHX_ a,b)
-#endif
#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
@@ -3853,6 +3848,11 @@
#endif
#ifndef HAS_STRLCPY
#endif
+#define gv_fetchpvn_flags(a,b,c,d) Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
+#define gv_fetchsv(a,b,c) Perl_gv_fetchsv(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define is_gv_magical_sv(a,b) Perl_is_gv_magical_sv(aTHX_ a,b)
+#endif
#ifndef SPRINTF_RETURNS_STRLEN
#endif
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
==== //depot/maint-5.8/perl/embedvar.h#60 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h#59~29863~ 2007-01-17 14:55:14.000000000 -0800
+++ perl/embedvar.h 2007-02-13 11:23:41.000000000 -0800
@@ -1467,6 +1467,8 @@
#define PL_malloc_mutex (PL_Vars.Gmalloc_mutex)
#define PL_op_mutex (PL_Vars.Gop_mutex)
#define PL_patleave (PL_Vars.Gpatleave)
+#define PL_perlio_fd_refcnt (PL_Vars.Gperlio_fd_refcnt)
+#define PL_perlio_fd_refcnt_size (PL_Vars.Gperlio_fd_refcnt_size)
#define PL_sh_path (PL_Vars.Gsh_path)
#define PL_sigfpe_saved (PL_Vars.Gsigfpe_saved)
#define PL_sv_placeholder (PL_Vars.Gsv_placeholder)
@@ -1485,6 +1487,8 @@
#define PL_Gmalloc_mutex PL_malloc_mutex
#define PL_Gop_mutex PL_op_mutex
#define PL_Gpatleave PL_patleave
+#define PL_Gperlio_fd_refcnt PL_perlio_fd_refcnt
+#define PL_Gperlio_fd_refcnt_size PL_perlio_fd_refcnt_size
#define PL_Gsh_path PL_sh_path
#define PL_Gsigfpe_saved PL_sigfpe_saved
#define PL_Gsv_placeholder PL_sv_placeholder
==== //depot/maint-5.8/perl/perlapi.h#52 (text+w) ====
Index: perl/perlapi.h
--- perl/perlapi.h#51~29863~ 2007-01-17 14:55:14.000000000 -0800
+++ perl/perlapi.h 2007-02-13 11:23:41.000000000 -0800
@@ -1047,6 +1047,10 @@
#define PL_op_mutex (*Perl_Gop_mutex_ptr(NULL))
#undef PL_patleave
#define PL_patleave (*Perl_Gpatleave_ptr(NULL))
+#undef PL_perlio_fd_refcnt
+#define PL_perlio_fd_refcnt (*Perl_Gperlio_fd_refcnt_ptr(NULL))
+#undef PL_perlio_fd_refcnt_size
+#define PL_perlio_fd_refcnt_size (*Perl_Gperlio_fd_refcnt_size_ptr(NULL))
#undef PL_sh_path
#define PL_sh_path (*Perl_Gsh_path_ptr(NULL))
#undef PL_sigfpe_saved
==== //depot/maint-5.8/perl/perlio.c#103 (text) ====
Index: perl/perlio.c
--- perl/perlio.c#102~30069~ 2007-01-29 13:05:26.000000000 -0800
+++ perl/perlio.c 2007-02-13 11:23:41.000000000 -0800
@@ -56,8 +56,6 @@
#include "XSUB.h"
-#define PERLIO_MAX_REFCOUNTABLE_FD 2048
-
#ifdef __Lynx__
/* Missing proto on LynxOS */
int mkstemp(char*);
@@ -2266,7 +2264,44 @@
#ifdef USE_THREADS
perl_mutex PerlIO_mutex;
#endif
-int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
+
+/* Must be called with PerlIO_mutex locked. */
+static void
+S_more_refcounted_fds(pTHX_ const int new_fd) {
+ const int old_max = PL_perlio_fd_refcnt_size;
+ const int new_max = 16 + (new_fd & ~15);
+ int *new_array;
+
+ PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
+ old_max, new_fd, new_max);
+
+ if (new_fd < old_max) {
+ return;
+ }
+
+ assert (new_max > new_fd);
+
+ new_array
+ = PerlMemShared_realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
+
+ if (!new_array) {
+#ifdef USE_THREADS
+ MUTEX_UNLOCK(&PerlIO_mutex);
+#endif
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
+ my_exit(1);
+ }
+
+ PL_perlio_fd_refcnt_size = new_max;
+ PL_perlio_fd_refcnt = new_array;
+
+ PerlIO_debug("Zeroing %p, %d\n", new_array + old_max, new_max - old_max);
+
+ Zero(new_array + old_max, new_max - old_max, int);
+}
+
void
PerlIO_init(pTHX)
@@ -2282,12 +2317,18 @@
void
PerlIOUnix_refcnt_inc(int fd)
{
- if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+ dTHX;
+ if (fd >= 0) {
+
#ifdef USE_THREADS
MUTEX_LOCK(&PerlIO_mutex);
#endif
- PerlIO_fd_refcnt[fd]++;
- PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
+ if (fd >= PL_perlio_fd_refcnt_size)
+ S_more_refcounted_fds(aTHX_ fd);
+
+ PL_perlio_fd_refcnt[fd]++;
+ PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]);
+
#ifdef USE_THREADS
MUTEX_UNLOCK(&PerlIO_mutex);
#endif
@@ -2297,12 +2338,18 @@
int
PerlIOUnix_refcnt_dec(int fd)
{
+ dTHX;
int cnt = 0;
- if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+ if (fd >= 0) {
#ifdef USE_THREADS
MUTEX_LOCK(&PerlIO_mutex);
#endif
- cnt = --PerlIO_fd_refcnt[fd];
+ /* XXX should this be a panic? */
+ if (fd >= PL_perlio_fd_refcnt_size)
+ S_more_refcounted_fds(aTHX_ fd);
+
+ /* XXX should this be a panic if it drops below 0? */
+ cnt = --PL_perlio_fd_refcnt[fd];
PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
#ifdef USE_THREADS
MUTEX_UNLOCK(&PerlIO_mutex);
@@ -2534,7 +2581,7 @@
if (flags & PERLIO_DUP_FD) {
fd = PerlLIO_dup(fd);
}
- if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+ if (fd >= 0) {
f = PerlIOBase_dup(aTHX_ f, o, param, flags);
if (f) {
/* If all went well overwrite fd in dup'ed lay with the dup()'ed fd
*/
==== //depot/maint-5.8/perl/perlvars.h#20 (text) ====
Index: perl/perlvars.h
--- perl/perlvars.h#19~29800~ 2007-01-13 15:25:42.000000000 -0800
+++ perl/perlvars.h 2007-02-13 11:23:41.000000000 -0800
@@ -77,3 +77,8 @@
#ifndef PERL_USE_SAFE_PUTENV
PERLVARI(Guse_safe_putenv, int, 1)
#endif
+
+#ifdef USE_PERLIO
+PERLVARI(Gperlio_fd_refcnt, int*, 0) /* Pointer to array of fd refcounts. */
+PERLVARI(Gperlio_fd_refcnt_size, int, 0) /* Size of the array */
+#endif
==== //depot/maint-5.8/perl/proto.h#199 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#198~30196~ 2007-02-10 11:13:38.000000000 -0800
+++ perl/proto.h 2007-02-13 11:23:41.000000000 -0800
@@ -1465,11 +1465,9 @@
PERL_CALLCONV void Perl_boot_core_xsutils(pTHX);
#if defined(USE_ITHREADS)
PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32
max, CLONE_PARAMS* param)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si, CLONE_PARAMS* param)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl,
CLONE_PARAMS* param)
@@ -1477,11 +1475,9 @@
__attribute__warn_unused_result__;
PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, PerlInterpreter* proto_perl)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared, CLONE_PARAMS*
param)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r, CLONE_PARAMS* param)
@@ -1489,23 +1485,18 @@
__attribute__warn_unused_result__;
PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type, CLONE_PARAMS*
param)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV DIR* Perl_dirp_dup(pTHX_ DIR* dp)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp, CLONE_PARAMS* param)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC* mg, CLONE_PARAMS* param)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_sv_dup(pTHX_ SV* sstr, CLONE_PARAMS* param)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_rvpv_dup(pTHX_ SV* dstr, SV *sstr, CLONE_PARAMS*
param);
@@ -1708,10 +1699,7 @@
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) ||
defined(PERL_DECL_PROT)
PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const
what, const U32 type, SV ***spp)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_4);
+ __attribute__warn_unused_result__;
#endif
End of Patch.
