This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add PMf_CODELIST_PRIVATE flag
authorDavid Mitchell <davem@iabyn.com>
Tue, 1 Nov 2011 16:50:16 +0000 (16:50 +0000)
committerDavid Mitchell <davem@iabyn.com>
Wed, 13 Jun 2012 12:25:51 +0000 (13:25 +0100)
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.

dump.c
op.c
op.h

diff --git a/dump.c b/dump.c
index deebf23..bda5172 100644 (file)
--- 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 cd5b0a7..c735d96 100644 (file)
--- a/op.c
+++ b/op.c
@@ -743,7 +743,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;
@@ -4460,6 +4461,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 4f5710b..06437d4 100644 (file)
--- a/op.h
+++ b/op.h
@@ -437,7 +437,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