In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/737b460d4977201e63598daf5cc7d1c00b9fb809?hp=0bb8cb436da6e18869ede1dfa3d55abc438bff5f>
- Log ----------------------------------------------------------------- commit 737b460d4977201e63598daf5cc7d1c00b9fb809 Merge: 0bb8cb436d 54d7f55c0b Author: David Mitchell <[email protected]> Date: Tue Feb 19 15:41:03 2019 +0000 [MERGE] fix PERL_GLOBAL_STRUCT builds PERL_GLOBAL_STRUCT and DPERL_GLOBAL_STRUCT_PRIVATE builds haven't been smoked for quite a while and the code has bit-rotted. The commits in this branch made them build and all test pass again, at least on Linux commit 54d7f55c0b7e797212eebb61c3f7e9e0cce0d442 Author: David Mitchell <[email protected]> Date: Tue Feb 19 15:20:16 2019 +0000 merge two versions of Perl_my_cxt_init There are two separate copies of this function, chosen by the presence of PERL_GLOBAL_STRUCT_PRIVATE. The previous couple of commits have made them more similar; this commit merges them into a single function with differing blocks of code protected by PERL_GLOBAL_STRUCT_PRIVATE commit 6a90e9f22120a5e2df51543e0402e2ad3b11017d Author: David Mitchell <[email protected]> Date: Tue Feb 19 14:59:24 2019 +0000 Perl_my_cxt_init: remove unnecessary code In the PERL_GLOBAL_STRUCT_PRIVATE variant of this code, it zeroes out unused slots of a freshly-realloced PL_my_cxt_list[]. This is not necessary, as those slots won't be used until a new index is allocated, as which point the new slot will get written to before anything else. The non-PERL_GLOBAL_STRUCT_PRIVATE variant of this function doesn't have this redundant zeroing. So remove it. commit 8e7615cb2f19df1393c4e187d2c3ef6cb73e2b1a Author: David Mitchell <[email protected]> Date: Tue Feb 19 14:35:31 2019 +0000 harmonise two versions of Perl_my_cxt_init There are two separate copies of this function, chosen by the presence of PERL_GLOBAL_STRUCT_PRIVATE. Make the two versions closer to each other, to allow shortly for merging. Mainly its renaming the int pointer parameter from 'index' to 'indexp', and adding a local var 'index', which is assigned from *indexp where appropriate. Also harmonise some of the comments between the two functions. commit c32805c1fdc2309bfc236013edc5490117fb28df Author: David Mitchell <[email protected]> Date: Tue Feb 19 12:29:38 2019 +0000 perlvars.h: remove #ifdef DEBUGGING Under PERL_GLOBAL_STRUCT, all the "global" vars are put in a structure, which means perlvars.h needs a similar constraint to intrpvar.h: its size and alignment shouldn't change between debugging and non-debugging builds. This is because regcomp/exec.c are compiled both with and without DEBUGGING. [Fixed by Karl] commit a6098fe8178c5ef2e7abbc8faf4c0f62b9b197ea Author: David Mitchell <[email protected]> Date: Tue Feb 19 11:06:38 2019 +0000 PERL_GLOBAL_STRUCT: remove static var from sv.c This var was protected by PERL_GLOBAL_STRUCT_PRIVATE, but PERL_GLOBAL_STRUCT doesn't allow static vars either. commit d6158b17934aab8f3f06ee6dd0a9fac0ac6940dd Author: David Mitchell <[email protected]> Date: Tue Feb 19 08:53:43 2019 +0000 get MakeMaker to play under PERL_GLOBAL_STRUCT Under PERL_GLOBAL_STRUCT (well, actually I've only tried under PERL_GLOBAL_STRUCT_PRIVATE), cpan/ExtUtils-MakeMaker/t/03-xsstatic.t was failing some tests. This was because it was creating a statically-linked perl binary, but wasn't compiling perlmain.c with -DPERL_CORE. Usually this doesn't matter, but under PERL_GLOBAL_STRUCT it needed a definition of aTHX which it was pulling from XSUB.h rather than perl.h, causing a SEGV. Until a proper fix makes it way into MakeMaker, explicitly define PERL_CORE in perlmain.c commit 04912be77a628a4643d16a99a332a73853926079 Author: David Mitchell <[email protected]> Date: Mon Feb 18 09:29:29 2019 +0000 fix thread issue with PERL_GLOBAL_STRUCT The MY_CXT subsystem allows per-thread pseudo-static data storage. Part of the implementation for this involves each XS module being assigned a unique index in its my_cxt_index static var when first loaded. Because PERL_GLOBAL_STRUCT bans any static vars, under those builds there is instead a table which maps the MY_CXT_KEY identifying string to index. Unfortunately, this table was allocated per-interpreter rather than globally, meaning if multiple threads tried to load the same XS module, crashes could ensue. This manifested itself in failures in ext/XS-APItest/t/keyword_plugin_threads.t The fix is relatively straightforward: allocate PL_my_cxt_keys globally rather than per-interpreter. Also record the size of this struct in a new var, PL_my_cxt_keys_size, rather than doing double duty on PL_my_cxt_size. commit 61d4c87c940fea028f08f27addc275b469320fda Author: David Mitchell <[email protected]> Date: Mon Feb 18 09:19:38 2019 +0000 Perl_my_cxt_init: fix potential race condition (Found by code inspection - I can't reproduce a failure) the MY_CXT subsystem, which allows per-thread pseudo-static variables, has a thread race condition. When a module is first loaded, it is allocated unique index (from PL_my_cxt_index++) which is assigned to the module's my_cxt_index static var. If two threads both try to load an XS module at the same time, its possible for one thread to set my_cxtp, then a second thread to overwrite it with a higher value, causing the first thread to use the wrong index into its local storage. commit 6009fde9e4e3d825057f663d300a7bede478e5c3 Author: David Mitchell <[email protected]> Date: Fri Dec 28 12:50:14 2018 +0000 PL_InBitmap: fix with -DPERL_GLOBAL_STRUCT_PRIVATE Valgrind wasn't happy, as this global var wasn't being initialised to NULL. commit 999d65ede909a162fb0accd370ffdf1411e94d5e Author: David Mitchell <[email protected]> Date: Wed Dec 26 12:58:06 2018 +0000 foo_cloexec() under PERL_GLOBAL_STRUCT_PRIVATE Fix the various Perl_PerlSock_dup2_cloexec() type functions so that t/porting/liberl.a passes under -DPERL_GLOBAL_STRUCT_PRIVATE builds. In these builds it is forbidden to have any static variables, but each of these functions (via convoluted macros) has a static var called 'strategy' which records, for each function, whether a run-time probe has been done to determine the best way of achieving close-exec functionality, and the result. Replace them all with 'global' vars: PL_strategy_dup2 etc. NB these vars aren't thread-safe but it doesn't really matter, as the worst that can happen is for a redundant probe or two to be done before a suitable "don't probe any more" value is written to the var and seen by all the threads. commit 4ef8bdf9dc2018cb385cf00d11e2e74f0491f8e9 Author: David Mitchell <[email protected]> Date: Fri Dec 28 11:29:27 2018 +0000 PERL_GLOBAL_STRUCT_PRIVATE: fix some const strings change a couple of const char * foo[] = { ... } to const char * const foo[] = { ... } Making the string ptrs const means the whole thing is RO and doesn't appear in data section, making porting/libperl.t happier when building under -DPERL_GLOBAL_STRUCT_PRIVATE. commit 3680775c4add74dd105f844256620954f5378054 Author: David Mitchell <[email protected]> Date: Wed Dec 26 20:50:16 2018 +0000 regcomp.c: don't include INTERN.h This file only needs including by globals.c; it was being included in regcomp.c too as the declarations in regcomp.h aren't included by perl.h and thus don't get pulled into globals.c. This was a confusing and hacky workaround. Instead, this commit causes globals.c to #include regcomp.h directly After this commit, only globals.c #includes INTERN.h commit 37137b990496477796ac4de6505577c12f281b58 Author: David Mitchell <[email protected]> Date: Wed Dec 26 20:37:45 2018 +0000 ext/SDBM_File/sdbm.c: don't include INTERN.h This file really only needs including by globals.c - including it in sdbm.c was probably just a thinko or cut and paste error from decades ago. Removing it doesn't seem to break anything. After this commit, only globals.c and regcomp.c include it. commit 8633b5394e9f1be292f2b13d5f642a205ae31509 Author: David Mitchell <[email protected]> Date: Wed Dec 26 10:41:28 2018 +0000 vutil.c: build under PERL_GLOBAL_STRUCT_PRIVATE The perl build option -DPERL_GLOBAL_STRUCT_PRIVATE had bit-rotted due to lack of smoking. This commit and the next fix it. I've separated out the vutil.c change into a separate commit since this file is actually part of the 'version' CPAN distribution and normally should be edited upstream first. commit 1565c085c35f9f8b0c729dff0ac353dcb8d79df6 Author: David Mitchell <[email protected]> Date: Wed Dec 26 10:45:22 2018 +0000 add dVAR's for PERL_GLOBAL_STRUCT_PRIVATE builds The perl build option -DPERL_GLOBAL_STRUCT_PRIVATE had bit-rotted due to lack of smoking. The main fix is to just add 'dVAR;' to any functions which have a pTHX arg. It's a NOOP on normal builds. ----------------------------------------------------------------------- Summary of changes: charclass_invlists.h | 12 +-- doio.c | 39 ++++++-- dump.c | 1 + embed.fnc | 2 +- embedvar.h | 23 ++++- ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm | 9 +- ext/SDBM_File/sdbm.c | 1 - globals.c | 7 ++ globvar.sym | 9 ++ intrpvar.h | 3 - locale.c | 4 +- makedef.pl | 3 +- miniperlmain.c | 7 +- op.c | 2 + perlapi.h | 22 +++++ perlvars.h | 30 +++++- pp.c | 1 + proto.h | 4 +- regcomp.c | 20 +++- regen/mk_invlists.pl | 2 +- regexec.c | 14 +++ sv.c | 13 +-- toke.c | 1 + uni_keywords.h | 2 +- utf8.c | 23 +++++ util.c | 121 ++++++++++++++----------- vutil.c | 5 + win32/win32.c | 5 + 28 files changed, 283 insertions(+), 102 deletions(-) diff --git a/charclass_invlists.h b/charclass_invlists.h index e0fc111a90..00a3407c1a 100644 --- a/charclass_invlists.h +++ b/charclass_invlists.h @@ -182193,7 +182193,7 @@ static const UV UNI__PERL_PROBLEMATIC_LOCALE_FOLDEDS_START_invlist[] = { /* for 0x0, 0x100, 0x130, - 0x132, + 0x131, 0x149, 0x14A, 0x178, @@ -182219,14 +182219,14 @@ static const UV UNI__PERL_PROBLEMATIC_LOCALE_FOLDEDS_START_invlist[] = { /* for }; static const UV UNI__PERL_PROBLEMATIC_LOCALE_FOLDS_invlist[] = { /* for all charsets */ - 26, /* Number of elements */ + 24, /* Number of elements */ 148565664, /* Version and data structure type */ 0, /* 0 if the list starts at 0; 1 if it starts at the element beyond 0 */ 0x0, 0x100, 0x130, - 0x132, + 0x131, 0x149, 0x14A, 0x178, @@ -182235,8 +182235,6 @@ static const UV UNI__PERL_PROBLEMATIC_LOCALE_FOLDS_invlist[] = { /* for all cha 0x180, 0x1F0, 0x1F1, - 0x307, - 0x308, 0x39C, 0x39D, 0x3BC, @@ -381512,7 +381510,7 @@ static const UV UNI__PERL_SURROGATE_invlist[] = { /* for all charsets */ 0xE000 }; -const char * deprecated_property_msgs[] = { +const char * const deprecated_property_msgs[] = { "", "Surrogates should never appear in well-formed text, and therefore shouldn't be the basis for line breaking", "Supplanted by Line_Break property values; see www.unicode.org/reports/tr14" @@ -384050,5 +384048,5 @@ static const U8 WB_table[23][23] = { * 7bd6bcbe3813e0cd55e0998053d182b7bc8c97dcfd0b85028e9f7f55af4ad61b lib/unicore/version * 4bb677187a1a64e39d48f2e341b5ecb6c99857e49d7a79cf503bd8a3c709999b regen/charset_translations.pl * 03e51b0f07beebd5da62ab943899aa4934eee1f792fa27c1fb638c33bf4ac6ea regen/mk_PL_charclass.pl - * 8ae37f2b5bbc7d215f63e8d1189754d83a16c6156fd353847f6fcced90c513d5 regen/mk_invlists.pl + * 2fb19108265d37fc38920cd3f775c5c9fc25ae8b95be3bf197f47da1dc4989f4 regen/mk_invlists.pl * ex: set ro: */ diff --git a/doio.c b/doio.c index 9fe222e082..0cc4e55404 100644 --- a/doio.c +++ b/doio.c @@ -112,11 +112,10 @@ Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd) } while(0) #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \ defined(F_GETFD) -enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; -# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(TESTFD, GENOPEN_CLOEXEC, \ +enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; +# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ do { \ - static int strategy = CLOEXEC_EXPERIMENT; \ switch (strategy) { \ case CLOEXEC_EXPERIMENT: default: { \ int res = (GENOPEN_CLOEXEC), eno; \ @@ -149,7 +148,7 @@ enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; } \ } while(0) #else -# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(TESTFD, GENOPEN_CLOEXEC, \ +# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) #endif @@ -160,10 +159,13 @@ enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \ setfd_cloexec(fd)); \ } while(0) -#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \ +#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \ + ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \ do { \ int fd; \ - DO_GENOPEN_EXPERIMENTING_CLOEXEC(fd, fd = (ONEOPEN_CLOEXEC), \ + DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ + fd, \ + fd = (ONEOPEN_CLOEXEC), \ fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \ } while(0) @@ -174,9 +176,10 @@ enum { CLOEXEC_EXPERIMENT, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; } while(0) #define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \ DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) -#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PIPEFD, PIPEOPEN_CLOEXEC, \ +#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \ PIPEOPEN_NORMAL) \ - DO_GENOPEN_EXPERIMENTING_CLOEXEC((PIPEFD)[0], PIPEOPEN_CLOEXEC, \ + DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ + (PIPEFD)[0], PIPEOPEN_CLOEXEC, \ PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) int @@ -188,7 +191,9 @@ Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd) * to extend it, so for the time being this just isn't available on * PERL_IMPLICIT_SYS builds. */ + dVAR; DO_ONEOPEN_EXPERIMENTING_CLOEXEC( + PL_strategy_dup, fcntl(oldfd, F_DUPFD_CLOEXEC, 0), PerlLIO_dup(oldfd)); #else @@ -205,7 +210,9 @@ Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd) * to extend it, so for the time being this just isn't available on * PERL_IMPLICIT_SYS builds. */ + dVAR; DO_ONEOPEN_EXPERIMENTING_CLOEXEC( + PL_strategy_dup2, dup3(oldfd, newfd, O_CLOEXEC), PerlLIO_dup2(oldfd, newfd)); #else @@ -216,9 +223,11 @@ Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd) int Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag) { + dVAR; PERL_ARGS_ASSERT_PERLLIO_OPEN_CLOEXEC; #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( + PL_strategy_open, PerlLIO_open(file, flag | O_CLOEXEC), PerlLIO_open(file, flag)); #else @@ -229,9 +238,11 @@ Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag) int Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm) { + dVAR; PERL_ARGS_ASSERT_PERLLIO_OPEN3_CLOEXEC; #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( + PL_strategy_open3, PerlLIO_open3(file, flag | O_CLOEXEC, perm), PerlLIO_open3(file, flag, perm)); #else @@ -242,9 +253,11 @@ Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm) int Perl_my_mkstemp_cloexec(char *templte) { + dVAR; PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC; #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( + PL_strategy_mkstemp, Perl_my_mkostemp(templte, O_CLOEXEC), Perl_my_mkstemp(templte)); #else @@ -256,6 +269,7 @@ Perl_my_mkstemp_cloexec(char *templte) int Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd) { + dVAR; PERL_ARGS_ASSERT_PERLPROC_PIPE_CLOEXEC; /* * struct IPerlProc doesn't cover pipe2(), and there's no clear way @@ -263,7 +277,7 @@ Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd) * PERL_IMPLICIT_SYS builds. */ # if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC) - DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(pipefd, + DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd, pipe2(pipefd, O_CLOEXEC), PerlProc_pipe(pipefd)); # else @@ -278,7 +292,9 @@ int Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol) { # if defined(SOCK_CLOEXEC) + dVAR; DO_ONEOPEN_EXPERIMENTING_CLOEXEC( + PL_strategy_socket, PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol), PerlSock_socket(domain, type, protocol)); # else @@ -297,7 +313,9 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, * way to extend it, so for the time being this just isn't available * on PERL_IMPLICIT_SYS builds. */ + dVAR; DO_ONEOPEN_EXPERIMENTING_CLOEXEC( + PL_strategy_accept, accept4(listenfd, addr, addrlen, SOCK_CLOEXEC), PerlSock_accept(listenfd, addr, addrlen)); # else @@ -314,9 +332,10 @@ int Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol, int *pairfd) { + dVAR; PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC; # ifdef SOCK_CLOEXEC - DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(pairfd, + DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd, PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd), PerlSock_socketpair(domain, type, protocol, pairfd)); # else diff --git a/dump.c b/dump.c index 98a307e038..9de1941b5a 100644 --- a/dump.c +++ b/dump.c @@ -1699,6 +1699,7 @@ const struct flag_to_name regexp_core_intflags_names[] = { void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { + dVAR; SV *d; const char *s; U32 flags; diff --git a/embed.fnc b/embed.fnc index 07a38a1b57..808ef83958 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3130,7 +3130,7 @@ px |void |my_clearenv Apo |void* |my_cxt_init |NN const char *my_cxt_key|size_t size Apo |int |my_cxt_index |NN const char *my_cxt_key #else -Apo |void* |my_cxt_init |NN int *index|size_t size +Apo |void* |my_cxt_init |NN int *indexp|size_t size #endif #endif #if defined(PERL_IN_UTIL_C) diff --git a/embedvar.h b/embedvar.h index 705be5ddf2..420664d68c 100644 --- a/embedvar.h +++ b/embedvar.h @@ -203,7 +203,6 @@ #define PL_modcount (vTHX->Imodcount) #define PL_modglobal (vTHX->Imodglobal) #define PL_multideref_pc (vTHX->Imultideref_pc) -#define PL_my_cxt_keys (vTHX->Imy_cxt_keys) #define PL_my_cxt_list (vTHX->Imy_cxt_list) #define PL_my_cxt_size (vTHX->Imy_cxt_size) #define PL_na (vTHX->Ina) @@ -426,6 +425,10 @@ #define PL_Gmy_ctx_mutex (my_vars->Gmy_ctx_mutex) #define PL_my_cxt_index (my_vars->Gmy_cxt_index) #define PL_Gmy_cxt_index (my_vars->Gmy_cxt_index) +#define PL_my_cxt_keys (my_vars->Gmy_cxt_keys) +#define PL_Gmy_cxt_keys (my_vars->Gmy_cxt_keys) +#define PL_my_cxt_keys_size (my_vars->Gmy_cxt_keys_size) +#define PL_Gmy_cxt_keys_size (my_vars->Gmy_cxt_keys_size) #define PL_op_mutex (my_vars->Gop_mutex) #define PL_Gop_mutex (my_vars->Gop_mutex) #define PL_op_seq (my_vars->Gop_seq) @@ -460,6 +463,24 @@ #define PL_Gsig_trapped (my_vars->Gsig_trapped) #define PL_sigfpe_saved (my_vars->Gsigfpe_saved) #define PL_Gsigfpe_saved (my_vars->Gsigfpe_saved) +#define PL_strategy_accept (my_vars->Gstrategy_accept) +#define PL_Gstrategy_accept (my_vars->Gstrategy_accept) +#define PL_strategy_dup (my_vars->Gstrategy_dup) +#define PL_Gstrategy_dup (my_vars->Gstrategy_dup) +#define PL_strategy_dup2 (my_vars->Gstrategy_dup2) +#define PL_Gstrategy_dup2 (my_vars->Gstrategy_dup2) +#define PL_strategy_mkstemp (my_vars->Gstrategy_mkstemp) +#define PL_Gstrategy_mkstemp (my_vars->Gstrategy_mkstemp) +#define PL_strategy_open (my_vars->Gstrategy_open) +#define PL_Gstrategy_open (my_vars->Gstrategy_open) +#define PL_strategy_open3 (my_vars->Gstrategy_open3) +#define PL_Gstrategy_open3 (my_vars->Gstrategy_open3) +#define PL_strategy_pipe (my_vars->Gstrategy_pipe) +#define PL_Gstrategy_pipe (my_vars->Gstrategy_pipe) +#define PL_strategy_socket (my_vars->Gstrategy_socket) +#define PL_Gstrategy_socket (my_vars->Gstrategy_socket) +#define PL_strategy_socketpair (my_vars->Gstrategy_socketpair) +#define PL_Gstrategy_socketpair (my_vars->Gstrategy_socketpair) #define PL_sv_placeholder (my_vars->Gsv_placeholder) #define PL_Gsv_placeholder (my_vars->Gsv_placeholder) #define PL_thr_key (my_vars->Gthr_key) diff --git a/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm b/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm index 6090970adc..46af2a6073 100644 --- a/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm +++ b/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm @@ -6,7 +6,7 @@ use ExtUtils::Embed 1.31, qw(xsi_header xsi_protos xsi_body); our @ISA = qw(Exporter); our @EXPORT = qw(writemain); -our $VERSION = '1.08'; +our $VERSION = '1.09'; # blead will run this with miniperl, hence we can't use autodie or File::Temp my $temp; @@ -63,7 +63,7 @@ sub writemain{ * * The content of the body of this generated file is mostly contained * in Miniperl.pm - edit that file if you want to change anything. - * miniperlmain.c is generated by running regen/miniperlmain.pl.pl, while + * miniperlmain.c is generated by running regen/miniperlmain.pl, while * perlmain.c is built automatically by Makefile (so the former is * included in the tarball while the latter isn't). */ @@ -78,6 +78,11 @@ sub writemain{ #endif #define PERL_IN_MINIPERLMAIN_C + +/* work round bug in MakeMaker which doesn't currently (2019) supply this + * flag when making a statically linked perl */ +#define PERL_CORE 1 + %s static void xs_init (pTHX); static PerlInterpreter *my_perl; diff --git a/ext/SDBM_File/sdbm.c b/ext/SDBM_File/sdbm.c index bdb5f47cf5..d7839aa8c2 100644 --- a/ext/SDBM_File/sdbm.c +++ b/ext/SDBM_File/sdbm.c @@ -7,7 +7,6 @@ * core routines */ -#include "INTERN.h" #include "config.h" #ifdef WIN32 #include "io.h" diff --git a/globals.c b/globals.c index 14a53a45b4..8d6f2b1968 100644 --- a/globals.c +++ b/globals.c @@ -33,6 +33,13 @@ #include "perlapi.h" /* bring in PL_force_link_funcs */ +/* regcomp.h * isn't #included in perl.h, as its only included within a + * few specific files such as regcomp.c, regexec.c. So include it + * explicitly to process any data declarations within it. + */ +#include "regcomp.h" + + /* * ex: set ts=8 sts=4 sw=4 et: */ diff --git a/globvar.sym b/globvar.sym index 476f4ca095..dcc65f2e29 100644 --- a/globvar.sym +++ b/globvar.sym @@ -66,6 +66,15 @@ PL_sig_name PL_sig_num PL_simple PL_simple_bitmask +PL_strategy_dup +PL_strategy_dup2 +PL_strategy_open +PL_strategy_open3 +PL_strategy_mkstemp +PL_strategy_socket +PL_strategy_accept +PL_strategy_pipe +PL_strategy_socketpair PL_strict_utf8_dfa_tab PL_subversion PL_utf8skip diff --git a/intrpvar.h b/intrpvar.h index f604ef9426..1f69ab277a 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -772,9 +772,6 @@ PERLVARI(I, globhook, globhook_t, NULL) #ifdef PERL_IMPLICIT_CONTEXT PERLVARI(I, my_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */ PERLVARI(I, my_cxt_size, int, 0) /* size of PL_my_cxt_list */ -# ifdef PERL_GLOBAL_STRUCT_PRIVATE -PERLVARI(I, my_cxt_keys, const char **, NULL) /* per-module array of pointers to MY_CXT_KEY constants */ -# endif #endif #if defined(PERL_IMPLICIT_CONTEXT) || defined(PERL_DEBUG_READONLY_COW) diff --git a/locale.c b/locale.c index e7348e1c78..c8f0196095 100644 --- a/locale.c +++ b/locale.c @@ -207,7 +207,7 @@ const int categories[] = { /* The top-most real element is LC_ALL */ -const char * category_names[] = { +const char * const category_names[] = { # ifdef USE_LOCALE_NUMERIC "LC_NUMERIC", @@ -3162,6 +3162,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * values for our db, instead of trying to change them. * */ + dVAR; + int ok = 1; #ifndef USE_LOCALE diff --git a/makedef.pl b/makedef.pl index 2e4e6dcda0..10c7d1e330 100644 --- a/makedef.pl +++ b/makedef.pl @@ -283,7 +283,6 @@ unless ($define{'DEBUGGING'}) { Perl_hv_assert PL_watchaddr PL_watchok - PL_watch_pvx ); } @@ -455,6 +454,7 @@ unless ($define{'PERL_IMPLICIT_CONTEXT'}) { PL_my_cxt_list PL_my_cxt_size PL_my_cxt_keys + PL_my_cxt_keys_size Perl_croak_nocontext Perl_die_nocontext Perl_deb_nocontext @@ -536,6 +536,7 @@ unless ($define{'PERL_GLOBAL_STRUCT'}) { unless ($define{'PERL_GLOBAL_STRUCT_PRIVATE'}) { ++$skip{$_} foreach qw( PL_my_cxt_keys + PL_my_cxt_keys_size Perl_my_cxt_index ); } diff --git a/miniperlmain.c b/miniperlmain.c index c885e0e4ff..0d32aeaf33 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -33,7 +33,7 @@ * * The content of the body of this generated file is mostly contained * in Miniperl.pm - edit that file if you want to change anything. - * miniperlmain.c is generated by running regen/miniperlmain.pl.pl, while + * miniperlmain.c is generated by running regen/miniperlmain.pl, while * perlmain.c is built automatically by Makefile (so the former is * included in the tarball while the latter isn't). */ @@ -48,6 +48,11 @@ #endif #define PERL_IN_MINIPERLMAIN_C + +/* work round bug in MakeMaker which doesn't currently (2019) supply this + * flag when making a statically linked perl */ +#define PERL_CORE 1 + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" diff --git a/op.c b/op.c index 577404427d..8e7123dff5 100644 --- a/op.c +++ b/op.c @@ -2650,6 +2650,7 @@ S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info) STATIC void S_maybe_multiconcat(pTHX_ OP *o) { + dVAR; OP *lastkidop; /* the right-most of any kids unshifted onto o */ OP *topop; /* the top-most op in the concat tree (often equals o, unless there are assign/stringify ops above it */ @@ -7822,6 +7823,7 @@ S_assignment_type(pTHX_ const OP *o) static OP * S_newONCEOP(pTHX_ OP *initop, OP *padop) { + dVAR; const PADOFFSET target = padop->op_targ; OP *const other = newOP(OP_PADSV, padop->op_flags diff --git a/perlapi.h b/perlapi.h index f08bd60a42..66f5ac5f73 100644 --- a/perlapi.h +++ b/perlapi.h @@ -177,6 +177,10 @@ END_EXTERN_C #define PL_my_ctx_mutex (*Perl_Gmy_ctx_mutex_ptr(NULL)) #undef PL_my_cxt_index #define PL_my_cxt_index (*Perl_Gmy_cxt_index_ptr(NULL)) +#undef PL_my_cxt_keys +#define PL_my_cxt_keys (*Perl_Gmy_cxt_keys_ptr(NULL)) +#undef PL_my_cxt_keys_size +#define PL_my_cxt_keys_size (*Perl_Gmy_cxt_keys_size_ptr(NULL)) #undef PL_op_mutex #define PL_op_mutex (*Perl_Gop_mutex_ptr(NULL)) #undef PL_op_seq @@ -207,6 +211,24 @@ END_EXTERN_C #define PL_sig_trapped (*Perl_Gsig_trapped_ptr(NULL)) #undef PL_sigfpe_saved #define PL_sigfpe_saved (*Perl_Gsigfpe_saved_ptr(NULL)) +#undef PL_strategy_accept +#define PL_strategy_accept (*Perl_Gstrategy_accept_ptr(NULL)) +#undef PL_strategy_dup +#define PL_strategy_dup (*Perl_Gstrategy_dup_ptr(NULL)) +#undef PL_strategy_dup2 +#define PL_strategy_dup2 (*Perl_Gstrategy_dup2_ptr(NULL)) +#undef PL_strategy_mkstemp +#define PL_strategy_mkstemp (*Perl_Gstrategy_mkstemp_ptr(NULL)) +#undef PL_strategy_open +#define PL_strategy_open (*Perl_Gstrategy_open_ptr(NULL)) +#undef PL_strategy_open3 +#define PL_strategy_open3 (*Perl_Gstrategy_open3_ptr(NULL)) +#undef PL_strategy_pipe +#define PL_strategy_pipe (*Perl_Gstrategy_pipe_ptr(NULL)) +#undef PL_strategy_socket +#define PL_strategy_socket (*Perl_Gstrategy_socket_ptr(NULL)) +#undef PL_strategy_socketpair +#define PL_strategy_socketpair (*Perl_Gstrategy_socketpair_ptr(NULL)) #undef PL_sv_placeholder #define PL_sv_placeholder (*Perl_Gsv_placeholder_ptr(NULL)) #undef PL_thr_key diff --git a/perlvars.h b/perlvars.h index 51c939e128..edc96c46a5 100644 --- a/perlvars.h +++ b/perlvars.h @@ -111,9 +111,7 @@ PERLVAR(G, lc_numeric_mutex, perl_mutex) /* Mutex for switching LC_NUMERIC */ PERLVAR(G, C_locale_obj, locale_t) #endif -#ifdef DEBUGGING PERLVARI(G, watch_pvx, char *, NULL) -#endif /* =for apidoc AmU|Perl_check_t *|PL_check @@ -304,7 +302,7 @@ PERLVAR(G, utf8_tosimplefold, SV *) PERLVAR(G, utf8_charname_begin, SV *) PERLVAR(G, utf8_charname_continue, SV *) PERLVAR(G, utf8_mark, SV *) -PERLVAR(G, InBitmap, SV *) +PERLVARI(G, InBitmap, SV *, NULL) PERLVAR(G, CCC_non0_non230, SV *) /* Definitions of user-defined \p{} properties, as the subs that define them @@ -321,3 +319,29 @@ PERLVAR(G, user_prop_mutex, perl_mutex) /* Mutex for manipulating /* Everything that folds to a given character, for case insensitivity regex * matching */ PERLVAR(G, utf8_foldclosures, SV *) + +/* these record the best way to to perform certain IO operations while + * atomically setting FD_CLOEXEC. On the first call, a probe is done + * and the result recorded for use by subsequent calls. + * In theory these variables aren't thread-safe, but the worst that can + * happen is that two treads will both do an initial probe + */ +PERLVARI(G, strategy_dup, int, 0) /* doio.c */ +PERLVARI(G, strategy_dup2, int, 0) /* doio.c */ +PERLVARI(G, strategy_open, int, 0) /* doio.c */ +PERLVARI(G, strategy_open3, int, 0) /* doio.c */ +PERLVARI(G, strategy_mkstemp, int, 0) /* doio.c */ +PERLVARI(G, strategy_socket, int, 0) /* doio.c */ +PERLVARI(G, strategy_accept, int, 0) /* doio.c */ +PERLVARI(G, strategy_pipe, int, 0) /* doio.c */ +PERLVARI(G, strategy_socketpair, int, 0) /* doio.c */ + +#ifdef PERL_IMPLICIT_CONTEXT +# ifdef PERL_GLOBAL_STRUCT_PRIVATE +/* per-module array of pointers to MY_CXT_KEY constants. + * It simulates each module having a static my_cxt_index var on builds + * which don't allow static vars */ +PERLVARI(G, my_cxt_keys, const char **, NULL) +PERLVARI(G, my_cxt_keys_size, int, 0) /* size of PL_my_cxt_keys */ +# endif +#endif diff --git a/pp.c b/pp.c index 4cdf832453..5965f1adc0 100644 --- a/pp.c +++ b/pp.c @@ -4034,6 +4034,7 @@ PP(pp_ucfirst) PP(pp_uc) { + dVAR; dSP; SV *source = TOPs; STRLEN len; diff --git a/proto.h b/proto.h index 680733cf9d..5e7b23f419 100644 --- a/proto.h +++ b/proto.h @@ -4058,9 +4058,9 @@ PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd); #endif #if !(defined(PERL_GLOBAL_STRUCT_PRIVATE)) # if defined(PERL_IMPLICIT_CONTEXT) -PERL_CALLCONV void* Perl_my_cxt_init(pTHX_ int *index, size_t size); +PERL_CALLCONV void* Perl_my_cxt_init(pTHX_ int *indexp, size_t size); #define PERL_ARGS_ASSERT_MY_CXT_INIT \ - assert(index) + assert(indexp) # endif #endif #if !(defined(_MSC_VER)) diff --git a/regcomp.c b/regcomp.c index 5949b8809b..5bae668075 100644 --- a/regcomp.c +++ b/regcomp.c @@ -74,10 +74,6 @@ #define PERL_IN_REGCOMP_C #include "perl.h" -#ifndef PERL_IN_XSUB_RE -# include "INTERN.h" -#endif - #define REG_COMP_C #ifdef PERL_IN_XSUB_RE # include "re_comp.h" @@ -1560,6 +1556,7 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, * returned list must, and will, contain every code point that is a * possibility. */ + dVAR; SV* invlist = NULL; SV* only_utf8_locale_invlist = NULL; unsigned int i; @@ -4428,6 +4425,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* recursed: which subroutines have we recursed into */ /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */ { + dVAR; /* There must be at least this number of characters to match */ SSize_t min = 0; I32 pars = 0, code; @@ -7301,6 +7299,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *expr, const regexp_engine* eng, REGEXP *old_re, bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags) { + dVAR; REGEXP *Rx; /* Capital 'R' means points to a REGEXP */ STRLEN plen; char *exp; @@ -10528,6 +10527,7 @@ Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b) STATIC SV* S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node) { + dVAR; const U8 * s = (U8*)STRING(node); SSize_t bytelen = STR_LEN(node); UV uc; @@ -13078,6 +13078,7 @@ S_backref_value(char *p, char *e) STATIC regnode_offset S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) { + dVAR; regnode_offset ret = 0; I32 flags = 0; char *parse_start; @@ -14576,6 +14577,8 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) * sets up the bitmap and any flags, removing those code points from the * inversion list, setting it to NULL should it become completely empty */ + dVAR; + PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST; assert(PL_regkind[OP(node)] == ANYOF); @@ -16471,6 +16474,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * UTF-8 */ + dVAR; UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE; IV range = 0; UV value = OOB_UNICODE, save_value = OOB_UNICODE; @@ -19897,6 +19901,7 @@ void Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state) { #ifdef DEBUGGING + dVAR; int k; RXi_GET_DECL(prog, progi); GET_RE_DEBUG_FLAGS_DECL; @@ -21189,6 +21194,7 @@ S_put_charclass_bitmap_innards_common(pTHX_ * output would have been only the inversion indicator '^', NULL is instead * returned. */ + dVAR; SV * output; PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON; @@ -21292,6 +21298,8 @@ S_put_charclass_bitmap_innards(pTHX_ SV *sv, * whether the class itself is to be inverted. However, there are some * cases where it can't try inverting, as what actually matches isn't known * until runtime, and hence the inversion isn't either. */ + + dVAR; bool inverting_allowed = ! force_as_is_display; int i; @@ -21686,6 +21694,8 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, void Perl_init_uniprops(pTHX) { + dVAR; + PL_user_def_props = newHV(); #ifdef USE_ITHREADS @@ -22120,6 +22130,7 @@ S_delete_recursion_entry(pTHX_ void *key) * properties. This is a function so it can be set up to be called even if * the program unexpectedly quits */ + dVAR; SV ** current_entry; const STRLEN key_len = strlen((const char *) key); DECLARATION_FOR_GLOBAL_CONTEXT; @@ -22176,6 +22187,7 @@ Perl_parse_uniprop_string(pTHX_ this */ const STRLEN level) /* Recursion level of this call */ { + dVAR; char* lookup_name; /* normalized name for lookup in our tables */ unsigned lookup_len; /* Its length */ bool stricter = FALSE; /* Some properties have stricter name diff --git a/regen/mk_invlists.pl b/regen/mk_invlists.pl index 55c4afb279..61148282b5 100644 --- a/regen/mk_invlists.pl +++ b/regen/mk_invlists.pl @@ -2911,7 +2911,7 @@ foreach my $prop (@props) { switch_pound_if ('binary_property_tables', 'PERL_IN_REGCOMP_C'); -print $out_fh "\nconst char * deprecated_property_msgs[] = {\n\t"; +print $out_fh "\nconst char * const deprecated_property_msgs[] = {\n\t"; print $out_fh join ",\n\t", map { "\"$_\"" } @deprecated_messages; print $out_fh "\n};\n"; diff --git a/regexec.c b/regexec.c index b612f04d6c..e00583aece 100644 --- a/regexec.c +++ b/regexec.c @@ -506,6 +506,8 @@ S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character, const U8* e) * rules, ignoring any locale. So use the Unicode function if this class * requires an inversion list, and use the Unicode macro otherwise. */ + dVAR; + PERL_ARGS_ASSERT_ISFOO_UTF8_LC; if (UTF8_IS_INVARIANT(*character)) { @@ -4680,6 +4682,7 @@ S_isGCB(pTHX_ const GCB_enum before, const GCB_enum after, const U8 * const strb STATIC GCB_enum S_backup_one_GCB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target) { + dVAR; GCB_enum gcb; PERL_ARGS_ASSERT_BACKUP_ONE_GCB; @@ -4957,6 +4960,8 @@ S_isLB(pTHX_ LB_enum before, STATIC LB_enum S_advance_one_LB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_target) { + dVAR; + LB_enum lb; PERL_ARGS_ASSERT_ADVANCE_ONE_LB; @@ -4986,6 +4991,7 @@ S_advance_one_LB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_ta STATIC LB_enum S_backup_one_LB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target) { + dVAR; LB_enum lb; PERL_ARGS_ASSERT_BACKUP_ONE_LB; @@ -5222,6 +5228,7 @@ S_isSB(pTHX_ SB_enum before, STATIC SB_enum S_advance_one_SB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_target) { + dVAR; SB_enum sb; PERL_ARGS_ASSERT_ADVANCE_ONE_SB; @@ -5255,6 +5262,7 @@ S_advance_one_SB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_ta STATIC SB_enum S_backup_one_SB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target) { + dVAR; SB_enum sb; PERL_ARGS_ASSERT_BACKUP_ONE_SB; @@ -5491,6 +5499,7 @@ S_advance_one_WB(pTHX_ U8 ** curpos, const bool utf8_target, const bool skip_Extend_Format) { + dVAR; WB_enum wb; PERL_ARGS_ASSERT_ADVANCE_ONE_WB; @@ -5528,6 +5537,7 @@ S_advance_one_WB(pTHX_ U8 ** curpos, STATIC WB_enum S_backup_one_WB(pTHX_ WB_enum * previous, const U8 * const strbeg, U8 ** curpos, const bool utf8_target) { + dVAR; WB_enum wb; PERL_ARGS_ASSERT_BACKUP_ONE_WB; @@ -9073,6 +9083,7 @@ STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, regmatch_info *const reginfo, I32 max _pDEPTH) { + dVAR; char *scan; /* Pointer to current position in target string */ I32 c; char *loceol = reginfo->strend; /* local version */ @@ -10171,6 +10182,8 @@ Perl__is_grapheme(pTHX_ const U8 * strbeg, const U8 * s, const U8 * strend, cons * so code using it would then break), and there has to be a GCB break * before and after the character. */ + dVAR; + GCB_enum cp_gcb_val, prev_cp_gcb_val, next_cp_gcb_val; const U8 * prev_cp_start; @@ -10289,6 +10302,7 @@ Perl_isSCRIPT_RUN(pTHX_ const U8 * s, const U8 * send, const bool utf8_target) * characters for at least one language in the Unicode Common Locale Data * Repository [CLDR]. */ + dVAR; /* Things that match /\d/u */ SV * decimals_invlist = PL_XPosix_ptrs[_CC_DIGIT]; diff --git a/sv.c b/sv.c index 0a4a2e531a..0bb96391e0 100644 --- a/sv.c +++ b/sv.c @@ -1071,10 +1071,10 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT) dVAR; #endif -#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) +#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT) static bool done_sanity_check; - /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global + /* PERL_GLOBAL_STRUCT cannot coexist with global * variables like done_sanity_check. */ if (!done_sanity_check) { unsigned int i = SVt_LAST; @@ -15575,16 +15575,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, if (PL_my_cxt_size) { Newx(PL_my_cxt_list, PL_my_cxt_size, void *); Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); -#ifdef PERL_GLOBAL_STRUCT_PRIVATE - Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); - Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); -#endif } else { PL_my_cxt_list = (void**)NULL; -#ifdef PERL_GLOBAL_STRUCT_PRIVATE - PL_my_cxt_keys = (const char**)NULL; -#endif } PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); @@ -15896,6 +15889,8 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) void Perl_init_constants(pTHX) { + dVAR; + SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVf_PROTECT|SVt_NULL; SvANY(&PL_sv_undef) = NULL; diff --git a/toke.c b/toke.c index 5a3fe78472..0bf86ad314 100644 --- a/toke.c +++ b/toke.c @@ -2596,6 +2596,7 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) * interior, hence to the "}". Finds what the name resolves to, returning * an SV* containing it; NULL if no valid one found */ + dVAR; SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0); HV * table; diff --git a/uni_keywords.h b/uni_keywords.h index 9f9243fb5c..2808b27682 100644 --- a/uni_keywords.h +++ b/uni_keywords.h @@ -6996,6 +6996,6 @@ MPH_VALt match_uniprop( const unsigned char * const key, const U16 key_len ) { * 7bd6bcbe3813e0cd55e0998053d182b7bc8c97dcfd0b85028e9f7f55af4ad61b lib/unicore/version * 4bb677187a1a64e39d48f2e341b5ecb6c99857e49d7a79cf503bd8a3c709999b regen/charset_translations.pl * 03e51b0f07beebd5da62ab943899aa4934eee1f792fa27c1fb638c33bf4ac6ea regen/mk_PL_charclass.pl - * 8ae37f2b5bbc7d215f63e8d1189754d83a16c6156fd353847f6fcced90c513d5 regen/mk_invlists.pl + * 2fb19108265d37fc38920cd3f775c5c9fc25ae8b95be3bf197f47da1dc4989f4 regen/mk_invlists.pl * c56b78df81e0f96632246052d71580b212546ca02ba4075158965e11d892f21e regen/mph.pl * ex: set ro: */ diff --git a/utf8.c b/utf8.c index ff5d4ad8ee..71159526ae 100644 --- a/utf8.c +++ b/utf8.c @@ -2778,6 +2778,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) bool Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c) { + dVAR; return _invlist_contains_cp(PL_XPosix_ptrs[classnum], c); } @@ -2787,6 +2788,8 @@ Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c) bool Perl__is_utf8_idstart(pTHX_ const U8 *p) { + dVAR; + PERL_ARGS_ASSERT__IS_UTF8_IDSTART; if (*p == '_') @@ -2797,12 +2800,14 @@ Perl__is_utf8_idstart(pTHX_ const U8 *p) bool Perl__is_uni_perl_idcont(pTHX_ UV c) { + dVAR; return _invlist_contains_cp(PL_utf8_perl_idcont, c); } bool Perl__is_uni_perl_idstart(pTHX_ UV c) { + dVAR; return _invlist_contains_cp(PL_utf8_perl_idstart, c); } @@ -2942,6 +2947,7 @@ Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) * The ordinal of the first character of the changed version is returned * (but note, as explained above, that there may be more.) */ + dVAR; PERL_ARGS_ASSERT_TO_UNI_UPPER; if (c < 256) { @@ -2954,6 +2960,7 @@ Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) UV Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) { + dVAR; PERL_ARGS_ASSERT_TO_UNI_TITLE; if (c < 256) { @@ -2993,6 +3000,7 @@ S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp, const char dummy) UV Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp) { + dVAR; PERL_ARGS_ASSERT_TO_UNI_LOWER; if (c < 256) { @@ -3074,6 +3082,7 @@ Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags) * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited */ + dVAR; PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS; if (flags & FOLD_FLAGS_LOCALE) { @@ -3210,6 +3219,7 @@ Perl__is_utf8_FOO(pTHX_ U8 classnum, const char * const file, const unsigned line) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_FOO; warn_on_first_deprecated_use(name, alternative, use_locale, file, line); @@ -3282,6 +3292,7 @@ bool Perl__is_utf8_FOO_with_len(pTHX_ const U8 classnum, const U8 *p, const U8 * const e) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_FOO_WITH_LEN; return is_utf8_common_with_len(p, e, PL_XPosix_ptrs[classnum]); @@ -3290,6 +3301,7 @@ Perl__is_utf8_FOO_with_len(pTHX_ const U8 classnum, const U8 *p, bool Perl__is_utf8_perl_idstart_with_len(pTHX_ const U8 *p, const U8 * const e) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART_WITH_LEN; return is_utf8_common_with_len(p, e, PL_utf8_perl_idstart); @@ -3298,6 +3310,7 @@ Perl__is_utf8_perl_idstart_with_len(pTHX_ const U8 *p, const U8 * const e) bool Perl__is_utf8_xidstart(pTHX_ const U8 *p) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_XIDSTART; if (*p == '_') @@ -3308,6 +3321,7 @@ Perl__is_utf8_xidstart(pTHX_ const U8 *p) bool Perl__is_utf8_perl_idcont_with_len(pTHX_ const U8 *p, const U8 * const e) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT_WITH_LEN; return is_utf8_common_with_len(p, e, PL_utf8_perl_idcont); @@ -3316,6 +3330,7 @@ Perl__is_utf8_perl_idcont_with_len(pTHX_ const U8 *p, const U8 * const e) bool Perl__is_utf8_idcont(pTHX_ const U8 *p) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_IDCONT; return is_utf8_common(p, PL_utf8_idcont); @@ -3324,6 +3339,7 @@ Perl__is_utf8_idcont(pTHX_ const U8 *p) bool Perl__is_utf8_xidcont(pTHX_ const U8 *p) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_XIDCONT; return is_utf8_common(p, PL_utf8_xidcont); @@ -3332,6 +3348,7 @@ Perl__is_utf8_xidcont(pTHX_ const U8 *p) bool Perl__is_utf8_mark(pTHX_ const U8 *p) { + dVAR; PERL_ARGS_ASSERT__IS_UTF8_MARK; return is_utf8_common(p, PL_utf8_mark); @@ -3535,6 +3552,7 @@ Perl__inverse_folds(pTHX_ const UV cp, unsigned int * first_folds_to, * the return can point to them, but single code points aren't, so would * need to be constructed if we didn't employ something like this API */ + dVAR; /* 'index' is guaranteed to be non-negative, as this is an inversion map * that covers all possible inputs. See [perl #133365] */ SSize_t index = _invlist_search(PL_utf8_foldclosures, cp); @@ -3761,6 +3779,7 @@ S_turkic_lc(pTHX_ const U8 * const p0, const U8 * const e, * sequence, and the entire sequence will be stored in *ustrp. ustrp will * contain *lenp bytes */ + dVAR; PERL_ARGS_ASSERT_TURKIC_LC; assert(e > p0); @@ -3944,6 +3963,7 @@ Perl__to_utf8_upper_flags(pTHX_ const U8 *p, const char * const file, const int line) { + dVAR; UV result; const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_UPPER, cBOOL(flags), file, line); @@ -3979,6 +3999,7 @@ Perl__to_utf8_title_flags(pTHX_ const U8 *p, const char * const file, const int line) { + dVAR; UV result; const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_TITLE, cBOOL(flags), file, line); @@ -4012,6 +4033,7 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, const char * const file, const int line) { + dVAR; UV result; const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_LOWER, cBOOL(flags), file, line); @@ -4049,6 +4071,7 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, const char * const file, const int line) { + dVAR; UV result; const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_FOLD, cBOOL(flags), file, line); diff --git a/util.c b/util.c index 8c9909e10c..aa7a0458f8 100644 --- a/util.c +++ b/util.c @@ -1527,6 +1527,7 @@ S_with_queued_errors(pTHX_ SV *ex) STATIC bool S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { + dVAR; HV *stash; GV *gv; CV *cv; @@ -5203,50 +5204,12 @@ Perl_my_clearenv(pTHX) #ifdef PERL_IMPLICIT_CONTEXT -/* Implements the MY_CXT_INIT macro. The first time a module is loaded, -the global PL_my_cxt_index is incremented, and that value is assigned to -that module's static my_cxt_index (who's address is passed as an arg). -Then, for each interpreter this function is called for, it makes sure a -void* slot is available to hang the static data off, by allocating or -extending the interpreter's PL_my_cxt_list array */ - -#ifndef PERL_GLOBAL_STRUCT_PRIVATE -void * -Perl_my_cxt_init(pTHX_ int *index, size_t size) -{ - dVAR; - void *p; - PERL_ARGS_ASSERT_MY_CXT_INIT; - if (*index == -1) { - /* this module hasn't been allocated an index yet */ - MUTEX_LOCK(&PL_my_ctx_mutex); - *index = PL_my_cxt_index++; - MUTEX_UNLOCK(&PL_my_ctx_mutex); - } - - /* make sure the array is big enough */ - if (PL_my_cxt_size <= *index) { - if (PL_my_cxt_size) { - IV new_size = PL_my_cxt_size; - while (new_size <= *index) - new_size *= 2; - Renew(PL_my_cxt_list, new_size, void *); - PL_my_cxt_size = new_size; - } - else { - PL_my_cxt_size = 16; - Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - } - } - /* newSV() allocates one more than needed */ - p = (void*)SvPVX(newSV(size-1)); - PL_my_cxt_list[*index] = p; - Zero(p, size, char); - return p; -} -#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE +/* rather than each module having a static var holding its index, + * use a global array of name to index mappings + */ int Perl_my_cxt_index(pTHX_ const char *my_cxt_key) { @@ -5265,9 +5228,22 @@ Perl_my_cxt_index(pTHX_ const char *my_cxt_key) } return -1; } +# endif + + +/* Implements the MY_CXT_INIT macro. The first time a module is loaded, +the global PL_my_cxt_index is incremented, and that value is assigned to +that module's static my_cxt_index (who's address is passed as an arg). +Then, for each interpreter this function is called for, it makes sure a +void* slot is available to hang the static data off, by allocating or +extending the interpreter's PL_my_cxt_list array */ void * +# ifdef PERL_GLOBAL_STRUCT_PRIVATE Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) +# else +Perl_my_cxt_init(pTHX_ int *indexp, size_t size) +# endif { dVAR; void *p; @@ -5275,44 +5251,81 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) PERL_ARGS_ASSERT_MY_CXT_INIT; +# ifdef PERL_GLOBAL_STRUCT_PRIVATE index = Perl_my_cxt_index(aTHX_ my_cxt_key); +# else + index = *indexp; +# endif + /* do initial check without locking. + * -1: not allocated or another thread currently allocating + * other: already allocated by another thread + */ if (index == -1) { - /* this module hasn't been allocated an index yet */ MUTEX_LOCK(&PL_my_ctx_mutex); - index = PL_my_cxt_index++; + /*now a stricter check with locking */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + index = Perl_my_cxt_index(aTHX_ my_cxt_key); +# else + index = *indexp; +# endif + if (index == -1) + /* this module hasn't been allocated an index yet */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + index = PL_my_cxt_index++; + + /* Store the index in a global MY_CXT_KEY string to index mapping + * table. This emulates the perl-module static my_cxt_index var on + * builds which don't allow static vars */ + if (PL_my_cxt_keys_size <= index) { + int old_size = PL_my_cxt_keys_size; + int i; + if (PL_my_cxt_keys_size) { + IV new_size = PL_my_cxt_keys_size; + while (new_size <= index) + new_size *= 2; + PL_my_cxt_keys = (const char **)PerlMemShared_realloc( + PL_my_cxt_keys, + new_size * sizeof(const char *)); + PL_my_cxt_keys_size = new_size; + } + else { + PL_my_cxt_keys_size = 16; + PL_my_cxt_keys = (const char **)PerlMemShared_malloc( + PL_my_cxt_keys_size * sizeof(const char *)); + } + for (i = old_size; i < PL_my_cxt_keys_size; i++) { + PL_my_cxt_keys[i] = 0; + } + } + PL_my_cxt_keys[index] = my_cxt_key; +# else + *indexp = PL_my_cxt_index++; + index = *indexp; +# endif MUTEX_UNLOCK(&PL_my_ctx_mutex); } /* make sure the array is big enough */ if (PL_my_cxt_size <= index) { - int old_size = PL_my_cxt_size; - int i; if (PL_my_cxt_size) { IV new_size = PL_my_cxt_size; while (new_size <= index) new_size *= 2; Renew(PL_my_cxt_list, new_size, void *); - Renew(PL_my_cxt_keys, new_size, const char *); PL_my_cxt_size = new_size; } else { PL_my_cxt_size = 16; Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); - } - for (i = old_size; i < PL_my_cxt_size; i++) { - PL_my_cxt_keys[i] = 0; - PL_my_cxt_list[i] = 0; } } - PL_my_cxt_keys[index] = my_cxt_key; /* newSV() allocates one more than needed */ p = (void*)SvPVX(newSV(size-1)); PL_my_cxt_list[index] = p; Zero(p, size, char); return p; } -#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ + #endif /* PERL_IMPLICIT_CONTEXT */ diff --git a/vutil.c b/vutil.c index 5d183a0f29..2367489153 100644 --- a/vutil.c +++ b/vutil.c @@ -571,6 +571,11 @@ Perl_upg_version2(pTHX_ SV *ver, bool qv) Perl_upg_version(pTHX_ SV *ver, bool qv) #endif { + +#ifdef dVAR + dVAR; +#endif + const char *version, *s; #ifdef SvVOK const MAGIC *mg; diff --git a/win32/win32.c b/win32/win32.c index 8b2808c6d8..8104d864c2 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1684,6 +1684,8 @@ win32_longpath(char *path) static void out_of_memory(void) { + dVAR; + if (PL_curinterp) croak_no_mem(); exit(1); @@ -4711,6 +4713,7 @@ win32_csighandler(int sig) void Perl_sys_intern_init(pTHX) { + dVAR; int i; w32_perlshell_tokens = NULL; @@ -4760,6 +4763,8 @@ Perl_sys_intern_init(pTHX) void Perl_sys_intern_clear(pTHX) { + dVAR; + Safefree(w32_perlshell_tokens); Safefree(w32_perlshell_vec); /* NOTE: w32_fdpid is freed by sv_clean_all() */ -- Perl5 Master Repository
