scope.c - add mortal_destructor_sv() and mortal_svfunc_x()

demerphq · demerphq · commit 9961aaca30f4 · 2023-03-17T15:53:33.000+01:00
The function SAVEDESTRUCTOR_X() (save_destructor_x) can be used to execute a C function at the end of the current psuedo-block. Prior to this patch there was no "mortal" equivalent that would execute at the end of the current statement. We offer a collection of functions which are intended to free SV's at either point in time, but only support callbacks at the end of the current pseudo-block. This patch adds two such functions, "mortal_destructor_sv" which can be used to trigger a perl code reference to execute at the end of the current statement, and "mortal_svfunc_x" which can be used to trigger an SVFUNC_t C function at the end of the current statement. Both functions differ from save_destructor_x() in that instead of supporting a void pointer argument they both require their argument to be some sort of SV pointer. The Perl callback function triggered by "mortal_destructor_sv" may be provided no arguments, a single argument or a list of arguments, depending on the type of argument provided to mortal_destructor_sv(): when the argument is a raw AV (with no SV ref wrapping it), then the contents of the AV are passed in as a list of arguments. When the argument is anything else but NULL, the argument is provided as a single argument, and when it is NULL the perl function is called with no arguments. Both functions are implemented on top of a mortal SV (unseen by the user) which has PERL_MAGIC_destruct magic associated with it, which triggers the destructor behavior when the SV is freed. Both functions are provided with macros to match the normal SAVExx() API, with MORTALDESTRUCTOR_SV() wrapping mortal_destructor_sv() and MORTALSVFUNC_X() wrapping mortal_svfunc_x(). The heart of this logic cribbed from Leon Timmermans' Variable-OnDestruct. See the code at: https://metacpan.org/dist/Variable-OnDestruct/source/lib/Variable/OnDestruct.xs#L6-17 I am very grateful to him for his help on this. Any errors or omissions in this code are my fault, not his.
diff --git a/MANIFEST b/MANIFEST
@@ -4879,6 +4879,7 @@ ext/XS-APItest/t/lvalue.t			Test XS lvalue functions
 ext/XS-APItest/t/magic.t			test attaching, finding, and removing magic
 ext/XS-APItest/t/magic_chain.t			test low-level MAGIC chain handling
 ext/XS-APItest/t/Markers.pm			Helper for ./blockhooks.t
+ext/XS-APItest/t/mortal_destructor.t		Test mortal_destructor api.
 ext/XS-APItest/t/mro.t				Test mro plugin api
 ext/XS-APItest/t/multicall.t			XS::APItest: test MULTICALL macros
 ext/XS-APItest/t/my_cxt.t			XS::APItest: test MY_CXT interface
diff --git a/embed.fnc b/embed.fnc
@@ -1808,6 +1808,9 @@ p	|int	|magic_existspack					\
 p	|int	|magic_freearylen_p					\
 				|NN SV *sv				\
 				|NN MAGIC *mg
+dp	|int	|magic_freedestruct					\
+				|NN SV *sv				\
+				|NN MAGIC *mg
 p	|int	|magic_freemglob|NN SV *sv				\
 				|NN MAGIC *mg
 p	|int	|magic_freeovrld|NN SV *sv				\
@@ -1970,7 +1973,12 @@ Cop	|void * |more_bodies	|const svtype sv_type			\
 				|const size_t arena_size
 Cp	|const char *|moreswitches					\
 				|NN const char *s
+Adp	|void	|mortal_destructor_sv					\
+				|NN SV *coderef 			\
+				|NULLOK SV *args
 CRTXip	|char * |mortal_getenv	|NN const char *str
+Cdp	|void	|mortal_svfunc_x|SVFUNC_t f				\
+				|NULLOK SV *p
 Adop	|const struct mro_alg *|mro_get_from_name			\
 				|NN SV *name
 Adp	|AV *	|mro_get_linear_isa					\
diff --git a/embed.h b/embed.h
@@ -359,7 +359,9 @@
 # define mg_size(a)                             Perl_mg_size(aTHX_ a)
 # define mini_mktime                            Perl_mini_mktime
 # define moreswitches(a)                        Perl_moreswitches(aTHX_ a)
+# define mortal_destructor_sv(a,b)              Perl_mortal_destructor_sv(aTHX_ a,b)
 # define mortal_getenv                          Perl_mortal_getenv
+# define mortal_svfunc_x(a,b)                   Perl_mortal_svfunc_x(aTHX_ a,b)
 # define mro_get_linear_isa(a)                  Perl_mro_get_linear_isa(aTHX_ a)
 # define mro_method_changed_in(a)               Perl_mro_method_changed_in(aTHX_ a)
 # define msbit_pos32                            Perl_msbit_pos32
@@ -961,6 +963,7 @@
 #   define magic_copycallchecker(a,b,c,d,e)     Perl_magic_copycallchecker(aTHX_ a,b,c,d,e)
 #   define magic_existspack(a,b)                Perl_magic_existspack(aTHX_ a,b)
 #   define magic_freearylen_p(a,b)              Perl_magic_freearylen_p(aTHX_ a,b)
+#   define magic_freedestruct(a,b)              Perl_magic_freedestruct(aTHX_ a,b)
 #   define magic_freemglob(a,b)                 Perl_magic_freemglob(aTHX_ a,b)
 #   define magic_freeovrld(a,b)                 Perl_magic_freeovrld(aTHX_ a,b)
 #   define magic_freeutf8(a,b)                  Perl_magic_freeutf8(aTHX_ a,b)
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.31';
+our $VERSION = '1.32';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
@@ -1515,6 +1515,11 @@ test_bool_internals_func(SV *true_sv, SV *false_sv, const char *msg) {
 }
 #include "const-c.inc"
 
+void
+destruct_test(pTHX_ void *p) {
+    warn("In destruct_test: %" SVf "\n", (SV*)p);
+}
+
 MODULE = XS::APItest            PACKAGE = XS::APItest
 
 INCLUDE: const-xs.inc
@@ -4908,6 +4913,24 @@ sv_refcnt(SV *sv)
     OUTPUT:
         RETVAL
 
+void
+test_mortal_destructor_sv(SV *coderef, SV *args)
+    CODE:
+        MORTALDESTRUCTOR_SV(coderef,args);
+
+void
+test_mortal_destructor_av(SV *coderef, AV *args)
+    CODE:
+        /* passing in an AV cast to SV is different from a SV ref to an AV */
+        MORTALDESTRUCTOR_SV(coderef, (SV *)args);
+
+void
+test_mortal_svfunc_x(SV *args)
+    CODE:
+        MORTALSVFUNC_X(&destruct_test,args);
+
+
+
 
 MODULE = XS::APItest            PACKAGE = XS::APItest
 
diff --git a/ext/XS-APItest/t/mortal_destructor.t b/ext/XS-APItest/t/mortal_destructor.t
@@ -0,0 +1,30 @@
+use XS::APItest;
+use Test::More tests => 1;
+use Data::Dumper;
+my $warnings = "";
+$SIG{__WARN__} = sub { $warnings .= $_[0]; };
+
+warn "Before test_mortal_destructor_sv\n";
+test_mortal_destructor_sv(sub { warn "in perl callback: ", $_[0],"\n" }, {});
+warn "After test_mortal_destructor_sv\n";
+
+warn "Before test_mortal_destructor_av\n";
+test_mortal_destructor_av(sub { warn "in perl callback: @_\n" }, ["a","b","c"]);
+warn "After test_mortal_destructor_av\n";
+
+warn "Before test_mortal_destructor_x\n";
+test_mortal_svfunc_x("this is an argument");
+warn "After test_mortal_destructor_x\n";
+
+$warnings=~s/0x[A-Fa-f0-9]+/0xDEADBEEF/g;
+is($warnings, <<'EXPECT');
+Before test_mortal_destructor_sv
+in perl callback: HASH(0xDEADBEEF)
+After test_mortal_destructor_sv
+Before test_mortal_destructor_av
+in perl callback: a b c
+After test_mortal_destructor_av
+Before test_mortal_destructor_x
+In destruct_test: this is an argument
+After test_mortal_destructor_x
+EXPECT
diff --git a/mg_names.inc b/mg_names.inc
@@ -44,6 +44,7 @@
 	{ PERL_MAGIC_vstring,        "vstring(V)" },
 	{ PERL_MAGIC_vec,            "vec(v)" },
 	{ PERL_MAGIC_utf8,           "utf8(w)" },
+	{ PERL_MAGIC_destruct,       "destruct(X)" },
 	{ PERL_MAGIC_substr,         "substr(x)" },
 	{ PERL_MAGIC_nonelem,        "nonelem(Y)" },
 	{ PERL_MAGIC_defelem,        "defelem(y)" },
diff --git a/mg_raw.h b/mg_raw.h
@@ -76,6 +76,8 @@
       "/* vec 'v' vec() lvalue */" },
     { 'w', "want_vtbl_utf8 | PERL_MAGIC_VALUE_MAGIC",
       "/* utf8 'w' Cached UTF-8 information */" },
+    { 'X', "want_vtbl_destruct | PERL_MAGIC_VALUE_MAGIC",
+      "/* destruct 'X' destruct callback */" },
     { 'x', "want_vtbl_substr | PERL_MAGIC_VALUE_MAGIC",
       "/* substr 'x' substr() lvalue */" },
     { 'Y', "want_vtbl_nonelem | PERL_MAGIC_VALUE_MAGIC",
diff --git a/mg_vtable.h b/mg_vtable.h
@@ -51,6 +51,7 @@
 #define PERL_MAGIC_vstring        'V' /* SV was vstring literal */
 #define PERL_MAGIC_vec            'v' /* vec() lvalue */
 #define PERL_MAGIC_utf8           'w' /* Cached UTF-8 information */
+#define PERL_MAGIC_destruct       'X' /* destruct callback */
 #define PERL_MAGIC_substr         'x' /* substr() lvalue */
 #define PERL_MAGIC_nonelem        'Y' /* Array element that does not exist */
 #define PERL_MAGIC_defelem        'y' /* Shadow "foreach" iterator variable /
@@ -69,6 +70,7 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_dbline,
     want_vtbl_debugvar,
     want_vtbl_defelem,
+    want_vtbl_destruct,
     want_vtbl_env,
     want_vtbl_envelem,
     want_vtbl_hints,
@@ -107,6 +109,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
     "dbline",
     "debugvar",
     "defelem",
+    "destruct",
     "env",
     "envelem",
     "hints",
@@ -168,6 +171,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, Perl_magic_setdbline, 0, 0, 0, 0, 0, 0 },
   { Perl_magic_getdebugvar, Perl_magic_setdebugvar, 0, 0, 0, 0, 0, 0 },
   { Perl_magic_getdefelem, Perl_magic_setdefelem, 0, 0, 0, 0, 0, 0 },
+  { 0, 0, 0, 0, Perl_magic_freedestruct, 0, 0, 0 },
   { 0, Perl_magic_set_all_env, 0, Perl_magic_clear_all_env, 0, 0, 0, 0 },
   { 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 },
   { 0, 0, 0, Perl_magic_clearhints, 0, 0, 0, 0 },
@@ -214,6 +218,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline]
 #define PL_vtbl_debugvar PL_magic_vtables[want_vtbl_debugvar]
 #define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem]
+#define PL_vtbl_destruct PL_magic_vtables[want_vtbl_destruct]
 #define PL_vtbl_env PL_magic_vtables[want_vtbl_env]
 #define PL_vtbl_envelem PL_magic_vtables[want_vtbl_envelem]
 #define PL_vtbl_fm PL_magic_vtables[want_vtbl_fm]
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
@@ -832,6 +832,14 @@ a C<given> block.  You probably meant to use C<next> or C<last>.
 
 (F) You called C<break>, but you're not inside a C<given> block.
 
+=item Can't call destructor for 0x%p in global destruction
+
+(S) This should not happen. Internals code has set up a destructor
+using C<mortal_destructor_sv> or C<mortal_destructor_x> which is firing
+during global destruction. Please attempt to reduce the code that triggers
+this warning down to a small an example as possible and then report the
+problem to L<https://github.com/Perl/perl5/issues/new/choose>
+
 =item Can't call method "%s" on an undefined value
 
 (F) You used the syntax of a method call, but the slot filled by the
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
@@ -1510,17 +1510,17 @@ will be lost.
                                              tables
  <  PERL_MAGIC_backref        vtbl_backref   For weak ref data
  @  PERL_MAGIC_arylen_p       (none)         To move arylen out of XPVAV
- B  PERL_MAGIC_bm             vtbl_regexp    Boyer-Moore 
+ B  PERL_MAGIC_bm             vtbl_regexp    Boyer-Moore
                                              (fast string search)
- c  PERL_MAGIC_overload_table vtbl_ovrld     Holds overload table 
+ c  PERL_MAGIC_overload_table vtbl_ovrld     Holds overload table
                                              (AMT) on stash
- D  PERL_MAGIC_regdata        vtbl_regdata   Regex match position data 
+ D  PERL_MAGIC_regdata        vtbl_regdata   Regex match position data
                                              (@+ and @- vars)
  d  PERL_MAGIC_regdatum       vtbl_regdatum  Regex match position data
                                              element
  E  PERL_MAGIC_env            vtbl_env       %ENV hash
  e  PERL_MAGIC_envelem        vtbl_envelem   %ENV hash element
- f  PERL_MAGIC_fm             vtbl_regexp    Formline 
+ f  PERL_MAGIC_fm             vtbl_regexp    Formline
                                              ('compiled' format)
  g  PERL_MAGIC_regex_global   vtbl_mglob     m//g target
  H  PERL_MAGIC_hints          vtbl_hints     %^H hash
@@ -1548,6 +1548,7 @@ will be lost.
  V  PERL_MAGIC_vstring        (none)         SV was vstring literal
  v  PERL_MAGIC_vec            vtbl_vec       vec() lvalue
  w  PERL_MAGIC_utf8           vtbl_utf8      Cached UTF-8 information
+ X  PERL_MAGIC_destruct       vtbl_destruct  destruct callback
  x  PERL_MAGIC_substr         vtbl_substr    substr() lvalue
  Y  PERL_MAGIC_nonelem        vtbl_nonelem   Array element that does not
                                              exist
@@ -1575,6 +1576,7 @@ will be lost.
 =for apidoc_item ||PERL_MAGIC_dbline
 =for apidoc_item ||PERL_MAGIC_debugvar
 =for apidoc_item ||PERL_MAGIC_defelem
+=for apidoc_item ||PERL_MAGIC_destruct
 =for apidoc_item ||PERL_MAGIC_env
 =for apidoc_item ||PERL_MAGIC_envelem
 =for apidoc_item ||PERL_MAGIC_ext
@@ -1978,19 +1980,53 @@ this:
 =item C<SAVEDESTRUCTOR(DESTRUCTORFUNC_NOCONTEXT_t f, void *p)>
 
 At the end of I<pseudo-block> the function C<f> is called with the
-only argument C<p>.
+only argument C<p> which may be NULL.
 
 =for apidoc Ayh||DESTRUCTORFUNC_NOCONTEXT_t
 =for apidoc Amh||SAVEDESTRUCTOR|DESTRUCTORFUNC_NOCONTEXT_t f|void *p
 
 =item C<SAVEDESTRUCTOR_X(DESTRUCTORFUNC_t f, void *p)>
 
 At the end of I<pseudo-block> the function C<f> is called with the
-implicit context argument (if any), and C<p>.
+implicit context argument (if any), and C<p> which may be NULL.
+
+Note the I<end of the current pseudo-block> may occur much later than
+the the I<end of the current statement>. You may wish to look at the
+C<MORTALDESTRUCTOR_X()> macro instead.
 
 =for apidoc Ayh||DESTRUCTORFUNC_t
 =for apidoc Amh||SAVEDESTRUCTOR_X|DESTRUCTORFUNC_t f|void *p
 
+=item C<MORTALSVFUNC_X(SVFUNC_t f, SV *sv)>
+
+At the end of I<the current statement> the function C<f> is called with
+the implicit context argument (if any), and C<sv> which may be NULL.
+
+Be aware that the parameter argument to the destructor function differs
+from the related C<SAVEDESTRUCTOR_X()> in that it MUST be either NULL or
+an C<SV*>.
+
+Note the I<end of the current statement> may occur much before the
+the I<end of the current pseudo-block>.  You may wish to look at the
+C<SAVEDESTRUCTOR_X()> macro instead.
+
+=for apidoc Amh||MORTALDESTRUCTOR_X|DESTRUCTORFUNC_t f|SV *sv
+
+=item C<MORTALDESTRUCTOR_SV(SV *coderef, SV *args)>
+
+At the end of I<the current statement> the Perl function contained in
+C<coderef> is called with the arguments provided (if any) in C<args>.
+See the documentation for C<mortal_destructor_sv()> for details on
+the C<args> parameter is handled.
+
+Note the I<end of the current statement> may occur much before the
+the I<end of the current pseudo-block>.  If you wish to call a perl
+function at the end of the current pseudo block you should use the
+C<SAVEDESTRUCTOR_X()> API instead, which will require you create a
+C wrapper to call the Perl function.
+
+=for apidoc Amh||MORTALDESTRUCTOR_SV|SV *coderef|SV *args
+
 =item C<SAVESTACK_POS()>
 
 The current offset on the Perl internal stack (cf. C<SP>) is restored
diff --git a/proto.h b/proto.h
diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
@@ -212,6 +212,12 @@ BEGIN
                    vtable => 'debugvar' },
      lvref => { char => '\\', vtable => 'lvref',
                   desc => "Lvalue reference constructor" },
+     destruct => {
+        char        => "X",
+        vtable      => 'destruct',
+        desc        => "destruct callback",
+        value_magic => 1,
+     },
 );
 
 
@@ -288,6 +294,7 @@ BEGIN
      'checkcall' => {copy => 'copycallchecker'},
      'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
      'lvref' => {set => 'setlvref'},
+     'destruct' => {free => 'freedestruct'},
 );
 
 
@@ -428,6 +435,7 @@ BEGIN
                     ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g
                 }
             }
+            s/\s+\z// for $desc, @cont;
             printf $format, $type, $vtbl, $desc;
             printf $format, '', '', $_ foreach @cont;
         }
diff --git a/scope.c b/scope.c
diff --git a/scope.h b/scope.h
