regcomp: handle cloning the rexc cleanup in the scope stack

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				\

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)

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

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;
 }
 

regen/scope_types.pl

@@ -137,6 +137,7 @@ BEGIN
 SAVEt_FREEPADNAME
 SAVEt_STRLEN_SMALL
 SAVEt_FREERCPV
+SAVEt_FREE_REXC_STATE
 
 /* two args */
 

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;

scope.h

@@ -183,6 +183,11 @@ scope has the given name. C<name> 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) \

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: */

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);