diff --git a/embed.fnc b/embed.fnc index 0332f63875ec..90b518a03f0a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2791,6 +2791,9 @@ Cp |char * |re_intuit_start|NN REGEXP * const rx \ |NULLOK re_scream_pos_data *data Cp |SV * |re_intuit_string \ |NN REGEXP * const r + +p |void |release_RExC_state \ + |NN void *vstate Xp |REGEXP *|re_op_compile |NULLOK SV ** const patternp \ |int pat_count \ |NULLOK OP *expr \ @@ -2799,7 +2802,6 @@ Xp |REGEXP *|re_op_compile |NULLOK SV ** const patternp \ |NULLOK bool *is_bare_re \ |const U32 rx_flags \ |const U32 pm_flags - ATdp |void |repeatcpy |NN char *to \ |NN const char *from \ |SSize_t len \ diff --git a/embed.h b/embed.h index e1e2bf4d02f1..d6926854177b 100644 --- a/embed.h +++ b/embed.h @@ -1200,6 +1200,7 @@ # define refcounted_he_new_pv(a,b,c,d,e) Perl_refcounted_he_new_pv(aTHX_ a,b,c,d,e) # define refcounted_he_new_pvn(a,b,c,d,e,f) Perl_refcounted_he_new_pvn(aTHX_ a,b,c,d,e,f) # define refcounted_he_new_sv(a,b,c,d,e) Perl_refcounted_he_new_sv(aTHX_ a,b,c,d,e) +# define release_RExC_state(a) Perl_release_RExC_state(aTHX_ a) # define report_evil_fh(a) Perl_report_evil_fh(aTHX_ a) # define report_wrongway_fh(a,b) Perl_report_wrongway_fh(aTHX_ a,b) # define rpeep(a) Perl_rpeep(aTHX_ a) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 33fbcecd371f..afd63c046494 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -385,6 +385,11 @@ point part. This should save 24 bytes per stored line for 64-bit systems, more for C<-Duselongdouble> or C<-Dusequadmath> builds. Discussed in [GH #23171]. +=item * + +Ensure cloning the save stack for fork emulation doesn't duplicate +freeing the RExC state. [GH #23022] + =back =head1 Known Problems diff --git a/proto.h b/proto.h index e132956f8ac8..6ded4aeb247f 100644 --- a/proto.h +++ b/proto.h @@ -3893,6 +3893,12 @@ PERL_CALLCONV void Perl_reginitcolors(pTHX); #define PERL_ARGS_ASSERT_REGINITCOLORS +PERL_CALLCONV void +Perl_release_RExC_state(pTHX_ void *vstate) + __attribute__visibility__("hidden"); +#define PERL_ARGS_ASSERT_RELEASE_REXC_STATE \ + assert(vstate) + PERL_CALLCONV void Perl_repeatcpy(char *to, const char *from, SSize_t len, IV count); #define PERL_ARGS_ASSERT_REPEATCPY \ diff --git a/regcomp.c b/regcomp.c index a79221079269..0a84ad07606f 100644 --- a/regcomp.c +++ b/regcomp.c @@ -1356,15 +1356,19 @@ S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc) return true; } -static void -release_RExC_state(pTHX_ void *vstate) { - RExC_state_t *pRExC_state = (RExC_state_t *)vstate; +#ifdef PERL_RE_BUILD_AUX + +void +Perl_release_RExC_state(pTHX_ void *vstate) { + PERL_ARGS_ASSERT_RELEASE_REXC_STATE; + RExC_state_t *pRExC_state = (RExC_state_t *)vstate; + /* Any or all of these might be NULL. There's no point in setting them to NULL after the free, since pRExC_state is about to be released. - */ + */ SvREFCNT_dec(RExC_rx_sv); Safefree(RExC_open_parens); Safefree(RExC_close_parens); @@ -1374,6 +1378,8 @@ release_RExC_state(pTHX_ void *vstate) { Safefree(pRExC_state); } +#endif + /* * Perl_re_op_compile - the perl internal RE engine's function to compile a * regular expression into internal code. @@ -1475,7 +1481,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, * or error. */ Newxz(pRExC_state, 1, RExC_state_t); - SAVEDESTRUCTOR_X(release_RExC_state, pRExC_state); + ENTER_with_name("re_op_compile"); + SAVE_FREE_REXC_STATE(pRExC_state); DEBUG_r({ /* and then initialize RExC_mysv1 and RExC_mysv2 early so if @@ -1572,6 +1579,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, "Precompiled pattern%s\n", orig_rx_flags & RXf_SPLIT ? " for split" : "")); + LEAVE_with_name("re_op_compile"); + return (REGEXP*)re; } } @@ -1587,7 +1596,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, pat = newSVpvn_flags(exp, plen, SVs_TEMP | (IN_BYTES ? 0 : SvUTF8(pat))); } - return CALLREGCOMP_ENG(eng, pat, orig_rx_flags); + REGEXP *re = CALLREGCOMP_ENG(eng, pat, orig_rx_flags); + LEAVE_with_name("re_op_compile"); + return re; } /* ignore the utf8ness if the pattern is 0 length */ @@ -1637,6 +1648,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, Perl_re_printf( aTHX_ "%sSkipping recompilation of unchanged REx%s %s\n", PL_colors[4], PL_colors[5], s); }); + LEAVE_with_name("re_op_compile"); return old_re; } @@ -2471,6 +2483,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (old_re && SvREADONLY(old_re)) SvREADONLY_on(Rx); #endif + LEAVE_with_name("re_op_compile"); return Rx; } diff --git a/regen/scope_types.pl b/regen/scope_types.pl index 3a7522d734b9..a3f406951793 100644 --- a/regen/scope_types.pl +++ b/regen/scope_types.pl @@ -137,6 +137,7 @@ BEGIN SAVEt_FREEPADNAME SAVEt_STRLEN_SMALL SAVEt_FREERCPV +SAVEt_FREE_REXC_STATE /* two args */ diff --git a/scope.c b/scope.c index 210ea36da3e8..b8063c27760b 100644 --- a/scope.c +++ b/scope.c @@ -1391,6 +1391,12 @@ Perl_leave_scope(pTHX_ I32 base) Safefree(a0.any_ptr); break; + case SAVEt_FREE_REXC_STATE: + a0 = ap[0]; + if (a0.any_ptr) + release_RExC_state(a0.any_ptr); + break; + case SAVEt_CLEARPADRANGE: { I32 i; diff --git a/scope.h b/scope.h index 311c4a32ec1b..eccd3aaba2dc 100644 --- a/scope.h +++ b/scope.h @@ -183,6 +183,11 @@ scope has the given name. C must be a literal string. #define SAVESETSVFLAGS(sv,mask,val) save_set_svflags(sv,mask,val) #define SAVEFREECOPHH(h) save_pushptr((void *)(h), SAVEt_FREECOPHH) +#if defined(PERL_CORE) || defined(PERL_EXT) +# define SAVE_FREE_REXC_STATE(p) \ + save_pushptr((void *)(p), SAVEt_FREE_REXC_STATE) +#endif + #define SAVEDELETE(h,k,l) \ save_delete(MUTABLE_HV(h), (char*)(k), (I32)(l)) #define SAVEHDELETE(h,s) \ diff --git a/scope_types.h b/scope_types.h index 6ec8bdfbfb8c..934303ae7bbd 100644 --- a/scope_types.h +++ b/scope_types.h @@ -44,44 +44,45 @@ #define SAVEt_FREEPADNAME 23 #define SAVEt_STRLEN_SMALL 24 #define SAVEt_FREERCPV 25 +#define SAVEt_FREE_REXC_STATE 26 /* two args */ -#define SAVEt_AV 26 -#define SAVEt_DESTRUCTOR 27 -#define SAVEt_DESTRUCTOR_X 28 -#define SAVEt_GENERIC_PVREF 29 -#define SAVEt_GENERIC_SVREF 30 -#define SAVEt_GP 31 -#define SAVEt_GVSV 32 -#define SAVEt_HINTS 33 -#define SAVEt_HPTR 34 -#define SAVEt_HV 35 -#define SAVEt_I32 36 -#define SAVEt_INT 37 -#define SAVEt_ITEM 38 -#define SAVEt_IV 39 -#define SAVEt_PPTR 40 -#define SAVEt_SAVESWITCHSTACK 41 -#define SAVEt_SHARED_PVREF 42 -#define SAVEt_SPTR 43 -#define SAVEt_STRLEN 44 -#define SAVEt_SV 45 -#define SAVEt_SVREF 46 -#define SAVEt_VPTR 47 -#define SAVEt_ADELETE 48 -#define SAVEt_APTR 49 -#define SAVEt_RCPV 50 +#define SAVEt_AV 27 +#define SAVEt_DESTRUCTOR 28 +#define SAVEt_DESTRUCTOR_X 29 +#define SAVEt_GENERIC_PVREF 30 +#define SAVEt_GENERIC_SVREF 31 +#define SAVEt_GP 32 +#define SAVEt_GVSV 33 +#define SAVEt_HINTS 34 +#define SAVEt_HPTR 35 +#define SAVEt_HV 36 +#define SAVEt_I32 37 +#define SAVEt_INT 38 +#define SAVEt_ITEM 39 +#define SAVEt_IV 40 +#define SAVEt_PPTR 41 +#define SAVEt_SAVESWITCHSTACK 42 +#define SAVEt_SHARED_PVREF 43 +#define SAVEt_SPTR 44 +#define SAVEt_STRLEN 45 +#define SAVEt_SV 46 +#define SAVEt_SVREF 47 +#define SAVEt_VPTR 48 +#define SAVEt_ADELETE 49 +#define SAVEt_APTR 50 +#define SAVEt_RCPV 51 /* three args */ -#define SAVEt_HELEM 51 -#define SAVEt_PADSV_AND_MORTALIZE 52 -#define SAVEt_SET_SVFLAGS 53 -#define SAVEt_GVSLOT 54 -#define SAVEt_AELEM 55 -#define SAVEt_DELETE 56 -#define SAVEt_HINTS_HH 57 +#define SAVEt_HELEM 52 +#define SAVEt_PADSV_AND_MORTALIZE 53 +#define SAVEt_SET_SVFLAGS 54 +#define SAVEt_GVSLOT 55 +#define SAVEt_AELEM 56 +#define SAVEt_DELETE 57 +#define SAVEt_HINTS_HH 58 static const U8 leave_scope_arg_counts[] = { 0, /* SAVEt_ALLOC */ @@ -110,6 +111,7 @@ static const U8 leave_scope_arg_counts[] = { 1, /* SAVEt_FREEPADNAME */ 1, /* SAVEt_STRLEN_SMALL */ 1, /* SAVEt_FREERCPV */ + 1, /* SAVEt_FREE_REXC_STATE */ 2, /* SAVEt_AV */ 2, /* SAVEt_DESTRUCTOR */ 2, /* SAVEt_DESTRUCTOR_X */ @@ -144,6 +146,6 @@ static const U8 leave_scope_arg_counts[] = { 3 /* SAVEt_HINTS_HH */ }; -#define MAX_SAVEt 57 +#define MAX_SAVEt 58 /* ex: set ro ft=c: */ diff --git a/sv.c b/sv.c index e8c6e65a2717..ae6d09dea28a 100644 --- a/sv.c +++ b/sv.c @@ -15515,6 +15515,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); break; + case SAVEt_FREE_REXC_STATE: + (void)POPPTR(ss, ix); + /* free only once */ + TOPPTR(nss, ix) = NULL; + break; case SAVEt_FREERCPV: c = (char *)POPPTR(ss,ix); TOPPTR(nss,ix) = rcpv_copy(c);