Click here to Skip to main content
Click here to Skip to main content
 
Add your own
alternative version

PXPerlWrap (PXPerl, reloaded)

, 3 Nov 2004
A comprehensive Perl embedding solution.
pxperldemo.zip
PERL_CORE
arpa
perl58.lib
PerlEz.lib
sys
Release
lib
auto
PerlIO
encoding
encoding.dll
scalar
scalar.dll
via
via.dll
Carp.pm
Exporter.pm
PerlIO
encoding.pm
scalar.pm
via
QuotedPrint.pm
via.pm
PerlIO.pm
strict.pm
Symbol.pm
THESE ARE REQUIRED LIBs
warnings.pm
XSLoader.pm
perl58.dll
PXPerlDemo.exe
res
perl.ico
perl2.ico
perl3.ico
perlsistent.pl
PXPerlDemo.ico
PXPerlDemo.manifest
pxperl_demo.zip
perl58.lib
PerlEz.lib
encoding.dll
scalar.dll
via.dll
Carp.pm
Exporter.pm
encoding.pm
scalar.pm
QuotedPrint.pm
via.pm
PerlIO.pm
strict.pm
Symbol.pm
THESE ARE REQUIRED LIBs
warnings.pm
XSLoader.pm
perl58.dll
PXPerlDemo.exe
perl.ico
perl2.ico
perl3.ico
perlsistent.pl
PXPerlDemo.ico
PXPerlDemo.manifest
/*    thread.h
 *
 *    Copyright (c) 1997-2002, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

#if defined(USE_5005THREADS) || defined(USE_ITHREADS)

#if defined(VMS)
#include <builtins.h>
#endif

#ifdef WIN32
#  include <win32thread.h>
#else
#ifdef NETWARE
#  include <nw5thread.h>
#else
#  ifdef OLD_PTHREADS_API /* Here be dragons. */
#    define DETACH(t) \
    STMT_START {						\
	if (pthread_detach(&(t)->self)) {			\
	    MUTEX_UNLOCK(&(t)->mutex);				\
	    Perl_croak_nocontext("panic: DETACH");		\
	}							\
    } STMT_END

#    define PERL_GET_CONTEXT	Perl_get_context()
#    define PERL_SET_CONTEXT(t)	Perl_set_context((void*)t)

#    define PTHREAD_GETSPECIFIC_INT
#    ifdef DJGPP
#      define pthread_addr_t any_t
#      define NEED_PTHREAD_INIT
#      define PTHREAD_CREATE_JOINABLE (1)
#    endif
#    ifdef __OPEN_VM
#      define pthread_addr_t void *
#    endif
#    ifdef VMS
#      define pthread_attr_init(a) pthread_attr_create(a)
#      define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_setdetach_np(a,s)
#      define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d)
#      define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d))
#      define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
#      define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
#    endif
#    if defined(__hpux) && defined(__ux_version) && __ux_version <= 1020
#      define pthread_attr_init(a) pthread_attr_create(a)
       /* XXX pthread_setdetach_np() missing in DCE threads on HP-UX 10.20 */
#      define PTHREAD_ATTR_SETDETACHSTATE(a,s)	(0)
#      define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d)
#      define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d))
#      define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
#      define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
#    endif
#    if defined(DJGPP) || defined(__OPEN_VM)
#      define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,&(s))
#      define YIELD pthread_yield(NULL)
#    endif
#  endif
#  if !defined(__hpux) || !defined(__ux_version) || __ux_version > 1020
#    define pthread_mutexattr_default NULL
#    define pthread_condattr_default  NULL
#  endif
#endif	/* NETWARE */
#endif

#ifndef PTHREAD_CREATE
/* You are not supposed to pass NULL as the 2nd arg of PTHREAD_CREATE(). */
#  define PTHREAD_CREATE(t,a,s,d) pthread_create(t,&(a),s,d)
#endif

#ifndef PTHREAD_ATTR_SETDETACHSTATE
#  define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,s)
#endif

#ifndef PTHREAD_CREATE_JOINABLE
#  ifdef OLD_PTHREAD_CREATE_JOINABLE
#    define PTHREAD_CREATE_JOINABLE OLD_PTHREAD_CREATE_JOINABLE
#  else
#    define PTHREAD_CREATE_JOINABLE 0 /* Panic?  No, guess. */
#  endif
#endif

#ifdef DGUX
#  define THREAD_CREATE_NEEDS_STACK (32*1024)
#endif

#ifdef I_MACH_CTHREADS

/* cthreads interface */

/* #include <mach/cthreads.h> is in perl.h #ifdef I_MACH_CTHREADS */

#define MUTEX_INIT(m) \
    STMT_START {						\
	*m = mutex_alloc();					\
	if (*m) {						\
	    mutex_init(*m);					\
	} else {						\
	    Perl_croak_nocontext("panic: MUTEX_INIT");		\
	}							\
    } STMT_END

#define MUTEX_LOCK(m)			mutex_lock(*m)
#define MUTEX_UNLOCK(m)			mutex_unlock(*m)
#define MUTEX_DESTROY(m) \
    STMT_START {						\
	mutex_free(*m);						\
	*m = 0;							\
    } STMT_END

#define COND_INIT(c) \
    STMT_START {						\
	*c = condition_alloc();					\
	if (*c) {						\
	    condition_init(*c);					\
	}							\
	else {							\
	    Perl_croak_nocontext("panic: COND_INIT");		\
	}							\
    } STMT_END

#define COND_SIGNAL(c)		condition_signal(*c)
#define COND_BROADCAST(c)	condition_broadcast(*c)
#define COND_WAIT(c, m)		condition_wait(*c, *m)
#define COND_DESTROY(c) \
    STMT_START {						\
	condition_free(*c);					\
	*c = 0;							\
    } STMT_END

#define THREAD_CREATE(thr, f)	(thr->self = cthread_fork(f, thr), 0)
#define THREAD_POST_CREATE(thr)

#define THREAD_RET_TYPE		any_t
#define THREAD_RET_CAST(x)	((any_t) x)

#define DETACH(t)		cthread_detach(t->self)
#define JOIN(t, avp)		(*(avp) = (AV *)cthread_join(t->self))

#define PERL_SET_CONTEXT(t)	cthread_set_data(cthread_self(), t)
#define PERL_GET_CONTEXT	cthread_data(cthread_self())

#define INIT_THREADS		cthread_init()
#define YIELD			cthread_yield()
#define ALLOC_THREAD_KEY	NOOP
#define FREE_THREAD_KEY		NOOP
#define SET_THREAD_SELF(thr)	(thr->self = cthread_self())

#endif /* I_MACH_CTHREADS */

#ifndef YIELD
#  ifdef SCHED_YIELD
#    define YIELD SCHED_YIELD
#  else
#    ifdef HAS_SCHED_YIELD
#      define YIELD sched_yield()
#    else
#      ifdef HAS_PTHREAD_YIELD
    /* pthread_yield(NULL) platforms are expected
     * to have #defined YIELD for themselves. */
#        define YIELD pthread_yield()
#      endif
#    endif
#  endif
#endif

#ifdef __hpux
#  define MUTEX_INIT_NEEDS_MUTEX_ZEROED
#endif

#ifndef MUTEX_INIT

#  ifdef MUTEX_INIT_NEEDS_MUTEX_ZEROED
    /* Temporary workaround, true bug is deeper. --jhi 1999-02-25 */
#    define MUTEX_INIT(m) \
    STMT_START {						\
	Zero((m), 1, perl_mutex);                               \
 	if (pthread_mutex_init((m), pthread_mutexattr_default))	\
	    Perl_croak_nocontext("panic: MUTEX_INIT");		\
    } STMT_END
#  else
#    define MUTEX_INIT(m) \
    STMT_START {						\
	if (pthread_mutex_init((m), pthread_mutexattr_default))	\
	    Perl_croak_nocontext("panic: MUTEX_INIT");		\
    } STMT_END
#  endif

#  define MUTEX_LOCK(m) \
    STMT_START {						\
	if (pthread_mutex_lock((m)))				\
	    Perl_croak_nocontext("panic: MUTEX_LOCK");		\
    } STMT_END

#  define MUTEX_UNLOCK(m) \
    STMT_START {						\
	if (pthread_mutex_unlock((m)))				\
	    Perl_croak_nocontext("panic: MUTEX_UNLOCK");	\
    } STMT_END

#  define MUTEX_DESTROY(m) \
    STMT_START {						\
	if (pthread_mutex_destroy((m)))				\
	    Perl_croak_nocontext("panic: MUTEX_DESTROY");	\
    } STMT_END
#endif /* MUTEX_INIT */

#ifndef COND_INIT
#  define COND_INIT(c) \
    STMT_START {						\
	if (pthread_cond_init((c), pthread_condattr_default))	\
	    Perl_croak_nocontext("panic: COND_INIT");		\
    } STMT_END

#  define COND_SIGNAL(c) \
    STMT_START {						\
	if (pthread_cond_signal((c)))				\
	    Perl_croak_nocontext("panic: COND_SIGNAL");		\
    } STMT_END

#  define COND_BROADCAST(c) \
    STMT_START {						\
	if (pthread_cond_broadcast((c)))			\
	    Perl_croak_nocontext("panic: COND_BROADCAST");	\
    } STMT_END

#  define COND_WAIT(c, m) \
    STMT_START {						\
	if (pthread_cond_wait((c), (m)))			\
	    Perl_croak_nocontext("panic: COND_WAIT");		\
    } STMT_END

#  define COND_DESTROY(c) \
    STMT_START {						\
	if (pthread_cond_destroy((c)))				\
	    Perl_croak_nocontext("panic: COND_DESTROY");	\
    } STMT_END
#endif /* COND_INIT */

/* DETACH(t) must only be called while holding t->mutex */
#ifndef DETACH
#  define DETACH(t) \
    STMT_START {						\
	if (pthread_detach((t)->self)) {			\
	    MUTEX_UNLOCK(&(t)->mutex);				\
	    Perl_croak_nocontext("panic: DETACH");		\
	}							\
    } STMT_END
#endif /* DETACH */

#ifndef JOIN
#  define JOIN(t, avp) \
    STMT_START {						\
	if (pthread_join((t)->self, (void**)(avp)))		\
	    Perl_croak_nocontext("panic: pthread_join");	\
    } STMT_END
#endif /* JOIN */

/* Use an unchecked fetch of thread-specific data instead of a checked one.
 * It would fail if the key were bogus, but if the key were bogus then
 * Really Bad Things would be happening anyway. --dan */
#if (defined(__ALPHA) && (__VMS_VER >= 70000000)) || \
    (defined(__alpha) && defined(__osf__)) /* Available only on >= 4.0 */
#  define HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP /* Configure test needed */
#endif

#ifdef HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP
#  define PTHREAD_GETSPECIFIC(key) pthread_unchecked_getspecific_np(key)
#else
#  define PTHREAD_GETSPECIFIC(key) pthread_getspecific(key)
#endif

#ifndef PERL_GET_CONTEXT
#  define PERL_GET_CONTEXT	PTHREAD_GETSPECIFIC(PL_thr_key)
#endif

#ifndef PERL_SET_CONTEXT
#  define PERL_SET_CONTEXT(t) \
    STMT_START {						\
	if (pthread_setspecific(PL_thr_key, (void *)(t)))	\
	    Perl_croak_nocontext("panic: pthread_setspecific");	\
    } STMT_END
#endif /* PERL_SET_CONTEXT */

#ifndef INIT_THREADS
#  ifdef NEED_PTHREAD_INIT
#    define INIT_THREADS pthread_init()
#  endif
#endif

#ifndef ALLOC_THREAD_KEY
#  define ALLOC_THREAD_KEY \
    STMT_START {						\
	if (pthread_key_create(&PL_thr_key, 0))	{		\
	    PerlIO_printf(PerlIO_stderr(), "panic: pthread_key_create");	\
	    exit(1);						\
	}							\
    } STMT_END
#endif

#ifndef FREE_THREAD_KEY
#  define FREE_THREAD_KEY \
    STMT_START {						\
	pthread_key_delete(PL_thr_key);				\
    } STMT_END
#endif

#ifndef PTHREAD_ATFORK
#  ifdef HAS_PTHREAD_ATFORK
#    define PTHREAD_ATFORK(prepare,parent,child)		\
	pthread_atfork(prepare,parent,child)
#  else
#    define PTHREAD_ATFORK(prepare,parent,child)		\
	NOOP
#  endif
#endif

#ifndef THREAD_RET_TYPE
#  define THREAD_RET_TYPE	void *
#  define THREAD_RET_CAST(p)	((void *)(p))
#endif /* THREAD_RET */

#if defined(USE_5005THREADS)

/* Accessor for per-thread SVs */
#  define THREADSV(i) (thr->threadsvp[i])

/*
 * LOCK_SV_MUTEX and UNLOCK_SV_MUTEX are performance-critical. Here, we
 * try only locking them if there may be more than one thread in existence.
 * Systems with very fast mutexes (and/or slow conditionals) may wish to
 * remove the "if (threadnum) ..." test.
 * XXX do NOT use C<if (PL_threadnum) ...> -- it sets up race conditions!
 */
#  define LOCK_SV_MUTEX		MUTEX_LOCK(&PL_sv_mutex)
#  define UNLOCK_SV_MUTEX	MUTEX_UNLOCK(&PL_sv_mutex)
#  define LOCK_STRTAB_MUTEX	MUTEX_LOCK(&PL_strtab_mutex)
#  define UNLOCK_STRTAB_MUTEX	MUTEX_UNLOCK(&PL_strtab_mutex)
#  define LOCK_CRED_MUTEX	MUTEX_LOCK(&PL_cred_mutex)
#  define UNLOCK_CRED_MUTEX	MUTEX_UNLOCK(&PL_cred_mutex)
#  define LOCK_FDPID_MUTEX	MUTEX_LOCK(&PL_fdpid_mutex)
#  define UNLOCK_FDPID_MUTEX	MUTEX_UNLOCK(&PL_fdpid_mutex)
#  define LOCK_SV_LOCK_MUTEX	MUTEX_LOCK(&PL_sv_lock_mutex)
#  define UNLOCK_SV_LOCK_MUTEX	MUTEX_UNLOCK(&PL_sv_lock_mutex)

/* Values and macros for thr->flags */
#define THRf_STATE_MASK	7
#define THRf_R_JOINABLE	0
#define THRf_R_JOINED	1
#define THRf_R_DETACHED	2
#define THRf_ZOMBIE	3
#define THRf_DEAD	4

#define THRf_DID_DIE	8

/* ThrSTATE(t) and ThrSETSTATE(t) must only be called while holding t->mutex */
#define ThrSTATE(t) ((t)->flags & THRf_STATE_MASK)
#define ThrSETSTATE(t, s) STMT_START {		\
	(t)->flags &= ~THRf_STATE_MASK;		\
	(t)->flags |= (s);			\
	DEBUG_S(PerlIO_printf(Perl_debug_log,	\
			      "thread %p set to state %d\n", (t), (s))); \
    } STMT_END

typedef struct condpair {
    perl_mutex	mutex;		/* Protects all other fields */
    perl_cond	owner_cond;	/* For when owner changes at all */
    perl_cond	cond;		/* For cond_signal and cond_broadcast */
    Thread	owner;		/* Currently owning thread */
} condpair_t;

#define MgMUTEXP(mg) (&((condpair_t *)(mg->mg_ptr))->mutex)
#define MgOWNERCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->owner_cond)
#define MgCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->cond)
#define MgOWNER(mg) ((condpair_t *)(mg->mg_ptr))->owner

#endif /* USE_5005THREADS */
#endif /* USE_5005THREADS || USE_ITHREADS */

#ifndef MUTEX_LOCK
#  define MUTEX_LOCK(m)
#endif

#ifndef MUTEX_UNLOCK
#  define MUTEX_UNLOCK(m)
#endif

#ifndef MUTEX_INIT
#  define MUTEX_INIT(m)
#endif

#ifndef MUTEX_DESTROY
#  define MUTEX_DESTROY(m)
#endif

#ifndef COND_INIT
#  define COND_INIT(c)
#endif

#ifndef COND_SIGNAL
#  define COND_SIGNAL(c)
#endif

#ifndef COND_BROADCAST
#  define COND_BROADCAST(c)
#endif

#ifndef COND_WAIT
#  define COND_WAIT(c, m)
#endif

#ifndef COND_DESTROY
#  define COND_DESTROY(c)
#endif

#ifndef LOCK_SV_MUTEX
#  define LOCK_SV_MUTEX
#endif

#ifndef UNLOCK_SV_MUTEX
#  define UNLOCK_SV_MUTEX
#endif

#ifndef LOCK_STRTAB_MUTEX
#  define LOCK_STRTAB_MUTEX
#endif

#ifndef UNLOCK_STRTAB_MUTEX
#  define UNLOCK_STRTAB_MUTEX
#endif

#ifndef LOCK_CRED_MUTEX
#  define LOCK_CRED_MUTEX
#endif

#ifndef UNLOCK_CRED_MUTEX
#  define UNLOCK_CRED_MUTEX
#endif

#ifndef LOCK_FDPID_MUTEX
#  define LOCK_FDPID_MUTEX
#endif

#ifndef UNLOCK_FDPID_MUTEX
#  define UNLOCK_FDPID_MUTEX
#endif

#ifndef LOCK_SV_LOCK_MUTEX
#  define LOCK_SV_LOCK_MUTEX
#endif

#ifndef UNLOCK_SV_LOCK_MUTEX
#  define UNLOCK_SV_LOCK_MUTEX
#endif

/* THR, SET_THR, and dTHR are there for compatibility with old versions */
#ifndef THR
#  define THR		PERL_GET_THX
#endif

#ifndef SET_THR
#  define SET_THR(t)	PERL_SET_THX(t)
#endif

#ifndef dTHR
#  define dTHR dNOOP
#endif

#ifndef INIT_THREADS
#  define INIT_THREADS NOOP
#endif

By viewing downloads associated with this article you agree to the Terms of Service and the article's licence.

If a file you wish to view isn't highlighted, and is a text file (not binary), please let us know and we'll add colourisation support for it.

License

This article has no explicit license attached to it but may contain usage terms in the article text or the download files themselves. If in doubt please contact the author via the discussion board below.

A list of licenses authors might use can be found here

About the Author

PixiGreg
Software Developer
France France
Bouh

| Advertise | Privacy | Mobile
Web02 | 2.8.140718.1 | Last Updated 3 Nov 2004
Article Copyright 2003 by PixiGreg
Everything else Copyright © CodeProject, 1999-2014
Terms of Service
Layout: fixed | fluid