diff --git a/embed.fnc b/embed.fnc index 762f47f06c63..1e8249b5d3ca 100644 --- a/embed.fnc +++ b/embed.fnc @@ -6463,6 +6463,9 @@ Cp |int |do_spawn |NN char *cmd Cp |int |do_spawn_nowait|NN char *cmd #endif #if defined(WIN32) +TXpr |void |die_cbrod +TXpr |void |die_csig +TXpr |void |die_cwait CRTdp |void * |get_context p |bool |get_win32_message_utf8ness \ |NULLOK const char *string diff --git a/embed.h b/embed.h index 6cb789ce5e02..9c50988b6002 100644 --- a/embed.h +++ b/embed.h @@ -1767,6 +1767,9 @@ # define quadmath_format_valid Perl_quadmath_format_valid # endif # if defined(WIN32) +# define die_cbrod Perl_die_cbrod +# define die_csig Perl_die_csig +# define die_cwait Perl_die_cwait # define get_win32_message_utf8ness(a) Perl_get_win32_message_utf8ness(aTHX_ a) # else # define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c) diff --git a/proto.h b/proto.h index d648766b4898..167e6b1ec066 100644 --- a/proto.h +++ b/proto.h @@ -11028,6 +11028,21 @@ Perl_do_spawn_nowait(pTHX_ char *cmd); #endif /* defined(VMS) || defined(WIN32) */ #if defined(WIN32) +PERL_CALLCONV_NO_RET void +Perl_die_cbrod(void) + __attribute__noreturn__; +# define PERL_ARGS_ASSERT_DIE_CBROD + +PERL_CALLCONV_NO_RET void +Perl_die_csig(void) + __attribute__noreturn__; +# define PERL_ARGS_ASSERT_DIE_CSIG + +PERL_CALLCONV_NO_RET void +Perl_die_cwait(void) + __attribute__noreturn__; +# define PERL_ARGS_ASSERT_DIE_CWAIT + PERL_CALLCONV void * Perl_get_context(void) __attribute__warn_unused_result__; diff --git a/util.c b/util.c index b80050479671..2ff85650f53c 100644 --- a/util.c +++ b/util.c @@ -2004,6 +2004,47 @@ Perl_croak_popstack(void) my_exit(1); } + +/* Helpers for COND_BROADCAST(c), COND_SIGNAL(c), and COND_WAIT(c) macros + which are long and verbose, and get embedded directly in their callers + and have dozens of callsites inside libperl and certain categories of + CPAN XS modules. The other COND_*() macros are very unlikely to ever + be used outside of libperl's perl_construct()/perl_destruct(). + + The pthreads variants of COND_BROADCAST/COND_SIGNAL/COND_WAIT currently + have assert() style error strings that are too big to factor out. */ + +#ifdef WIN32 + +STATIC void +Perl_die_w32err(const char *context) +{ + DWORD e = GetLastError(); + Perl_croak_nocontext("panic: %s (%ld)", context, e); +} + +/* These 3 helpers prevent the same const C string literals appearing in many + .dll files over and over. */ +void +Perl_die_cbrod(void) +{ + Perl_die_w32err("COND_BROADCAST"); +} + +void +Perl_die_cwait(void) +{ + Perl_die_w32err("COND_WAIT"); +} + +void +Perl_die_csig(void) +{ + Perl_die_w32err("COND_SIGNAL"); +} + +#endif + /* =for apidoc warn_sv diff --git a/win32/win32thread.h b/win32/win32thread.h index da5f229b22e8..1131cb8576de 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -21,6 +21,10 @@ typedef CRITICAL_SECTION perl_mutex; #else +/* This backend is unused since + commit d55594aef6 - Gurusamy Sarathy - 11/9/1997 7:57:53 PM + Initial (untested) merge of all non-ansi changes on ansiperl branch */ + typedef HANDLE perl_mutex; # define MUTEX_INIT(m) \ STMT_START { \ @@ -46,7 +50,7 @@ typedef HANDLE perl_mutex; Perl_croak_nocontext("panic: MUTEX_DESTROY"); \ } STMT_END -#endif +#endif /* DONT_USE_CRITICAL_SECTION */ /* These macros assume that the mutex associated with the condition * will always be held before COND_{SIGNAL,BROADCAST,WAIT,DESTROY}, @@ -57,21 +61,21 @@ typedef HANDLE perl_mutex; (c)->waiters = 0; \ (c)->sem = Win_CreateSemaphore(NULL,0,LONG_MAX,NULL); \ if ((c)->sem == NULL) \ - Perl_croak_nocontext("panic: COND_INIT (%ld)",GetLastError()); \ + Perl_die_cwait(); \ } STMT_END #define COND_SIGNAL(c) \ STMT_START { \ if ((c)->waiters > 0 && \ ReleaseSemaphore((c)->sem,1,NULL) == 0) \ - Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",GetLastError()); \ + Perl_die_csig(); \ } STMT_END #define COND_BROADCAST(c) \ STMT_START { \ if ((c)->waiters > 0 && \ ReleaseSemaphore((c)->sem,(c)->waiters,NULL) == 0) \ - Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\ + Perl_die_cbrod();\ } STMT_END #define COND_WAIT(c, m) \ @@ -82,7 +86,7 @@ typedef HANDLE perl_mutex; * COND_BROADCAST() on another thread will have seen the\ * right number of waiters (i.e. including this one) */ \ if (WaitForSingleObject((c)->sem,INFINITE)==WAIT_FAILED)\ - Perl_croak_nocontext("panic: COND_WAIT (%ld)",GetLastError()); \ + Perl_die_cwait(); \ /* XXX there may be an inconsequential race here */ \ MUTEX_LOCK(m); \ (c)->waiters--; \