extension for specifying 'locked' and 'method' attributes.
p4raw-id: //depot/perl@56
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
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*)
#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)
#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)
#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
--- /dev/null
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'attrs',
+ VERSION_FROM => 'attrs.pm',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes'
+);
--- /dev/null
+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;
--- /dev/null
+#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)));
+
too_few_arguments
too_many_arguments
unlnk
+unlock_condpair
unshare_hek
unsharepvn
utilize
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)) {
#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);
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)
#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);
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()
{
/* 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);
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();
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);
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;
}
#ifdef USE_THREADS
-static void
+void
unlock_condpair(svv)
void *svv;
{
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();
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);
}
#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));
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;
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);
}
}
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);
MARK++;
}
}
+#if 0
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"%p entersub returning %p\n", thr, CvSTART(cv)));
+#endif
RETURNOP(CvSTART(cv));
}
}
#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));
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;
#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 */
};
/* 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 */
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;
};
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();
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff