This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rewrite synchronisation of subs/methods and add attrs
authorMalcolm Beattie <mbeattie@sable.ox.ac.uk>
Tue, 9 Sep 1997 15:04:26 +0000 (15:04 +0000)
committerMalcolm Beattie <mbeattie@sable.ox.ac.uk>
Tue, 9 Sep 1997 15:04:26 +0000 (15:04 +0000)
extension for specifying 'locked' and 'method' attributes.

p4raw-id: //depot/perl@56

16 files changed:
MANIFEST
cv.h
embed.h
ext/attrs/Makefile.PL [new file with mode: 0644]
ext/attrs/attrs.pm [new file with mode: 0644]
ext/attrs/attrs.xs [new file with mode: 0644]
global.sym
op.c
perl.c
pp.c
pp_ctl.c
pp_hot.c
proto.h
sv.c
sv.h
toke.c

index fa97d8e..4773984 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/cv.h b/cv.h
index 1e6b8de..d5ffdc2 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -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)
diff --git a/embed.h b/embed.h
index f71c3ad..9fd116c 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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 (file)
index 0000000..c421757
--- /dev/null
@@ -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 (file)
index 0000000..fe2bf35
--- /dev/null
@@ -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 (file)
index 0000000..f34ac85
--- /dev/null
@@ -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)));
+
index 6439135..f7d11f2 100644 (file)
@@ -1158,6 +1158,7 @@ taint_proper
 too_few_arguments
 too_many_arguments
 unlnk
+unlock_condpair
 unshare_hek
 unsharepvn
 utilize
diff --git a/op.c b/op.c
index 4e8fa1d..b21c26d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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);
diff --git a/perl.c b/perl.c
index c9acca4..ea8d3fd 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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);
diff --git a/pp.c b/pp.c
index c956e80..6761a1f 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -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;
 {
index a2074c2..54524ae 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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();
index 87bcad2..fce7437 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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));
     }
 }
diff --git a/proto.h b/proto.h
index 3ad298d..4565ec4 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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));
diff --git a/sv.c b/sv.c
index 2868073..cd55f81 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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;
diff --git a/sv.h b/sv.h
index 2651e43..884b206 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -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;
 };
diff --git a/toke.c b/toke.c
index dc2c2a2..78ae386 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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;