From 87ec7cd2c6b3f01d5c10701c18d9dee90a3db6aa Mon Sep 17 00:00:00 2001 From: Reini Urban Date: Sun, 22 Oct 2017 14:17:07 +0200 Subject: [PATCH] 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 | 1 + embed.fnc | 5 ++ embed.h | 3 + lib/Internals.pod | 11 ++++ op.c | 55 ++++++++++++++++ pod/perlcdelta.pod | 6 ++ proto.h | 11 ++++ regcomp.c | 3 +- sv.c | 161 ++++++++++++++++++++++++++++++++++++++++++--- t/cmd/gc.t | 81 +++++++++++++++++++++++ universal.c | 11 ++++ 11 files changed, 339 insertions(+), 9 deletions(-) create mode 100644 t/cmd/gc.t diff --git a/MANIFEST b/MANIFEST index 051c49db9ef..e46f059a9d7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6359,6 +6359,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 diff --git a/embed.fnc b/embed.fnc index cf4d0bc629c..4655e084321 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1720,6 +1720,11 @@ Apd |void |sv_free |NULLOK SV *const sv poMX |void |sv_free2 |NN SV *const sv|const U32 refcnt : Used only in perl.c pd |void |sv_free_arenas +#ifdef PERL_CORE +pd |void |opslab_gc |NN OPSLAB *slab +#endif +Apd |void |op_gc_arenas +Apd |void |sv_gc_arenas Apd |char* |sv_gets |NN SV *const sv|NN PerlIO *const fp|STRLEN append Apd |char* |sv_grow |NN SV *const sv|STRLEN newlen Apd |void |sv_inc |NULLOK SV *const sv diff --git a/embed.h b/embed.h index 2ea42db10f6..da011062da1 100644 --- a/embed.h +++ b/embed.h @@ -603,6 +603,7 @@ #define op_dump(a) Perl_op_dump(aTHX_ a) #define op_dump_cv(a,b) Perl_op_dump_cv(aTHX_ a,b) #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_lvalue_flags(a,b,c) Perl_op_lvalue_flags(aTHX_ a,b,c) #define op_null(a) Perl_op_null(aTHX_ a) @@ -808,6 +809,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_gets(a,b,c) Perl_sv_gets(aTHX_ a,b,c) #define sv_grow(a,b) Perl_sv_grow(aTHX_ a,b) @@ -1837,6 +1839,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 #define strip_spaces(a,b) S_strip_spaces(aTHX_ a,b) diff --git a/lib/Internals.pod b/lib/Internals.pod index 630f585700f..34484af508c 100644 --- a/lib/Internals.pod +++ b/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 providewd 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 it is not needed. + +Experimental, unstable and might go away soon. + =back =head1 AUTHOR Perl core development team. +cperl development team. =head1 SEE ALSO diff --git a/op.c b/op.c index e4637651593..c5c53fa9c26 100644 --- a/op.c +++ b/op.c @@ -779,6 +779,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) diff --git a/pod/perlcdelta.pod b/pod/perlcdelta.pod index c203d2195ea..dcdb89569d9 100644 --- a/pod/perlcdelta.pod +++ b/pod/perlcdelta.pod @@ -68,6 +68,12 @@ L section. [ List each security issue as a =head2 entry ] +=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 and L. + =head1 Incompatible Changes XXX For a release on a stable branch, this section aspires to be: diff --git a/proto.h b/proto.h index 2d03ec80285..0ced84da7b5 100644 --- a/proto.h +++ b/proto.h @@ -4484,6 +4484,9 @@ PERL_CALLCONV void Perl_op_dump_cv(pTHX_ const OP *o, const CV *cv) 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); @@ -6030,6 +6033,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); @@ -8147,6 +8153,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); diff --git a/regcomp.c b/regcomp.c index d50b9c50959..5210cf6646f 100644 --- a/regcomp.c +++ b/regcomp.c @@ -20260,7 +20260,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) { diff --git a/sv.c b/sv.c index 4bf27c7886c..09ef0fe8e8d 100644 --- a/sv.c +++ b/sv.c @@ -1148,7 +1148,7 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, assert(arena_size); - /* may need new arena-set to hold new arena */ + /* may need new arenaset to hold new arena */ if (!aroot || aroot->curr >= aroot->set_size) { struct arena_set *newroot; Newxz(newroot, 1, struct arena_set); @@ -1159,7 +1159,7 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset 0x%p\n", (void*)aroot)); } - /* ok, now have arena-set with at least 1 empty/available arena-desc */ + /* ok, now have arenaset with at least 1 empty/available arena-desc */ curr = aroot->curr++; adesc = &(aroot->set[curr]); assert(!adesc->arena); @@ -1196,6 +1196,9 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, while (1) { /* Where the next body would start: */ char * const next = start + body_size; +#if defined(DEBUGGING) + Zero(start, body_size, char); +#endif if (next >= end) { /* This is the last body: */ assert(next == end); @@ -1209,7 +1212,7 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, } } -/* grab a new thing from the free list, allocating more if necessary. +/* Grab a new body from the free list, allocating more if necessary. The inline version is used for speed in hot routines, and the function using it serves the rest (unless PURIFY). */ @@ -1218,8 +1221,8 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, void ** const r3wt = &PL_body_roots[sv_type]; \ xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ - bodies_by_type[sv_type].body_size,\ - bodies_by_type[sv_type].arena_size)); \ + bodies_by_type[sv_type].body_size, \ + bodies_by_type[sv_type].arena_size)); \ *(r3wt) = *(void**)(xpv); \ } STMT_END @@ -1666,6 +1669,147 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) return s; } +/* +=for apidoc sv_gc_arenas + +Free's all temporary data, as if it was at end of scope. Scans the +whole heap, i.e. all SV head and body arenas, and deallocate the +memory used by freed arenas. Note that if one arena contains at least +one live SV the whole arena stays live. + +=cut + +*/ +void +Perl_sv_gc_arenas(pTHX) +{ + SV *sva, *svanext, *prev = NULL; +#ifdef DEBUGGING + int yes = 0, no = 0; + int i = 0; +#endif + + FREETMPS; + /* Free empty head arenas, skipping fake ones. */ + for (sva = PL_sv_arenaroot; sva; sva = svanext) { + bool filled = FALSE; +#ifdef DEBUGGING + i++; +#endif + svanext = MUTABLE_SV(SvANY(sva)); + if (!SvFAKE(sva)) { + SV *sv; + SV* svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (!SvIS_FREED(sv)) { + if (SvTEMP(sv)) { + sv_free(sv); + } else { + filled = TRUE; + DEBUG_mv(PerlIO_printf(Perl_debug_log, + "%-7s arena [%d] 0x%p\n", "filled", i, (void*)sva)); + break; + } + } + } + if (!filled) { + if (sva == PL_sv_arenaroot) + PL_sv_arenaroot = svanext; + else if (prev) + prev->sv_any = svanext; +#ifdef DEBUGGING + yes++; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "%7s arena [%d] 0x%p\n", "gc free", i, (void*)sva)); + /*PoisonFree(sva, svend - sva, SV);*/ +#endif + if (PL_sv_root < svend && PL_sv_root > sva) + PL_sv_root = NULL; + Safefree(sva); + } + else { + prev = sva; +#ifdef DEBUGGING + no++; +#endif + } + } + else { + prev = sva; +#ifdef DEBUGGING + no++; + DEBUG_mv(PerlIO_printf(Perl_debug_log, + "%-7s arena [%d] 0x%p\n", "fake", i, (void*)sva)); +#endif + } + } + DEBUG_m(PerlIO_printf(Perl_debug_log, "arena gc: %d/%d\n", yes, yes+no)); + + /* Scan the PL_body_roots[type] free lists if it makes a full arenaset + from PL_body_arenas. See Perl_more_bodies(). + SVt_NULL is used for HE*. */ + if (PL_body_arenas) { + struct arena_set *aroot = (struct arena_set *) PL_body_arenas; + unsigned int curr = aroot->curr; +#ifdef DEBUGGING + yes = 0; + no = 0; +#endif + do { + while (curr) { + struct arena_desc *adesc = &(aroot->set[curr]); + const int type = adesc->utype; + void *const root = PL_body_roots[type]; + int body_size = bodies_by_type[type].body_size; + /* HE chain's are similar */ + if (!body_size && type == SVt_NULL) + body_size = sizeof(HE); + if (root && adesc->size && body_size) { + /* Check if the body_roots[type] list is empty. + The end of the arena has *start == NULL, + else points to next (= start+body_size). + If empty root points to the arena start, if full to + the arena end. + */ + if (*(void**)adesc->arena == NULL) { +#ifdef DEBUGGING + yes++; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "%7s body_arena [%u] type=%d size=%d 0x%p\n", + "gc free", curr, type, body_size, adesc->arena)); + /* XXX problems with backrefs and mg */ + /*if (type != SVt_PVHV) + PoisonFree(adesc->arena, adesc->size, char); */ +#endif + Safefree(adesc->arena); + adesc->arena = NULL; + adesc->size = 0; + PL_body_roots[type] = NULL; + } +#ifdef DEBUGGING + else { + no++; + DEBUG_mv(PerlIO_printf(Perl_debug_log, + "%-7s body_arena [%u] type=%d size=%d 0x%p\n", + "filled", curr, type, body_size, adesc->arena)); + } +#endif + } +#ifdef DEBUGGING + else { + DEBUG_mv(PerlIO_printf(Perl_debug_log, + "%-7s body_arena [%u] type=%d size=%d 0x%p\n", + "empty", curr, type, body_size, adesc->arena)); + } +#endif + curr--; + } + aroot = aroot->next; + } while (aroot); + DEBUG_m(PerlIO_printf(Perl_debug_log, "body_arena gc: %d/%d\n", yes, yes+no)); + } +} + /* =for apidoc sv_setiv @@ -6719,7 +6863,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) PL_comppad = NULL; PL_curpad = NULL; } - if (AvREAL(av) && AvFILLp(av) > -1) { + if (AvREAL(av) && AvARRAY(av) && AvFILLp(av) > -1) { next_sv = AvARRAY(av)[AvFILLp(av)--]; /* save old iter_sv in top-most slot of AV, * and pray that it doesn't get wiped in the meantime */ @@ -7144,7 +7288,8 @@ Perl_sv_free2(pTHX_ SV *const sv, const U32 rc) SvREFCNT(sv) = SvREFCNT_IMMORTAL; return; } - sv_clear(sv); + if (! SvIS_FREED(sv)) + sv_clear(sv); if (! SvREFCNT(sv)) /* may have have been resurrected */ del_SV(sv); return; @@ -8904,7 +9049,7 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, STRLEN append) } else { - /*The big, slow, and stupid way. */ + /* The big, slow, and stupid way. */ #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ STDCHAR *buf = NULL; Newx(buf, 8192, STDCHAR); diff --git a/t/cmd/gc.t b/t/cmd/gc.t new file mode 100644 index 00000000000..3b7b9d682fd --- /dev/null +++ b/t/cmd/gc.t @@ -0,0 +1,81 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc('../lib'); +} +plan tests => 2; + +my $cmd = <<'END'; +$|++; +my $s = shift // 2; +sub rss { + # not portable and no process module in core + # `ps -o "comm,rss,vsize" | grep perl` + print "\n"; +} +print "# BEGIN ",scalar keys %main::," ",rss; +require Symbol; +require POSIX; + +print "# GOT POSIX ",scalar keys %main::," ",rss; +sleep($s); + +POSIX->import; +print "# IMPORT POSIX ",scalar keys %main::," ",rss; +sleep($s); + +POSIX->unimport; +Symbol::delete_package('POSIX'); +# with cperl we can safely use Symbol, with perl5 not +if ($^V =~ /c$/) { + Symbol::delete_package('main::'); + eval 'sub rss {print"\n";}'; +} else { + for (keys %main::) { + undef ${$_} unless /^(STD|!|0|1|2|\]|_)/; + undef &{$_} unless /rss/; + undef @{$_}; + undef *{$_} unless /^(STD...?|main::|DynaLoader::|Internals::|rss|_|!)$/; + delete $main::{$_} unless /^(STD...?|main::|DynaLoader::|Internals::|rss|_|!)$/; + } +} +print "# unloaded ",scalar keys %main::," ",rss; +sleep(0.5); + +DynaLoader::dl_unload_file($_) for @DynaLoader::dl_librefs; +undef *DynaLoader::; +print "# unload XS ",scalar keys %main::," ",rss; + +print "POSIX::$_\n" for keys %POSIX::; +Internals::gc() if defined \&Internals::gc; +print "# freed ",scalar keys %main::," ",rss,"\n"; +sleep(0.5); +END + +my $Perl = which_perl(); +my $tmpfile = tempfile(); +chmod 0755, $tmpfile; +unlink_all $tmpfile; + +if (!is_miniperl()) { + open(my $f, ">", $tmpfile) || DIE("Can't open temp test file: $!"); + print $f $cmd; + close $f; + my $res = system("$Perl -I../lib -I../lib/auto $tmpfile 0"); + ok(!$res, "errcode: ".$?>>8); +} else { + ok(1, "skip - no POSIX with miniperl"); +} + +$cmd =~ s/POSIX/parent/g; +$cmd =~ s/^DynaLoader.*$//m; +$cmd =~ s/^.+unload XS.+$//m; +open(my $f, ">", $tmpfile) || DIE("Can't open temp test file: $!"); +print $f $cmd; +close $f; + +my $res = system("$Perl -I../lib $tmpfile 0"); +ok(!$res, "errcode: ".$?>>8); +unlink_all $tmpfile; diff --git a/universal.c b/universal.c index 5da5efbcfcd..8eec5b2d068 100644 --- a/universal.c +++ b/universal.c @@ -704,6 +704,16 @@ XS(XS_Internals_hv_clear_placehold) } } +XS(XS_Internals_gc); /* prototype to pass -Wmissing-prototypes */ +XS(XS_Internals_gc) +{ + /*op_gc_arenas();*/ + sv_gc_arenas(); +#ifdef __GLIBC__ + malloc_trim(0); /* help rss report lower numbers. linux only */ +#endif +} + XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO_get_layers) { @@ -1404,6 +1414,7 @@ static const struct xsub_details details[] = { {"Internals::HvCLASS", XS_Internals_HvCLASS, "\\[$%];$"}, {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, + {"Internals::gc", XS_Internals_gc, ""}, {"constant::_make_const", XS_constant__make_const, "\\[$@]"}, {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, {"re::is_regexp", XS_re_is_regexp, "$"},