diff options
| -rw-r--r-- | MANIFEST | 3 | ||||
| -rw-r--r-- | cv.h | 26 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | ext/attrs/Makefile.PL | 7 | ||||
| -rw-r--r-- | ext/attrs/attrs.pm | 55 | ||||
| -rw-r--r-- | ext/attrs/attrs.xs | 60 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | op.c | 11 | ||||
| -rw-r--r-- | perl.c | 21 | ||||
| -rw-r--r-- | pp.c | 5 | ||||
| -rw-r--r-- | pp_ctl.c | 2 | ||||
| -rw-r--r-- | pp_hot.c | 66 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | sv.c | 3 | ||||
| -rw-r--r-- | sv.h | 8 | ||||
| -rw-r--r-- | toke.c | 4 |
16 files changed, 213 insertions, 63 deletions
@@ -205,6 +205,9 @@ ext/SDBM_File/typemap SDBM extension interface types ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines +ext/attrs/Makefile.PL attrs extension makefile writer +ext/attrs/attrs.pm attrs extension Perl module +ext/attrs/attrs.xs attrs extension external subroutines ext/util/extliblist Used by extension Makefile.PL to make lib lists ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info @@ -30,10 +30,9 @@ struct xpvcv { CV * xcv_outside; #ifdef USE_THREADS perl_mutex *xcv_mutexp; - perl_cond * xcv_condp; /* signalled when owner leaves CV */ struct thread *xcv_owner; /* current owner thread */ #endif /* USE_THREADS */ - U8 xcv_flags; + cv_flags_t xcv_flags; }; #define Nullcv Null(CV*) @@ -50,18 +49,19 @@ struct xpvcv { #define CvOUTSIDE(sv) ((XPVCV*)SvANY(sv))->xcv_outside #ifdef USE_THREADS #define CvMUTEXP(sv) ((XPVCV*)SvANY(sv))->xcv_mutexp -#define CvCONDP(sv) ((XPVCV*)SvANY(sv))->xcv_condp #define CvOWNER(sv) ((XPVCV*)SvANY(sv))->xcv_owner #endif /* USE_THREADS */ #define CvFLAGS(sv) ((XPVCV*)SvANY(sv))->xcv_flags -#define CVf_CLONE 0x01 /* anon CV uses external lexicals */ -#define CVf_CLONED 0x02 /* a clone of one of those */ -#define CVf_ANON 0x04 /* CvGV() can't be trusted */ -#define CVf_OLDSTYLE 0x08 -#define CVf_UNIQUE 0x10 /* can't be cloned */ -#define CVf_NODEBUG 0x20 /* no DB::sub indirection for this CV +#define CVf_CLONE 0x0001 /* anon CV uses external lexicals */ +#define CVf_CLONED 0x0002 /* a clone of one of those */ +#define CVf_ANON 0x0004 /* CvGV() can't be trusted */ +#define CVf_OLDSTYLE 0x0008 +#define CVf_UNIQUE 0x0010 /* can't be cloned */ +#define CVf_NODEBUG 0x0020 /* no DB::sub indirection for this CV (esp. useful for special XSUBs) */ +#define CVf_METHOD 0x0040 /* CV is explicitly marked as a method */ +#define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */ #define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) #define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) @@ -86,3 +86,11 @@ struct xpvcv { #define CvNODEBUG(cv) (CvFLAGS(cv) & CVf_NODEBUG) #define CvNODEBUG_on(cv) (CvFLAGS(cv) |= CVf_NODEBUG) #define CvNODEBUG_off(cv) (CvFLAGS(cv) &= ~CVf_NODEBUG) + +#define CvMETHOD(cv) (CvFLAGS(cv) & CVf_METHOD) +#define CvMETHOD_on(cv) (CvFLAGS(cv) |= CVf_METHOD) +#define CvMETHOD_off(cv) (CvFLAGS(cv) &= ~CVf_METHOD) + +#define CvLOCKED(cv) (CvFLAGS(cv) & CVf_LOCKED) +#define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED) +#define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED) @@ -1091,6 +1091,7 @@ #define too_many_arguments Perl_too_many_arguments #define uid Perl_uid #define unlnk Perl_unlnk +#define unlock_condpair Perl_unlock_condpair #define unshare_hek Perl_unshare_hek #define unsharepvn Perl_unsharepvn #define utilize Perl_utilize diff --git a/ext/attrs/Makefile.PL b/ext/attrs/Makefile.PL new file mode 100644 index 0000000000..c421757615 --- /dev/null +++ b/ext/attrs/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'attrs', + VERSION_FROM => 'attrs.pm', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes' +); diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm new file mode 100644 index 0000000000..fe2bf356e4 --- /dev/null +++ b/ext/attrs/attrs.pm @@ -0,0 +1,55 @@ +package attrs; +require DynaLoader; +use vars '@ISA'; +@ISA = 'DynaLoader'; + +use vars qw($VERSION); +$VERSION = "1.0"; + +=head1 NAME + +attrs - set/get attributes of a subroutine + +=head1 SYNOPSIS + + sub foo { + use attrs qw(locked method); + ... + } + + @a = attrs::get(\&foo); + +=head1 DESCRIPTION + +This module lets you set and get attributes for subroutines. +Setting attributes takes place at compile time; trying to set +invalid attribute names causes a compile-time error. Calling +C<attr::get> on a subroutine reference or name returns its list +of attribute names. Notice that C<attr::get> is not exported. +Valid attributes are as follows. + +=over + +=item method + +Indicates that the invoking subroutine is a method. + +=item locked + +Setting this attribute is only meaningful when the subroutine or +method is to be called by multiple threads. When set on a method +subroutine (i.e. one marked with the B<method> attribute above), +perl ensures that any invocation of it implicitly locks its first +argument before execution. When set on a non-method subroutine, +perl ensures that a lock is taken on the subroutine itself before +execution. The semantics of the lock are exactly those of one +explicitly taken with the C<lock> operator immediately after the +subroutine is entered. + +=back + +=cut + +bootstrap attrs $VERSION; + +1; diff --git a/ext/attrs/attrs.xs b/ext/attrs/attrs.xs new file mode 100644 index 0000000000..f34ac850ea --- /dev/null +++ b/ext/attrs/attrs.xs @@ -0,0 +1,60 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +static cv_flags_t +get_flag(attr) +char *attr; +{ + if (strnEQ(attr, "method", 6)) + return CVf_METHOD; + else if (strnEQ(attr, "locked", 6)) + return CVf_LOCKED; + else + return 0; +} + +MODULE = attrs PACKAGE = attrs + +void +import(class, ...) +char * class + ALIAS: + unimport = 1 + PREINIT: + int i; + CV *cv; + PPCODE: + if (!compcv || !(cv = CvOUTSIDE(compcv))) + croak("can't set attributes outside a subroutine scope"); + for (i = 1; i < items; i++) { + char *attr = SvPV(ST(i), na); + cv_flags_t flag = get_flag(attr); + if (!flag) + croak("invalid attribute name %s", attr); + if (ix) + CvFLAGS(cv) &= ~flag; + else + CvFLAGS(cv) |= flag; + } + +void +get(sub) +SV * sub + PPCODE: + if (SvROK(sub)) { + sub = SvRV(sub); + if (SvTYPE(sub) != SVt_PVCV) + sub = Nullsv; + } + else { + char *name = SvPV(sub, na); + sub = (SV*)perl_get_cv(name, FALSE); + } + if (!sub) + croak("invalid subroutine reference or name"); + if (CvFLAGS(sub) & CVf_METHOD) + XPUSHs(sv_2mortal(newSVpv("method", 0))); + if (CvFLAGS(sub) & CVf_LOCKED) + XPUSHs(sv_2mortal(newSVpv("locked", 0))); + diff --git a/global.sym b/global.sym index 6439135e46..f7d11f22ad 100644 --- a/global.sym +++ b/global.sym @@ -1158,6 +1158,7 @@ taint_proper too_few_arguments too_many_arguments unlnk +unlock_condpair unshare_hek unsharepvn utilize @@ -2998,11 +2998,6 @@ CV *cv; Safefree(CvMUTEXP(cv)); CvMUTEXP(cv) = 0; } - if (CvCONDP(cv)) { - COND_DESTROY(CvCONDP(cv)); - Safefree(CvCONDP(cv)); - CvCONDP(cv) = 0; - } #endif /* USE_THREADS */ if (!CvXSUB(cv) && CvROOT(cv)) { @@ -3133,8 +3128,6 @@ CV* outside; #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, perl_cond); - COND_INIT(CvCONDP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILEGV(cv) = CvFILEGV(proto); @@ -3375,8 +3368,6 @@ OP *block; CvOWNER(cv) = 0; New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, perl_cond); - COND_INIT(CvCONDP(cv)); #endif /* USE_THREADS */ if (ps) @@ -3582,8 +3573,6 @@ char *filename; #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, perl_cond); - COND_INIT(CvCONDP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILEGV(cv) = gv_fetchfile(filename); @@ -83,6 +83,19 @@ static void validate_suid _((char *, char*)); static int fdscript = -1; +#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) +#include <asm/sigcontext.h> +static void +catch_sigsegv(int signo, struct sigcontext_struct sc) +{ + signal(SIGSEGV, SIG_DFL); + fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n" + "return_address = 0x%lx, eip = 0x%lx\n", + sc.cr2, __builtin_return_address(0), sc.eip); + fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR); +} +#endif + PerlInterpreter * perl_alloc() { @@ -416,8 +429,10 @@ register PerlInterpreter *sv_interp; /* startup and shutdown function lists */ SvREFCNT_dec(beginav); SvREFCNT_dec(endav); + SvREFCNT_dec(initav); beginav = Nullav; endav = Nullav; + initav = Nullav; /* temp stack during pp_sort() */ SvREFCNT_dec(sortstack); @@ -855,8 +870,6 @@ print \" \\@INC:\\n @INC\\n\";"); CvOWNER(compcv) = 0; New(666, CvMUTEXP(compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(compcv)); - New(666, CvCONDP(compcv), 1, perl_cond); - COND_INIT(CvCONDP(compcv)); #endif /* USE_THREADS */ comppadlist = newAV(); @@ -872,6 +885,10 @@ print \" \\@INC:\\n @INC\\n\";"); init_os_extras(); #endif +#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) + DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv);); +#endif + init_predump_symbols(); if (!do_undump) init_postdump_symbols(argc,argv,env); @@ -89,9 +89,6 @@ typedef unsigned UBW; static void doencodes _((SV* sv, char* s, I32 len)); static SV* refto _((SV* sv)); static U32 seed _((void)); -#ifdef USE_THREADS -static void unlock_condpair _((void*)); -#endif /* USE_THREADS */ static bool srand_called = FALSE; @@ -4117,7 +4114,7 @@ PP(pp_split) } #ifdef USE_THREADS -static void +void unlock_condpair(svv) void *svv; { @@ -2158,8 +2158,6 @@ int gimme; CvOWNER(compcv) = 0; New(666, CvMUTEXP(compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(compcv)); - New(666, CvCONDP(compcv), 1, perl_cond); - COND_INIT(CvCONDP(compcv)); #endif /* USE_THREADS */ comppad = newAV(); @@ -33,11 +33,11 @@ void *cvarg; DEBUG_L((fprintf(stderr, "0x%lx unsetting CvOWNER of 0x%lx:%s\n", (unsigned long)thr, (unsigned long)cv, SvPEEK((SV*)cv)))); MUTEX_LOCK(CvMUTEXP(cv)); - /* assert(CvDEPTH(cv) == 0); */ + DEBUG_L(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); assert(thr == CvOWNER(cv)); CvOWNER(cv) = 0; - if (CvCONDP(cv)) - COND_SIGNAL(CvCONDP(cv)); /* next please */ MUTEX_UNLOCK(CvMUTEXP(cv)); SvREFCNT_dec(cv); } @@ -1873,26 +1873,35 @@ PP(pp_entersub) #ifdef USE_THREADS MUTEX_LOCK(CvMUTEXP(cv)); - if (!CvCONDP(cv)) { -#ifdef DEBUGGING - DEBUG_L((fprintf(stderr, "0x%lx entering fast %s\n", - (unsigned long)thr, SvPEEK((SV*)cv)))); -#endif /* DEBUGGING */ - MUTEX_UNLOCK(CvMUTEXP(cv)); /* fast sub wants neither sync nor clone */ - } - else if (SvFLAGS(cv) & SVp_SYNC) { - /* - * It's a synchronised CV. Wait until it's free unless - * we own it already (in which case we're recursing). - */ - if (CvOWNER(cv) && CvOWNER(cv) != thr) { - do { - DEBUG_L((fprintf(stderr, "0x%lx wait for 0x%lx to leave %s\n", - (unsigned long)thr,(unsigned long)CvOWNER(cv), - SvPEEK((SV*)cv)))); - COND_WAIT(CvCONDP(cv), CvMUTEXP(cv)); /* yawn */ - } while (CvOWNER(cv)); + if (CvFLAGS(cv) & CVf_LOCKED) { + MAGIC *mg; + if (CvFLAGS(cv) & CVf_METHOD) { + if (SP > stack_base + TOPMARK) + sv = *(stack_base + TOPMARK + 1); + else { + MUTEX_UNLOCK(CvMUTEXP(cv)); + croak("no argument for locked method call"); + } + if (SvROK(sv)) + sv = SvRV(sv); + } + else { + sv = (SV*)cv; } + MUTEX_UNLOCK(CvMUTEXP(cv)); + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + MUTEX_UNLOCK(MgMUTEXP(mg)); + save_destructor(unlock_condpair, sv); + } + MUTEX_LOCK(CvMUTEXP(cv)); + assert(CvOWNER(cv) == 0); CvOWNER(cv) = thr; /* Assert ownership */ SvREFCNT_inc(cv); MUTEX_UNLOCK(CvMUTEXP(cv)); @@ -1949,9 +1958,10 @@ PP(pp_entersub) SvREFCNT_inc(cv); MUTEX_UNLOCK(CvMUTEXP(cv)); DEBUG_L(fprintf(stderr, - "entersub: 0x%lx grabbing 0x%lx:%s\n", + "entersub: 0x%lx grabbing 0x%lx:%s in stash %s\n", (unsigned long) thr, (unsigned long) cv, - SvPEEK((SV*)cv))); + SvPEEK((SV*)cv), CvSTASH(cv) ? + HvNAME(CvSTASH(cv)) : "(none)")); } else { /* Make a new clone. */ CV *clonecv; @@ -1975,7 +1985,9 @@ PP(pp_entersub) cv = clonecv; SvREFCNT_inc(cv); } - assert(CvDEPTH(cv) == 0); + DEBUG_L(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); SAVEDESTRUCTOR(unset_cvowner, (void*) cv); } } @@ -2125,8 +2137,10 @@ PP(pp_entersub) AV* av; SV** ary; +#if 0 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p entersub preparing @_\n", thr)); +#endif av = (AV*)curpad[0]; if (AvREAL(av)) { av_clear(av); @@ -2161,8 +2175,10 @@ PP(pp_entersub) MARK++; } } +#if 0 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p entersub returning %p\n", thr, CvSTART(cv))); +#endif RETURNOP(CvSTART(cv)); } } @@ -534,6 +534,9 @@ void taint_proper _((const char* f, char* s)); #ifdef UNLINK_ALL_VERSIONS I32 unlnk _((char* f)); #endif +#ifdef USE_THREADS +void unlock_condpair _((void* svv)); +#endif void unsharepvn _((char* sv, I32 len, U32 hash)); void unshare_hek _((HEK* hek)); void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg)); @@ -4897,9 +4897,10 @@ SV* sv; PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); #ifdef USE_THREADS PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv)); - PerlIO_printf(Perl_debug_log, " CONDP = 0x%lx\n", (long)CvCONDP(sv)); PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv)); #endif /* USE_THREADS */ + PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", + (unsigned long)CvFLAGS(sv)); if (type == SVt_PVFM) PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); break; @@ -131,10 +131,6 @@ struct io { #define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */ #define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */ -#ifdef USE_THREADS -#define SVp_SYNC 0x10000000 /* Synchronised CV or an SV lock */ -#endif /* USE_THREADS */ - struct xrv { SV * xrv_rv; /* pointer to another SV */ }; @@ -224,6 +220,8 @@ struct xpvbm { /* This structure much match XPVCV */ +typedef U16 cv_flags_t; + struct xpvfm { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ @@ -248,7 +246,7 @@ struct xpvfm { perl_cond * xcv_condp; /* signalled when owner leaves CV */ struct thread *xcv_owner; /* current owner thread */ #endif /* USE_THREADS */ - U8 xcv_flags; + cv_flags_t xcv_flags; I32 xfm_lines; }; @@ -5243,8 +5243,6 @@ U32 flags; CvOWNER(compcv) = 0; New(666, CvMUTEXP(compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(compcv)); - New(666, CvCONDP(compcv), 1, perl_cond); - COND_INIT(CvCONDP(compcv)); #endif /* USE_THREADS */ comppadlist = newAV(); @@ -5258,8 +5256,6 @@ U32 flags; CvOWNER(compcv) = 0; New(666, CvMUTEXP(compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(compcv)); - New(666, CvCONDP(compcv), 1, perl_cond); - COND_INIT(CvCONDP(compcv)); #endif /* USE_THREADS */ return oldsavestack_ix; |