From: Dave Mitchell Date: Tue, 19 Apr 2005 01:38:54 +0000 (+0000) Subject: Add CLONE_SKIP() class method to allow individual classes to skip X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9660f4819671f0b9100e5eabfa988ead3e799a1e;p=p5sagit%2Fp5-mst-13.2.git Add CLONE_SKIP() class method to allow individual classes to skip cloning objects during thread creation p4raw-id: //depot/perl@24247 --- diff --git a/dump.c b/dump.c index 31a0e03..0cff00b 100644 --- a/dump.c +++ b/dump.c @@ -1136,7 +1136,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (flags & SVp_IOK) sv_catpv(d, "pIOK,"); if (flags & SVp_NOK) sv_catpv(d, "pNOK,"); if (flags & SVp_POK) sv_catpv(d, "pPOK,"); - if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,"); + if (flags & SVp_SCREAM && type != SVt_PVHV) + sv_catpv(d, "SCREAM,"); switch (type) { case SVt_PVCV: @@ -1159,6 +1160,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,"); if (HvREHASH(sv)) sv_catpv(d, "REHASH,"); + if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,"); break; case SVt_PVGV: case SVt_PVLV: if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t index 2935fc2..de1e938 100644 --- a/ext/threads/t/thread.t +++ b/ext/threads/t/thread.t @@ -12,7 +12,7 @@ BEGIN { use ExtUtils::testlib; use strict; -BEGIN { $| = 1; print "1..26\n" }; +BEGIN { $| = 1; print "1..31\n" }; use threads; use threads::shared; @@ -159,4 +159,114 @@ run_perl(prog => 'use threads; sub a{threads->new(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid'); is($?, 0, 'coredump in global destruction'); +# test CLONE_SKIP() functionality + +{ + my %c : shared; + my %d : shared; + + # --- + + package A; + sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; } + sub DESTROY { $d{"A-". ref $_[0]}++ } + + package A1; + our @ISA = qw(A); + sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; } + sub DESTROY { $d{"A1-". ref $_[0]}++ } + + package A2; + our @ISA = qw(A1); + + # --- + + package B; + sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; } + sub DESTROY { $d{"B-" . ref $_[0]}++ } + + package B1; + our @ISA = qw(B); + sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; } + sub DESTROY { $d{"B1-" . ref $_[0]}++ } + + package B2; + our @ISA = qw(B1); + + # --- + + package C; + sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; } + sub DESTROY { $d{"C-" . ref $_[0]}++ } + + package C1; + our @ISA = qw(C); + sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; } + sub DESTROY { $d{"C1-" . ref $_[0]}++ } + + package C2; + our @ISA = qw(C1); + + # --- + + package D; + sub DESTROY { $d{"D-" . ref $_[0]}++ } + + package D1; + our @ISA = qw(D); + + package main; + + { + my @objs; + for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) { + push @objs, bless [], $class; + } + + sub f { + my $depth = shift; + my $cloned = ""; # XXX due to recursion, doesn't get initialized + $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs; + is($cloned, ($depth ? '00010001111' : '11111111111'), + "objs clone skip at depth $depth"); + threads->new( \&f, $depth+1)->join if $depth < 2; + @objs = (); + } + f(0); + } + + curr_test(curr_test()+2); + ok(eq_hash(\%c, + { + qw( + A-A 2 + A1-A1 2 + A1-A2 2 + B-B 2 + B1-B1 2 + B1-B2 2 + C-C 2 + C1-C1 2 + C1-C2 2 + ) + }), + "counts of calls to CLONE_SKIP"); + ok(eq_hash(\%d, + { + qw( + A-A 1 + A1-A1 1 + A1-A2 1 + B-B 3 + B1-B1 1 + B1-B2 1 + C-C 1 + C1-C1 3 + C1-C2 3 + D-D 3 + D-D1 3 + ) + }), + "counts of calls to DESTROY"); +} diff --git a/pod/perlmod.pod b/pod/perlmod.pod index 00cc71a..518c04b 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -539,7 +539,8 @@ between different threads. These threads can be used by using the C module or by doing fork() on win32 (fake fork() support). When a thread is cloned all Perl data is cloned, however non-Perl data cannot be cloned automatically. Perl after 5.7.2 has support for the C -special subroutine. In C you can do whatever you need to do, +and C special subroutines. In C you can do whatever +you need to do, like for example handle the cloning of non-Perl data, if necessary. C will be called once as a class method for every package that has it defined (or inherits it). It will be called in the context of the new thread, @@ -551,6 +552,21 @@ will be passed in to give more information about the state of cloning. If you want to CLONE all objects you will need to keep track of them per package. This is simply done using a hash and Scalar::Util::weaken(). +Like C, C is called once per package; however, it is +called just before cloning starts, and in the context of the parent +thread. If it returns a true value, then no objects of that class will +be cloned; or rather, they will be copied as unblessed, undef values. +This provides a simple mechanism for making a module threadsafe; just add +C at the top of the class, and C will be +now only be called once per object. Of course, if the child thread needs +to make use of the objects, then a more sophisticated approach is +needed. + +Like C, C is currently called with no parameters other +than the invocant package name, although that may change. Similarly, to +allow for future expansion, the return value should be a single C<0> or +C<1> value. + =head1 SEE ALSO See L for general style issues related to building Perl diff --git a/sv.c b/sv.c index bd736b7..b2366e1 100644 --- a/sv.c +++ b/sv.c @@ -10775,6 +10775,13 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) PL_watch_pvx, SvPVX(sstr)); #endif + /* don't clone objects whose class has asked us not to */ + if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { + SvFLAGS(dstr) &= ~SVTYPEMASK; + SvOBJECT_off(dstr); + return dstr; + } + switch (SvTYPE(sstr)) { case SVt_NULL: SvANY(dstr) = NULL; @@ -11490,6 +11497,40 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) return nss; } + +/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE + * flag to the result. This is done for each stash before cloning starts, + * so we know which stashes want their objects cloned */ + +static void +do_mark_cloneable_stash(pTHX_ SV *sv) +{ + if (HvNAME((HV*)sv)) { + GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); + SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ + if (cloner && GvCV(cloner)) { + dSP; + UV status; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0))); + PUTBACK; + call_sv((SV*)GvCV(cloner), G_SCALAR); + SPAGAIN; + status = POPu; + PUTBACK; + FREETMPS; + LEAVE; + if (status) + SvFLAGS(sv) &= ~SVphv_CLONEABLE; + } + } +} + + + /* =for apidoc perl_clone @@ -11571,6 +11612,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + /* for each stash, determine whether its objects should be cloned */ + S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); # ifdef DEBUGGING @@ -11603,10 +11646,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, CLONE_PARAMS clone_params; CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + /* for each stash, determine whether its objects should be cloned */ + S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); - - # ifdef DEBUGGING Poison(my_perl, 1, PerlInterpreter); PL_op = Nullop; @@ -12314,7 +12357,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); + XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; diff --git a/sv.h b/sv.h index 251a1d9..ecde483 100644 --- a/sv.h +++ b/sv.h @@ -221,6 +221,7 @@ perform the upgrade if necessary. See C. #define SVrepl_EVAL 0x40000000 /* Replacement part of s///e */ +#define SVphv_CLONEABLE 0x08000000 /* for stashes: clone its objects */ #define SVphv_REHASH 0x10000000 /* HV is recalculating hash values */ #define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */ #define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */