add PMf_CODELIST_PRIVATE flag

This indicates that the op_code_list field in a PMOP is "private";
that is, it points to a list of DO blocks that we don't own, and
shouldn't free, and whose pad may not match ours.

This will allow us to use the op_code_list field in the runtime case of
literal code, e.g. /$runtime(?{...})/ and qr/$runtime(?{...})/. Here, at
compile-time, we need to make the pre-compiled (?{..}) blocks available to
pp_regcomp, but the list containing those blocks is also the list that is
executed in the lead-up to executing pp_regcomp (while skipping the DO
blocks), so the code is already embedded, and doesn't need freeing.
Furthermore, in the qr// case, the code blocks are actually within a
different sub (an anon one) than the PMOP, so the pads won't match.

3 files changed, 21 insertions, 4 deletions

diff --git a/dump.c b/dump.c
index e6c4ae0e1c..99e5df9ab1 100644
--- a/dump.c
+++ b/dump.c
@@ -614,8 +614,13 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 	op_dump(pm->op_pmreplrootu.op_pmreplroot);
     }
     if (pm->op_code_list) {
-	Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
-	do_op_dump(level, file, pm->op_code_list);
+	if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
+	    Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
+	    do_op_dump(level, file, pm->op_code_list);
+	}
+	else
+	    Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
+				    PTR2UV(pm->op_code_list));
     }
     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
 	SV * const tmpsv = pm_description(pm);
@@ -635,6 +640,7 @@ const struct flag_to_name pmflags_flags_names[] = {
     {PMf_EVAL, ",EVAL"},
     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
     {PMf_HAS_CV, ",HAS_CV"},
+    {PMf_CODELIST_PRIVATE, "PMf_CODELIST_PRIVATE"}
 };
 
 static SV *
diff --git a/op.c b/op.c
index 005a370a53..073b5f7b47 100644
--- a/op.c
+++ b/op.c
@@ -677,7 +677,8 @@ Perl_op_clear(pTHX_ OP *o)
     case OP_MATCH:
     case OP_QR:
 clear_pmop:
-	op_free(cPMOPo->op_code_list);
+	if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
+	    op_free(cPMOPo->op_code_list);
 	cPMOPo->op_code_list = NULL;
 	forget_pmop(cPMOPo, 1);
 	cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
@@ -4405,6 +4406,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
 	if (reglist)
 	    op_null(expr);
 
+	if (has_code) {
+	    pm->op_code_list = expr;
+	    /* don't free op_code_list; its ops are embedded elsewhere too */
+	    pm->op_pmflags |= PMf_CODELIST_PRIVATE;
+	}
+
 	if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
 	    expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
 			    ? OP_REGCRESET
diff --git a/op.h b/op.h
index 8f5d837e96..6e924a3317 100644
--- a/op.h
+++ b/op.h
@@ -434,7 +434,11 @@ struct pmop {
 /* the pattern has a CV attached (currently only under qr/...(?{}).../) */
 #define PMf_HAS_CV	(1<<(PMf_BASE_SHIFT+10))
 
-#if PMf_BASE_SHIFT+10 > 31
+/* op_code_list is private; don't free it etc. It may well point to
+ * code within another sub, with different pad etc */
+#define PMf_CODELIST_PRIVATE	(1<<(PMf_BASE_SHIFT+11))
+
+#if PMf_BASE_SHIFT+11 > 31
 #   error Too many PMf_ bits used.  See above and regnodes.h for any spare in middle
 #endif