regcomp.c - in regdupe_internal() set up "in program" stclass properly

We were only handling "synthetic start classes", not ones that are in
the program itself, because those dont have an entry in the data array.
So after copying the program after ruling out that the regstclass is
synthetic we can assume that if its non-null it points into the program
itself, and simply set it up the copy accordingly.

Fixes https://github.com/Perl/perl5/issues/9373

3 files changed, 91 insertions, 0 deletions

diff --git a/MANIFEST b/MANIFEST
index 5a329b6ee5..fc7ad7d12c 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -6216,6 +6216,7 @@ t/re/rxcode.t			See if /(?{ code })/ works
 t/re/script_run.t		See if script runs works
 t/re/speed.t			See if optimisations are keeping things fast
 t/re/speed_thr.t		ditto under threads
+t/re/stclass_threads.t		Test if stclass is preserved across threads
 t/re/subst.t			See if substitution works
 t/re/subst_amp.t		See if $&-related substitution works
 t/re/subst_wamp.t		See if substitution works with $& present
diff --git a/regcomp.c b/regcomp.c
index ac959772ef..f98304daf3 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -13436,6 +13436,15 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
     else
         reti->data = NULL;
 
+    if (ri->regstclass && !reti->regstclass) {
+        /* Assume that the regstclass is a regnode which is inside of the
+         * program which we have to copy over */
+        regnode *node= ri->regstclass;
+        assert(node >= ri->program && (node - ri->program) < len);
+        reti->regstclass = reti->program + (node - ri->program);
+    }
+
+
     reti->name_list_idx = ri->name_list_idx;
 
     SetProgLen(reti, len);
diff --git a/t/re/stclass_threads.t b/t/re/stclass_threads.t
new file mode 100644
index 0000000000..c55515aa40
--- /dev/null
+++ b/t/re/stclass_threads.t
@@ -0,0 +1,81 @@
+#!./perl
+#
+# This is a home for regular expression tests that don't fit into
+# the format supported by re/regexp.t.  If you want to add a test
+# that does fit that format, add it to re/re_tests, not here.
+
+use strict;
+use warnings;
+
+sub run_tests;
+
+$| = 1;
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+    set_up_inc('../lib', '.', '../ext/re');
+    require Config; import Config;
+}
+
+skip_all_without_config('useithreads');
+skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
+
+plan tests => 6;  # Update this when adding/deleting tests.
+
+run_tests() unless caller;
+
+#
+# Tests start here.
+#
+sub run_tests {
+    my @res;
+    for my $len (10,100,1000) {
+        my $result1= fresh_perl(sprintf(<<'EOF_CODE', $len),
+        use threads;
+        use re 'debug';
+
+        sub start_thread {
+            warn "===\n";
+            split /[.;]+[\'\"]+/, $_[0];
+            warn "===\n";
+        }
+
+        my $buffer = '.' x %d;
+
+        start_thread $buffer;
+EOF_CODE
+        {});
+        my $result2= fresh_perl(sprintf(<<'EOF_CODE', $len),
+        use threads;
+        use re 'debug';
+
+        sub start_thread {
+            warn "\n===\n";
+            split /[.;]+[\'\"]+/, $_[0];
+            warn "\n===\n";
+        }
+
+        my $buffer = '.' x %d;
+        my $thr = threads->create('start_thread', $buffer);
+        $thr->join();
+EOF_CODE
+        {});
+        for ($result1, $result2) {
+            (undef,$_,undef)= split /\n===\n/, $_;
+        }
+        my @l1= split /\n/, $result1;
+        my @l2= split /\n/, $result2;
+        push @res, 0+@l2;
+        is(0+@l2,0+@l1, sprintf
+            "Threaded and unthreaded stclass behavior matches (n=%d)",
+            $len);
+    }
+    my $n10= $res[0]/10;
+    my $n100= $res[1]/100;
+    my $n1000= $res[2]/1000;
+    ok(abs($n10-$n100)<1,"Behavior appears to be sub quadratic ($n10, $n100)");
+    ok(abs($n100-$n1000)<0.1,"Behavior is linear and not quadratic ($n100, $n1000)");
+    ok(abs(3-$n1000)<0.1,"Behavior is linear as expected");
+}
+#