From: Vincent Pit Date: Sun, 28 Sep 2014 15:18:22 +0000 (+0200) Subject: Support pseudo-forks more reliably X-Git-Tag: v0.06~4 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=edfeeb476d5446fc117243df3a5b4ce6baa82b43;p=perl%2Fmodules%2FThread-Cleanup.git Support pseudo-forks more reliably reap.h is no longer necessary. --- diff --git a/Cleanup.xs b/Cleanup.xs index e88916c..919bbff 100644 --- a/Cleanup.xs +++ b/Cleanup.xs @@ -11,8 +11,6 @@ #define TC_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) -#include "reap.h" - STATIC void tc_callback(pTHX_ void *ud) { dSP; @@ -30,6 +28,29 @@ STATIC void tc_callback(pTHX_ void *ud) { LEAVE; } +STATIC int tc_endav_free(pTHX_ SV *sv, MAGIC *mg) { + SAVEDESTRUCTOR_X(tc_callback, NULL); + + return 0; +} + +STATIC MGVTBL tc_endav_vtbl = { + 0, + 0, + 0, + 0, + tc_endav_free +#if MGf_COPY + , 0 +#endif +#if MGf_DUP + , 0 +#endif +#if MGf_LOCAL + , 0 +#endif +}; + MODULE = Thread::Cleanup PACKAGE = Thread::Cleanup PROTOTYPES: DISABLE @@ -37,6 +58,17 @@ PROTOTYPES: DISABLE void CLONE(...) PREINIT: + GV *gv; PPCODE: - reap(3, tc_callback, NULL); + gv = gv_fetchpv(__PACKAGE__ "::_CLEANUP", 0, SVt_PVCV); + if (gv) { + CV *cv = GvCV(gv); + if (!PL_endav) + PL_endav = newAV(); + av_unshift(PL_endav, 1); + SvREFCNT_inc(cv); + if (!av_store(PL_endav, 0, cv)) + SvREFCNT_dec(cv); + sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &tc_endav_vtbl, NULL, 0); + } XSRETURN(0); diff --git a/MANIFEST b/MANIFEST index 00b94e9..cb6efab 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6,12 +6,12 @@ META.yml Makefile.PL README lib/Thread/Cleanup.pm -reap.h samples/try.pl t/00-load.t t/10-join.t t/11-detach.t t/20-recurse.t t/21-ctl.t +t/30-pseudoforks.t t/lib/Thread/Cleanup/TestThreads.pm t/lib/VPIT/TestHelpers.pm diff --git a/lib/Thread/Cleanup.pm b/lib/Thread/Cleanup.pm index ebb424e..96256fd 100644 --- a/lib/Thread/Cleanup.pm +++ b/lib/Thread/Cleanup.pm @@ -40,6 +40,8 @@ This module allows you to hook thread destruction without fiddling with the inte It acts globally on all the threads that may spawn anywhere in your program, with the exception of the main thread. +The hook will also be called when pseudo-forks (i.e. processes spawn on Windows for the C emulation) terminate. + =head1 FUNCTIONS =head2 C diff --git a/reap.h b/reap.h deleted file mode 100644 index 6b92167..0000000 --- a/reap.h +++ /dev/null @@ -1,81 +0,0 @@ -/* This file is part of the Thread::Cleanup Perl module. - * See http://search.cpan.org/dist/Thread-Cleanup/ */ - -/* This header provides a specialized version of Scope::Upper::reap that can be - * called directly from XS. - * See http://search.cpan.org/dist/Scope-Upper/ for details. */ - -#ifndef REAP_H -#define REAP_H 1 - -#define REAP_DESTRUCTOR_SIZE 3 - -typedef struct { - I32 depth; - I32 *origin; - void (*cb)(pTHX_ void *); - void *ud; - char *dummy; -} reap_ud; - -STATIC void reap_pop(pTHX_ void *); - -STATIC void reap_pop(pTHX_ void *ud_) { - reap_ud *ud = ud_; - I32 depth, *origin, mark, base; - - depth = ud->depth; - origin = ud->origin; - mark = origin[depth]; - base = origin[depth - 1]; - - if (base < mark) { - PL_savestack_ix = mark; - leave_scope(base); - } - PL_savestack_ix = base; - - if ((ud->depth = --depth) > 0) { - SAVEDESTRUCTOR_X(reap_pop, ud); - } else { - void (*cb)(pTHX_ void *) = ud->cb; - void *cb_ud = ud->ud; - - PerlMemShared_free(ud->origin); - PerlMemShared_free(ud); - - SAVEDESTRUCTOR_X(cb, cb_ud); - } -} - -STATIC void reap(pTHX_ I32 depth, void (*cb)(pTHX_ void *), void *cb_ud) { -#define reap(D, CB, UD) reap(aTHX_ (D), (CB), (UD)) - reap_ud *ud; - I32 i; - - if (depth > PL_scopestack_ix) - depth = PL_scopestack_ix; - - ud = PerlMemShared_malloc(sizeof *ud); - ud->depth = depth; - ud->origin = PerlMemShared_malloc((depth + 1) * sizeof *ud->origin); - ud->cb = cb; - ud->ud = cb_ud; - ud->dummy = NULL; - - for (i = depth; i >= 1; --i) { - I32 j = PL_scopestack_ix - i; - ud->origin[depth - i] = PL_scopestack[j]; - PL_scopestack[j] += REAP_DESTRUCTOR_SIZE; - } - ud->origin[depth] = PL_savestack_ix; - - while (PL_savestack_ix + REAP_DESTRUCTOR_SIZE - <= PL_scopestack[PL_scopestack_ix - 1]) { - save_pptr(&ud->dummy); - } - - SAVEDESTRUCTOR_X(reap_pop, ud); -} - -#endif /* REAP_H */ diff --git a/t/30-pseudoforks.t b/t/30-pseudoforks.t new file mode 100644 index 0000000..2247c40 --- /dev/null +++ b/t/30-pseudoforks.t @@ -0,0 +1,46 @@ +#!perl -T + +use strict; +use warnings; + +use Config; + +use Test::More; + +use lib 't/lib'; +use VPIT::TestHelpers; + +use Thread::Cleanup; + +plan skip_all => + 'perl on Windows with pseudoforks enabled is required for this test' + unless $^O eq 'MSWin32' and $Config::Config{d_pseudofork}; + +my $global_end = 0; +END { ++$global_end } + +my $pid = fork; + +plan skip_all => 'could not fork' unless defined $pid; + +if ($pid) { + waitpid $pid, 0; +} else { + plan tests => 4; + + my $gd = 0; + my $immortal = VPIT::TestHelpers::Guard->new(sub { ++$gd }); + $immortal->{self} = $immortal; + + my $local_end = 0; + eval 'END { ++$local_end }'; + + Thread::Cleanup::register { + pass 'pseudo-fork destructor called'; + is $local_end, 1, 'pseudo-fork destructor called after local END block'; + is $global_end, 0, 'pseudo-fork destructor called before global END block'; + is $gd, 0, 'pseudo-fork destructor called before global destruction'; + }; + + exit; +}