add Internals::gc()

free empty SV arenas and empty body roots.
Note that is usually doesn't reclaim system memory, very often
it even increases memory usage.

opslab arenas should be deleted by cv_undef() already.

See GH #336

MANIFEST

@@ -6538,6 +6538,7 @@ t/bigmem/vec.t			Check vec() handles large offsets
 t/charset_tools.pl		To aid in portable testing across platforms with different character sets
 t/cmd/elsif.t			See if else-if works
 t/cmd/for.t			See if for loops work
+t/cmd/gc.t			See if Internals::gc() works
 t/cmd/mod.t			See if statement modifiers work
 t/cmd/subval.t			See if subroutine values work
 t/cmd/switch.t			See if switch optimizations work

embed.fnc

@@ -1878,6 +1878,13 @@ poMX	|void	|sv_free2	|NN SV *const sv|const U32 refcnt
 : Used only in perl.c
 pd	|void	|sv_free_arenas
 #if defined(USE_CPERL)
+#ifdef PERL_CORE
+pd	|void	|opslab_gc      |NN OPSLAB *slab
+#endif
+Apd	|void	|op_gc_arenas
+Apd	|void	|sv_gc_arenas
+#endif
+#if defined(USE_CPERL)
 : a perl5 limitation
 Apd	|char*	|sv_gets	|NN SV *const sv|NN PerlIO *const fp|STRLEN append
 #else

embed.h

@@ -569,6 +569,7 @@
 #define op_convert_list(a,b,c)	Perl_op_convert_list(aTHX_ a,b,c)
 #define op_dump(a)		Perl_op_dump(aTHX_ a)
 #define op_free(a)		Perl_op_free(aTHX_ a)
+#define op_gc_arenas()		Perl_op_gc_arenas(aTHX)
 #define op_linklist(a)		Perl_op_linklist(aTHX_ a)
 #define op_null(a)		Perl_op_null(aTHX_ a)
 #define op_parent		Perl_op_parent
@@ -763,6 +764,7 @@
 #define sv_eq_flags(a,b,c)	Perl_sv_eq_flags(aTHX_ a,b,c)
 #define sv_force_normal_flags(a,b)	Perl_sv_force_normal_flags(aTHX_ a,b)
 #define sv_free(a)		Perl_sv_free(aTHX_ a)
+#define sv_gc_arenas()		Perl_sv_gc_arenas(aTHX)
 #define sv_get_backrefs		Perl_sv_get_backrefs
 #define sv_grow(a,b)		Perl_sv_grow(aTHX_ a,b)
 #define sv_inc(a)		Perl_sv_inc(aTHX_ a)
@@ -1858,6 +1860,7 @@
 #define opslab_force_free(a)	Perl_opslab_force_free(aTHX_ a)
 #define opslab_free(a)		Perl_opslab_free(aTHX_ a)
 #define opslab_free_nopad(a)	Perl_opslab_free_nopad(aTHX_ a)
+#define opslab_gc(a)		Perl_opslab_gc(aTHX_ a)
 #define parser_free_nexttoke_ops(a,b)	Perl_parser_free_nexttoke_ops(aTHX_ a,b)
 #define should_warn_nl		S_should_warn_nl
 #    if defined(PERL_DEBUG_READONLY_OPS)

lib/Internals.pod

@@ -65,11 +65,22 @@ Clear any placeholders from a locked hash. Should not be used directly.
 You should use the wrapper functions provided by Hash::Util instead.
 As of 5.25 also available as C< Hash::Util::_clear_placeholders(%hash) >
 
+=item gc()
+
+Free any empty SV arena and empty body roots, and free all block
+temporaries, thus should be only called at the end of blocks. Note
+that this usually doesn't reclaim much system memory, and in certain
+configurations it might even cause crashes.
+With C<PERL_POISON> it is not needed.
+
+Experimental, unstable and might go away soon.
+
 =back
 
 =head1 AUTHOR
 
 Perl core development team.
+cperl development team.
 
 =head1 SEE ALSO
 

op.c

@@ -804,6 +804,61 @@ Perl_opslab_force_free(pTHX_ OPSLAB *slab)
     opslab_free(slab);
 }
 
+/*
+=for apidoc Apd|void	|op_gc_arenas
+
+Deallocate memory used by freed obslab arenas. Note that if one slab
+contains at least one live OP the whole arena stays live.
+
+=cut
+*/
+void
+Perl_op_gc_arenas(pTHX)
+{
+    /* TODO walk all CVs to look for empty arenas */
+    if (!PL_compcv
+        || CvROOT(PL_compcv)
+        || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
+    {
+        return; /* not slabbed */
+    } else {
+        opslab_gc((OPSLAB *)CvSTART(PL_compcv));
+    }
+}
+
+/*
+=for apidoc pd|void	|opslab_gc
+
+Deallocate memory used by a freed obslab arena. Note that if the slab
+contains at least one live OP the whole arena stays live.
+
+=cut
+*/
+void
+Perl_opslab_gc(pTHX_ OPSLAB *slab)
+{
+    OPSLAB *slab2 = slab;
+    PERL_ARGS_ASSERT_OPSLAB_GC;
+    DEBUG_S_warn((aTHX_ "gc slab %p", (void*)slab));
+
+    do {
+        OPSLOT *slot;
+	for (slot = slab2->opslab_first;
+	     slot->opslot_next;
+	     slot = slot->opslot_next)
+        {
+	    if (slot->opslot_op.op_type != OP_FREED) {
+		assert(slot->opslot_op.op_slabbed);
+                goto next_slab;
+	    }
+	}
+        if (slab->opslab_refcnt == 1)
+            opslab_free(slab);
+    next_slab:
+        ;
+    } while ((slab2 = slab2->opslab_next));
+}
+
 #ifdef PERL_DEBUG_READONLY_OPS
 OP *
 Perl_op_refcnt_inc(pTHX_ OP *o)

pod/perlcdelta.pod

@@ -212,6 +212,12 @@ If so, destruct all ops, leading to no valgrind leaks, even with
 --leak-check=full.
 cperl-only L<[cperl #400]|https://github.com/perl11/cperl/issues/400>
 
+=head2 Added experimental Internals::gc()
+
+With the ability to free empty SV arenas. It's currently unstable, and
+might be replaced by proper arena memory handling later.  See
+L<Internals/gc> and L<perlapi/sv_gc_arenas>.
+
 =head1 Security
 
 =head2 Variable length lookbehind in regular expression pattern matching

proto.h

@@ -4197,6 +4197,9 @@ PERL_CALLCONV void	Perl_op_dump(pTHX_ const OP *o)
 PERL_CALLCONV void	Perl_op_free(pTHX_ OP* arg)
 			__attribute__global__;
 
+PERL_CALLCONV void	Perl_op_gc_arenas(pTHX)
+			__attribute__global__;
+
 PERL_CALLCONV OP*	Perl_op_linklist(pTHX_ OP *o)
 			__attribute__global__
 			__attribute__nonnull__(pTHX_1);
@@ -5683,6 +5686,9 @@ PERL_CALLCONV void	Perl_sv_free2(pTHX_ SV *const sv, const U32 refcnt)
 	assert(sv)
 
 PERL_CALLCONV void	Perl_sv_free_arenas(pTHX);
+PERL_CALLCONV void	Perl_sv_gc_arenas(pTHX)
+			__attribute__global__;
+
 PERL_CALLCONV SV*	Perl_sv_get_backrefs(SV *const sv)
 			__attribute__global__
 			__attribute__nonnull__(1);
@@ -7750,6 +7756,11 @@ PERL_CALLCONV void	Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 #define PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD	\
 	assert(slab)
 
+PERL_CALLCONV void	Perl_opslab_gc(pTHX_ OPSLAB *slab)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPSLAB_GC	\
+	assert(slab)
+
 PERL_CALLCONV void	Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);

regcomp.c

@@ -20760,7 +20760,8 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
     if (r->mother_re) {
         ReREFCNT_dec(r->mother_re);
     } else {
-        CALLREGFREE_PVT(rx); /* free the private data */
+        if (LIKELY(r->engine))   /* gc() might have deleted this body already */
+            CALLREGFREE_PVT(rx); /* free the private data */
         SvREFCNT_dec(RXp_PAREN_NAMES(r));
     }
     if (r->substrs) {