diff options
| -rwxr-xr-x | Configure | 13 | ||||
| -rw-r--r-- | Makefile.SH | 4 | ||||
| -rw-r--r-- | embedvar.h | 6 | ||||
| -rwxr-xr-x | ext/threads/threads.xs | 4 | ||||
| -rw-r--r-- | intrpvar.h | 5 | ||||
| -rw-r--r-- | makedef.pl | 18 | ||||
| -rw-r--r-- | os2/Makefile.SHs | 1 | ||||
| -rw-r--r-- | os2/OS2/ExtAttr/Changes | 2 | ||||
| -rw-r--r-- | os2/OS2/ExtAttr/ExtAttr.pm | 17 | ||||
| -rw-r--r-- | os2/OS2/PrfDB/Changes | 1 | ||||
| -rw-r--r-- | os2/OS2/PrfDB/PrfDB.pm | 26 | ||||
| -rw-r--r-- | os2/OS2/REXX/DLL/DLL.pm | 6 | ||||
| -rw-r--r-- | os2/OS2/REXX/REXX.pm | 9 | ||||
| -rw-r--r-- | os2/dl_os2.c | 12 | ||||
| -rw-r--r-- | os2/os2.c | 417 | ||||
| -rw-r--r-- | os2/os2ish.h | 116 | ||||
| -rw-r--r-- | os2/os2thread.h | 1 | ||||
| -rw-r--r-- | perlapi.h | 6 | ||||
| -rw-r--r-- | perlio.c | 2 | ||||
| -rw-r--r-- | perlvars.h | 3 | ||||
| -rw-r--r-- | reentr.c | 2 | ||||
| -rw-r--r-- | reentr.pl | 2 | ||||
| -rw-r--r-- | sv.c | 2 |
23 files changed, 605 insertions, 70 deletions
@@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Tue Mar 18 09:54:18 EET 2003 [metaconfig 3.0 PL70] +# Generated on Tue Apr 1 20:39:33 EET DST 2003 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <<EOF @@ -71,11 +71,12 @@ esac : Proper separator for the PATH environment variable p_=: : On OS/2 this directory should exist if this is not floppy only system :-] -if test -d c:/. ; then +if test -d c:/. || ( uname -a | grep -i 'os\(/\|\)2' ) 2>&1 >/dev/null ; then if test -n "$OS2_SHELL"; then p_=\; PATH=`cmd /c "echo %PATH%" | tr '\\\\' / ` OS2_SHELL=`cmd /c "echo %OS2_SHELL%" | tr '\\\\' / | tr '[A-Z]' '[a-z]'` + is_os2=yes elif test -n "$DJGPP"; then case "X${MACHTYPE:-nonesuchmach}" in *cygwin) ;; @@ -1195,7 +1196,7 @@ elif test -f "/system/gnu_library/bin/ar.pm"; then elif test -n "$DJGPP"; then : DOS DJGPP _exe=".exe" -elif test -d c:/. ; then +elif test -d c:/. -o -n "$is_os2" ; then : OS/2 or cygwin _exe=".exe" fi @@ -3137,6 +3138,9 @@ EOM openbsd) osname=openbsd osvers="$3" ;; + os2) osname=os2 + osvers="$4" + ;; POSIX-BC | posix-bc ) osname=posix-bc osvers="$3" ;; @@ -3255,7 +3259,7 @@ EOM osname=news_os fi $rm -f UU/kernel.what - elif test -d c:/.; then + elif test -d c:/. -o -n "$is_os2" ; then set X $myuname osname=os2 osvers="$5" @@ -4978,6 +4982,7 @@ echo "Your cpp writes the filename in the $pos field of the line." case "$osname" in vos) cppfilter="tr '\\\\>' '/' |" ;; # path component separator is > +os2) cppfilter="sed -e 's|\\\\\\\\|/|g' |" ;; # path component separator is \ *) cppfilter='' ;; esac : locate header file diff --git a/Makefile.SH b/Makefile.SH index 9fa3257f60..63e3176a95 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -457,7 +457,7 @@ PERLEXPORT = perl.exp esac $spitshell >>Makefile <<'!NO!SUBS!' perl.exp: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH) - ./$(MINIPERLEXP) makedef.pl PLATFORM=aix | sort -u | sort -f > perl.exp.tmp + ./$(MINIPERLEXP) makedef.pl PLATFORM=aix CC_FLAGS="$(OPTIMIZE)" | sort -u | sort -f > perl.exp.tmp sh mv-if-diff perl.exp.tmp perl.exp !NO!SUBS! @@ -467,7 +467,7 @@ os2) MINIPERLEXP = miniperl perl5.def: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH) miniperl.map - ./$(MINIPERLEXP) makedef.pl PLATFORM=os2 -DPERL_DLL=$(PERL_DLL) > perl.exp.tmp + ./$(MINIPERLEXP) makedef.pl PLATFORM=os2 -DPERL_DLL=$(PERL_DLL) CC_FLAGS="$(OPTIMIZE)" > perl.exp.tmp sh mv-if-diff perl.exp.tmp perl5.def !NO!SUBS! diff --git a/embedvar.h b/embedvar.h index fd198e0f98..6e1d615974 100644 --- a/embedvar.h +++ b/embedvar.h @@ -366,7 +366,7 @@ #define PL_runops (vTHX->Irunops) #define PL_savebegin (vTHX->Isavebegin) #define PL_sawampersand (vTHX->Isawampersand) -#define PL_sh_path (vTHX->Ish_path) +#define PL_sh_path_compat (vTHX->Ish_path_compat) #define PL_sig_pending (vTHX->Isig_pending) #define PL_sighandlerp (vTHX->Isighandlerp) #define PL_signals (vTHX->Isignals) @@ -658,7 +658,7 @@ #define PL_Irunops PL_runops #define PL_Isavebegin PL_savebegin #define PL_Isawampersand PL_sawampersand -#define PL_Ish_path PL_sh_path +#define PL_Ish_path_compat PL_sh_path_compat #define PL_Isig_pending PL_sig_pending #define PL_Isighandlerp PL_sighandlerp #define PL_Isignals PL_signals @@ -883,6 +883,7 @@ #define PL_ppid (PL_Vars.Gppid) #define PL_runops_dbg (PL_Vars.Grunops_dbg) #define PL_runops_std (PL_Vars.Grunops_std) +#define PL_sh_path (PL_Vars.Gsh_path) #define PL_sharehook (PL_Vars.Gsharehook) #define PL_thr_key (PL_Vars.Gthr_key) #define PL_threadhook (PL_Vars.Gthreadhook) @@ -903,6 +904,7 @@ #define PL_Gppid PL_ppid #define PL_Grunops_dbg PL_runops_dbg #define PL_Grunops_std PL_runops_std +#define PL_Gsh_path PL_sh_path #define PL_Gsharehook PL_sharehook #define PL_Gthr_key PL_thr_key #define PL_Gthreadhook PL_threadhook diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 68cb699ff9..00d18ba917 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -18,7 +18,11 @@ STMT_START {\ }\ } STMT_END #else +#ifdef OS2 +typedef perl_os_thread pthread_t; +#else #include <pthread.h> +#endif #include <thread.h> #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) diff --git a/intrpvar.h b/intrpvar.h index eb7d0da143..61d48a2988 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -242,7 +242,10 @@ PERLVAR(Iorigalen, U32) PERLVAR(Ipidstatus, HV *) /* pid-to-status mappings for waitpid */ PERLVARI(Imaxo, int, MAXO) /* maximum number of ops */ PERLVAR(Iosname, char *) /* operating system */ -PERLVARI(Ish_path, char *, SH_PATH)/* full path of shell */ + +/* For binary compatibility with older versions only */ +PERLVARI(Ish_path_compat, char *, SH_PATH)/* full path of shell */ + PERLVAR(Isighandlerp, Sighandler_t) PERLVAR(Ixiv_arenaroot, XPV*) /* list of allocated xiv areas */ diff --git a/makedef.pl b/makedef.pl index ef84c18796..b075eb41db 100644 --- a/makedef.pl +++ b/makedef.pl @@ -6,13 +6,20 @@ # and by MacOS Classic. # # reads global.sym, pp.sym, perlvars.h, intrpvar.h, thrdvar.h, config.h -# On OS/2 reads miniperl.map as well +# On OS/2 reads miniperl.map and the previous version of perl5.def as well my $PLATFORM; my $CCTYPE; while (@ARGV) { my $flag = shift; + if ($flag =~ s/^CC_FLAGS=/ /) { + for my $fflag ($flag =~ /(?:^|\s)-D(\S+)/g) { + $fflag .= '=1' unless $fflag =~ /^(\w+)=/; + $define{$1} = $2 if $fflag =~ /^(\w+)=(.+)$/; + } + next; + } $define{$1} = 1 if ($flag =~ /^-D(\w+)$/); $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/); $CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/); @@ -417,7 +424,14 @@ elsif ($PLATFORM eq 'os2') { os2error ResetWinError CroakWinError + PL_do_undump )]); + emit_symbols([qw(os2_cond_wait + pthread_join + pthread_create + pthread_detach + )]) + if $define{'USE_5005THREADS'} or $define{'USE_ITHREADS'}; } elsif ($PLATFORM eq 'MacOS') { skip_symbols [qw( @@ -947,7 +961,7 @@ if ($define{'MULTIPLICITY'}) { emit_symbols $glob; } # XXX AIX seems to want the perlvars.h symbols, for some reason - if ($PLATFORM eq 'aix') { + if ($PLATFORM eq 'aix' or $PLATFORM eq 'os2') { # OS/2 needs PL_thr_key my $glob = readvar($perlvars_h); emit_symbols $glob; } diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index ba3744457f..baefec987f 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -27,7 +27,6 @@ $spitshell >>Makefile <<!GROK!THIS! PERL_FULLVERSION = $perl_fullversion -OPTIMIZE = $optimize AOUT_OPTIMIZE = \$(OPTIMIZE) AOUT_CCCMD = \$(CC) -DPERL_CORE $aout_ccflags \$(AOUT_OPTIMIZE) AOUT_AR = $aout_ar diff --git a/os2/OS2/ExtAttr/Changes b/os2/OS2/ExtAttr/Changes index 55fdc5f6d5..92b51826cc 100644 --- a/os2/OS2/ExtAttr/Changes +++ b/os2/OS2/ExtAttr/Changes @@ -3,3 +3,5 @@ Revision history for Perl extension OS2::ExtAttr. 0.01 Sun Apr 21 11:07:04 1996 - original version; created by h2xs 1.16 +0.02 Update to XSLoader and 'our'. + Remove Exporter. diff --git a/os2/OS2/ExtAttr/ExtAttr.pm b/os2/OS2/ExtAttr/ExtAttr.pm index bebbcc963e..c49f1d4de5 100644 --- a/os2/OS2/ExtAttr/ExtAttr.pm +++ b/os2/OS2/ExtAttr/ExtAttr.pm @@ -1,21 +1,10 @@ package OS2::ExtAttr; use strict; -use vars qw($VERSION @ISA @EXPORT); +use XSLoader; -require Exporter; -require DynaLoader; - -@ISA = qw(Exporter DynaLoader); -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. -@EXPORT = qw( - -); -$VERSION = '0.01'; - -bootstrap OS2::ExtAttr $VERSION; +our $VERSION = '0.02'; +XSLoader::load 'OS2::ExtAttr', $VERSION; # Preloaded methods go here. diff --git a/os2/OS2/PrfDB/Changes b/os2/OS2/PrfDB/Changes index 3e8bf3f580..49ac8c1a43 100644 --- a/os2/OS2/PrfDB/Changes +++ b/os2/OS2/PrfDB/Changes @@ -3,3 +3,4 @@ Revision history for Perl extension OS2::PrfDB. 0.01 Tue Mar 26 19:35:27 1996 - original version; created by h2xs 1.16 0.02: Field do-not-close added to OS2::Prf::Hini. +0.03: Update to XSLoader and 'our'. diff --git a/os2/OS2/PrfDB/PrfDB.pm b/os2/OS2/PrfDB/PrfDB.pm index 41d7dba2f1..328f4dcd5d 100644 --- a/os2/OS2/PrfDB/PrfDB.pm +++ b/os2/OS2/PrfDB/PrfDB.pm @@ -1,21 +1,22 @@ package OS2::PrfDB; use strict; -use vars qw($VERSION @ISA @EXPORT); require Exporter; -require DynaLoader; +use XSLoader; +use Tie::Hash; -@ISA = qw(Exporter DynaLoader); +our $debug; +our @ISA = qw(Exporter Tie::Hash); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. -@EXPORT = qw( - AnyIni UserIni SystemIni - ); -$VERSION = '0.02'; +our @EXPORT = qw( + AnyIni UserIni SystemIni + ); +our $VERSION = '0.03'; -bootstrap OS2::PrfDB $VERSION; +XSLoader::load 'OS2::PrfDB', $VERSION; # Preloaded methods go here. @@ -32,10 +33,6 @@ sub SystemIni { new_from_int OS2::PrfDB::Hini OS2::Prf::System(2),'System settings database',1; } -use vars qw{$debug @ISA}; -use Tie::Hash; -push @ISA, qw{Tie::Hash}; - # Internal structure 0 => HINI, 1 => array of entries, 2 => iterator. sub TIEHASH { @@ -127,9 +124,10 @@ sub DESTROY { } package OS2::PrfDB::Sub; -use vars qw{$debug @ISA}; use Tie::Hash; -@ISA = qw{Tie::Hash}; + +our $debug; +our @ISA = qw{Tie::Hash}; # Internal structure 0 => HINI, 1 => array of entries, 2 => iterator, # 3 => appname. diff --git a/os2/OS2/REXX/DLL/DLL.pm b/os2/OS2/REXX/DLL/DLL.pm index f9be9e433c..09e3e37a08 100644 --- a/os2/OS2/REXX/DLL/DLL.pm +++ b/os2/OS2/REXX/DLL/DLL.pm @@ -3,9 +3,7 @@ package OS2::DLL; our $VERSION = '1.00'; use Carp; -use DynaLoader; - -@ISA = qw(DynaLoader); +use XSLoader; sub AUTOLOAD { $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/ @@ -86,7 +84,7 @@ EOE return 1; } -bootstrap OS2::DLL; +XSLoader::load 'OS2::DLL'; 1; __END__ diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm index 57e6d6d1a4..88b624f233 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -1,18 +1,17 @@ package OS2::REXX; -use Carp; require Exporter; -require DynaLoader; +use XSLoader; require OS2::DLL; -@ISA = qw(Exporter DynaLoader); +@ISA = qw(Exporter); # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @EXPORT = qw(REXX_call REXX_eval REXX_eval_with); # Other items we are prepared to export if requested @EXPORT_OK = qw(drop register); -$VERSION = '1.01'; +$VERSION = '1.02'; # We cannot just put OS2::DLL in @ISA, since some scripts would use # function interface, not method interface... @@ -21,7 +20,7 @@ $VERSION = '1.01'; *load = \&OS2::DLL::load; *find = \&OS2::DLL::find; -bootstrap OS2::REXX; +XSLoader::load 'OS2::REXX'; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. diff --git a/os2/dl_os2.c b/os2/dl_os2.c index 5c8b6e6871..b698451b08 100644 --- a/os2/dl_os2.c +++ b/os2/dl_os2.c @@ -8,13 +8,23 @@ static ULONG retcode; static char fail[300]; +#ifdef PERL_CORE + +#include "EXTERN.h" +#include "perl.h" + +#else + char *os2error(int rc); +#endif + void * dlopen(const char *path, int mode) { HMODULE handle; - char tmp[260], *beg, *dot; + char tmp[260]; + const char *beg, *dot; ULONG rc; fail[0] = 0; @@ -9,6 +9,7 @@ #define SPU_ENABLESUPPRESSION 1 #include <os2.h> #include "dlfcn.h" +#include <emx/syscalls.h> #include <sys/uflags.h> @@ -29,6 +30,292 @@ #include "EXTERN.h" #include "perl.h" +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + +typedef void (*emx_startroutine)(void *); +typedef void* (*pthreads_startroutine)(void *); + +enum pthreads_state { + pthreads_st_none = 0, + pthreads_st_run, + pthreads_st_exited, + pthreads_st_detached, + pthreads_st_waited, + pthreads_st_norun, + pthreads_st_exited_waited, +}; +const char *pthreads_states[] = { + "uninit", + "running", + "exited", + "detached", + "waited for", + "could not start", + "exited, then waited on", +}; + +enum pthread_exists { pthread_not_existant = -0xff }; + +static const char* +pthreads_state_string(enum pthreads_state state) +{ + if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) { + static char buf[80]; + + snprintf(buf, sizeof(buf), "unknown thread state %d", (int)state); + return buf; + } + return pthreads_states[state]; +} + +typedef struct { + void *status; + perl_cond cond; + enum pthreads_state state; +} thread_join_t; + +thread_join_t *thread_join_data; +int thread_join_count; +perl_mutex start_thread_mutex; + +int +pthread_join(perl_os_thread tid, void **status) +{ + MUTEX_LOCK(&start_thread_mutex); + if (tid < 1 || tid >= thread_join_count) { + MUTEX_UNLOCK(&start_thread_mutex); + if (tid != pthread_not_existant) + Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid); + Perl_warn_nocontext("panic: join with a thread which could not start"); + *status = 0; + return 0; + } + switch (thread_join_data[tid].state) { + case pthreads_st_exited: + thread_join_data[tid].state = pthreads_st_exited_waited; + *status = thread_join_data[tid].status; + MUTEX_UNLOCK(&start_thread_mutex); + COND_SIGNAL(&thread_join_data[tid].cond); + break; + case pthreads_st_waited: + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("join with a thread with a waiter"); + break; + case pthreads_st_norun: + { + int state = (int)thread_join_data[tid].status; + + thread_join_data[tid].state = pthreads_st_none; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: join with a thread which could not run" + " due to attempt of tid reuse (state='%s')", + pthreads_state_string(state)); + break; + } + case pthreads_st_run: + { + perl_cond cond; + + thread_join_data[tid].state = pthreads_st_waited; + thread_join_data[tid].status = (void *)status; + COND_INIT(&thread_join_data[tid].cond); + cond = thread_join_data[tid].cond; + COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); + COND_DESTROY(&cond); + MUTEX_UNLOCK(&start_thread_mutex); + break; + } + default: + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'", + pthreads_state_string(thread_join_data[tid].state)); + break; + } + return 0; +} + +typedef struct { + pthreads_startroutine sub; + void *arg; + void *ctx; +} pthr_startit; + +/* The lock is used: + a) Since we temporarily usurp the caller interp, so malloc() may + use it to decide on debugging the call; + b) Since *args is on the caller's stack. + */ +void +pthread_startit(void *arg1) +{ + /* Thread is already started, we need to transfer control only */ + pthr_startit args = *(pthr_startit *)arg1; + int tid = pthread_self(); + void *rc; + int state; + + if (tid <= 1) { + /* Can't croak, the setjmp() is not in scope... */ + char buf[80]; + + snprintf(buf, sizeof(buf), + "panic: thread with strange ordinal %d created\n\r", tid); + write(2,buf,strlen(buf)); + MUTEX_UNLOCK(&start_thread_mutex); + return; + } + /* Until args.sub resets it, makes debugging Perl_malloc() work: */ + PERL_SET_CONTEXT(0); + if (tid >= thread_join_count) { + int oc = thread_join_count; + + thread_join_count = tid + 5 + tid/5; + if (thread_join_data) { + Renew(thread_join_data, thread_join_count, thread_join_t); + Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); + } else { + Newz(1323, thread_join_data, thread_join_count, thread_join_t); + } + } + if (thread_join_data[tid].state != pthreads_st_none) { + /* Can't croak, the setjmp() is not in scope... */ + char buf[80]; + + snprintf(buf, sizeof(buf), + "panic: attempt to reuse thread id %d (state='%s')\n\r", + tid, pthreads_state_string(thread_join_data[tid].state)); + write(2,buf,strlen(buf)); + thread_join_data[tid].status = (void*)thread_join_data[tid].state; + thread_join_data[tid].state = pthreads_st_norun; + MUTEX_UNLOCK(&start_thread_mutex); + return; + } + thread_join_data[tid].state = pthreads_st_run; + /* Now that we copied/updated the guys, we may release the caller... */ + MUTEX_UNLOCK(&start_thread_mutex); + rc = (*args.sub)(args.arg); + MUTEX_LOCK(&start_thread_mutex); + switch (thread_join_data[tid].state) { + case pthreads_st_waited: + COND_SIGNAL(&thread_join_data[tid].cond); + thread_join_data[tid].state = pthreads_st_none; + *((void**)thread_join_data[tid].status) = rc; + break; + case pthreads_st_detached: + thread_join_data[tid].state = pthreads_st_none; + break; + case pthreads_st_run: + /* Somebody can wait on us; cannot exit, since OS can reuse the tid + and our waiter will get somebody else's status. */ + thread_join_data[tid].state = pthreads_st_exited; + thread_join_data[tid].status = rc; + COND_INIT(&thread_join_data[tid].cond); + COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); + COND_DESTROY(&thread_join_data[tid].cond); + thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ + break; + default: + state = thread_join_data[tid].state; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'", + pthreads_state_string(state)); + } + MUTEX_UNLOCK(&start_thread_mutex); +} + +int +pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr, + void *(*start_routine)(void*), void *arg) +{ + dTHX; + pthr_startit args; + + args.sub = (void*)start_routine; + args.arg = arg; + args.ctx = PERL_GET_CONTEXT; + + MUTEX_LOCK(&start_thread_mutex); + /* Test suite creates 31 extra threads; + on machine without shared-memory-hogs this stack sizeis OK with 31: */ + *tidp = _beginthread(pthread_startit, /*stack*/ NULL, + /*stacksize*/ 4*1024*1024, (void*)&args); + if (*tidp == -1) { + *tidp = pthread_not_existant; + MUTEX_UNLOCK(&start_thread_mutex); + return EINVAL; + } + MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */ + MUTEX_UNLOCK(&start_thread_mutex); + return 0; +} + +int +pthread_detach(perl_os_thread tid) +{ + MUTEX_LOCK(&start_thread_mutex); + if (tid < 1 || tid >= thread_join_count) { + MUTEX_UNLOCK(&start_thread_mutex); + if (tid != pthread_not_existant) + Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid); + Perl_warn_nocontext("detach of a thread which could not start"); + return 0; + } + switch (thread_join_data[tid].state) { + case pthreads_st_waited: + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("detach on a thread with a waiter"); + break; + case pthreads_st_run: + thread_join_data[tid].state = pthreads_st_detached; + MUTEX_UNLOCK(&start_thread_mutex); + break; + case pthreads_st_exited: + MUTEX_UNLOCK(&start_thread_mutex); + COND_SIGNAL(&thread_join_data[tid].cond); + break; + case pthreads_st_detached: + MUTEX_UNLOCK(&start_thread_mutex); + Perl_warn_nocontext("detach on an already detached thread"); + break; + case pthreads_st_norun: + { + int state = (int)thread_join_data[tid].status; + + thread_join_data[tid].state = pthreads_st_none; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: detaching thread which could not run" + " due to attempt of tid reuse (state='%s')", + pthreads_state_string(state)); + break; + } + default: + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'", + pthreads_state_string(thread_join_data[tid].state)); + break; + } + return 0; +} + +/* This is a very bastardized version; may be OK due to edge trigger of Wait */ +int +os2_cond_wait(perl_cond *c, perl_mutex *m) +{ + int rc; + STRLEN n_a; + if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) + Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc); + if (m) MUTEX_UNLOCK(m); + if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) + && (rc != ERROR_INTERRUPT)) + Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc); + if (rc == ERROR_INTERRUPT) + errno = EINTR; + if (m) MUTEX_LOCK(m); + return 0; +} +#endif + static int exe_is_aout(void); /*****************************************************************************/ @@ -1125,17 +1412,51 @@ int setgid(x) { errno = EINVAL; return -1; } #if OS2_STAT_HACK +enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */ + os2_stat_archived = 0x1000000, /* 0100000000 */ + os2_stat_hidden = 0x2000000, /* 0200000000 */ + os2_stat_system = 0x4000000, /* 0400000000 */ + os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */ +}; + +#define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden) + +static void +massage_os2_attr(struct stat *st) +{ + if ( ((st->st_mode & S_IFMT) != S_IFREG + && (st->st_mode & S_IFMT) != S_IFDIR) + || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM))) + return; + + if ( st->st_attr & FILE_ARCHIVED ) + st->st_mode |= (os2_stat_archived | os2_stat_force); + if ( st->st_attr & FILE_HIDDEN ) + st->st_mode |= (os2_stat_hidden | os2_stat_force); + if ( st->st_attr & FILE_SYSTEM ) + st->st_mode |= (os2_stat_system | os2_stat_force); +} + /* First attempt used DosQueryFSAttach which crashed the system when used with 5.001. Now just look for /dev/. */ - int os2_stat(const char *name, struct stat *st) { static int ino = SHRT_MAX; - - if (stricmp(name, "/dev/con") != 0 - && stricmp(name, "/dev/tty") != 0) - return stat(name, st); + STRLEN l = strlen(name); + + if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0 + || ( stricmp(name + 5, "con") != 0 + && stricmp(name + 5, "tty") != 0 + && stricmp(name + 5, "nul") != 0 + && stricmp(name + 5, "null") != 0) ) { + int s = stat(name, st); + + if (s) + return s; + massage_os2_attr(st); + return 0; + } memset(st, 0, sizeof *st); st->st_mode = S_IFCHR|0666; @@ -1144,6 +1465,48 @@ os2_stat(const char *name, struct stat *st) return 0; } +int +os2_fstat(int handle, struct stat *st) +{ + int s = fstat(handle, st); + + if (s) + return s; + massage_os2_attr(st); + return 0; +} + +#undef chmod +int +os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */ +{ + int attr, rc; + + if (!(pmode & os2_stat_force)) + return chmod(name, pmode); + + attr = __chmod (name, 0, 0); /* Get attributes */ + if (attr < 0) + return -1; + if (pmode & S_IWRITE) + attr &= ~FILE_READONLY; + else + attr |= FILE_READONLY; + /* New logic */ + attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM); + + if ( pmode & os2_stat_archived ) + attr |= FILE_ARCHIVED; + if ( pmode & os2_stat_hidden ) + attr |= FILE_HIDDEN; + if ( pmode & os2_stat_system ) + attr |= FILE_SYSTEM; + + rc = __chmod (name, 1, attr); + if (rc >= 0) rc = 0; + return rc; +} + #endif #ifdef USE_PERL_SBRK @@ -1288,6 +1651,7 @@ XS(XS_DynaLoader_mod2fname) char * os2error(int rc) { + dTHX; static char buf[300]; ULONG len; char *s; @@ -1334,8 +1698,11 @@ void CroakWinError(int die, char *name) { FillWinError; - if (die && Perl_rc) - croak("%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc)); + if (die && Perl_rc) { + dTHX; + + Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc)); + } } char * @@ -1443,6 +1810,7 @@ Perl_Register_MQ(int serve) /* 64 messages if before OS/2 3.0, ignored otherwise */ Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); if (!Perl_hmq) { + dTHX; static int cnt; SAVEINT(cnt); /* Allow catch()ing. */ @@ -2082,6 +2450,7 @@ enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full}; static SV* module_name_at(void *pp, enum module_name_how how) { + dTHX; char buf[MAXPATHLEN]; char *p = buf; HMODULE mod; @@ -2106,8 +2475,11 @@ module_name_at(void *pp, enum module_name_how how) static SV* module_name_of_cv(SV *cv, enum module_name_how how) { - if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) - croak("Not an XSUB reference"); + if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) { + dTHX; + + Perl_croak(aTHX_ "Not an XSUB reference"); + } return module_name_at(CvXSUB(SvRV(cv)), how); } @@ -2145,7 +2517,7 @@ XS(XS_OS2__control87) { dXSARGS; if (items != 2) - croak("Usage: OS2::_control87(new,mask)"); + Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)"); { unsigned new = (unsigned)SvIV(ST(0)); unsigned mask = (unsigned)SvIV(ST(1)); @@ -2162,7 +2534,7 @@ XS(XS_OS2_get_control87) { dXSARGS; if (items != 0) - croak("Usage: OS2::get_control87()"); + Perl_croak(aTHX_ "Usage: OS2::get_control87()"); { unsigned RETVAL; @@ -2178,7 +2550,7 @@ XS(XS_OS2_set_control87) { dXSARGS; if (items < 0 || items > 2) - croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); + Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); { unsigned new; unsigned mask; @@ -2599,7 +2971,9 @@ Perl_OS2_init3(char **env, void **preg, int flags) if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; } } +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) MUTEX_INIT(&start_thread_mutex); +#endif os2_mytype = my_type(); /* Do it before morphing. Needed? */ /* Some DLLs reset FP flags on load. We may have been linked with them */ _control87(MCW_EM, MCW_EM); @@ -2911,3 +3285,22 @@ gcvt_os2 (double value, int digits, char *buffer) { return gcvt (value, digits, buffer); } + +#undef fork +int fork_with_resources() +{ +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC) + dTHX; + void *ctx = PERL_GET_CONTEXT; +#endif + + int rc = fork(); + +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC) + if (rc == 0) { /* child */ + ALLOC_THREAD_KEY; /* Acquire the thread-local memory */ + PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */ + } +#endif + return rc; +} diff --git a/os2/os2ish.h b/os2/os2ish.h index 20e413a837..c6baad554a 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -99,6 +99,111 @@ # undef I_SYS_UN #endif +#ifdef USE_ITHREADS + +#define do_spawn(a) os2_do_spawn(aTHX_ (a)) +#define do_aspawn(a,b,c) os2_do_aspawn(aTHX_ (a),(b),(c)) + +#define OS2_ERROR_ALREADY_POSTED 299 /* Avoid os2.h */ + +extern int rc; + +#define MUTEX_INIT(m) \ + STMT_START { \ + int rc; \ + if ((rc = _rmutex_create(m,0))) \ + Perl_croak_nocontext("panic: MUTEX_INIT: rc=%i", rc); \ + } STMT_END +#define MUTEX_LOCK(m) \ + STMT_START { \ + int rc; \ + if ((rc = _rmutex_request(m,_FMR_IGNINT))) \ + Perl_croak_nocontext("panic: MUTEX_LOCK: rc=%i", rc); \ + } STMT_END +#define MUTEX_UNLOCK(m) \ + STMT_START { \ + int rc; \ + if ((rc = _rmutex_release(m))) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK: rc=%i", rc); \ + } STMT_END +#define MUTEX_DESTROY(m) \ + STMT_START { \ + int rc; \ + if ((rc = _rmutex_close(m))) \ + Perl_croak_nocontext("panic: MUTEX_DESTROY: rc=%i", rc); \ + } STMT_END + +#define COND_INIT(c) \ + STMT_START { \ + int rc; \ + if ((rc = DosCreateEventSem(NULL,c,0,0))) \ + Perl_croak_nocontext("panic: COND_INIT: rc=%i", rc); \ + } STMT_END +#define COND_SIGNAL(c) \ + STMT_START { \ + int rc; \ + if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ + Perl_croak_nocontext("panic: COND_SIGNAL, rc=%ld", rc); \ + } STMT_END +#define COND_BROADCAST(c) \ + STMT_START { \ + int rc; \ + if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ + Perl_croak_nocontext("panic: COND_BROADCAST, rc=%i", rc); \ + } STMT_END +/* #define COND_WAIT(c, m) \ + STMT_START { \ + if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \ + Perl_croak_nocontext("panic: COND_WAIT"); \ + } STMT_END +*/ +#define COND_WAIT(c, m) os2_cond_wait(c,m) + +#define COND_WAIT_win32(c, m) \ + STMT_START { \ + int rc; \ + if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE))) \ + Perl_croak_nocontext("panic: COND_WAIT"); \ + else \ + MUTEX_LOCK(m); \ + } STMT_END +#define COND_DESTROY(c) \ + STMT_START { \ + int rc; \ + if ((rc = DosCloseEventSem(*(c)))) \ + Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ + } STMT_END +/*#define THR ((struct thread *) TlsGetValue(PL_thr_key)) +*/ + +#ifdef USE_SLOW_THREAD_SPECIFIC +# define pthread_getspecific(k) (*_threadstore()) +# define pthread_setspecific(k,v) (*_threadstore()=v,0) +# define pthread_key_create(keyp,flag) (*keyp=_gettid(),0) +#else /* USE_SLOW_THREAD_SPECIFIC */ +# define pthread_getspecific(k) (*(k)) +# define pthread_setspecific(k,v) (*(k)=(v),0) +# define pthread_key_create(keyp,flag) \ + ( DosAllocThreadLocalMemory(1,(unsigned long**)keyp) \ + ? Perl_croak_nocontext("LocalMemory"),1 \ + : 0 \ + ) +#endif /* USE_SLOW_THREAD_SPECIFIC */ +#define pthread_key_delete(keyp) +#define pthread_self() _gettid() +#define YIELD DosSleep(0) + +#ifdef PTHREADS_INCLUDED /* For ./x2p stuff. */ +int pthread_join(pthread_t tid, void **status); +int pthread_detach(pthread_t tid); +int pthread_create(pthread_t *tid, const pthread_attr_t *attr, + void *(*start_routine)(void*), void *arg); +#endif /* PTHREAD_INCLUDED */ + +#define THREADS_ELSEWHERE + +#else /* USE_ITHREADS */ + #define do_spawn(a) os2_do_spawn(a) #define do_aspawn(a,b,c) os2_do_aspawn((a),(b),(c)) @@ -294,15 +399,19 @@ char *ctermid(char *s); #if OS2_STAT_HACK #define Stat(fname,bufptr) os2_stat((fname),(bufptr)) -#define Fstat(fd,bufptr) fstat((fd),(bufptr)) +#define Fstat(fd,bufptr) os2_fstat((fd),(bufptr)) #define Fflush(fp) fflush(fp) #define Mkdir(path,mode) mkdir((path),(mode)) +#define chmod(path,mode) os2_chmod((path),(mode)) #undef S_IFBLK #undef S_ISBLK -#define S_IFBLK 0120000 +#define S_IFBLK 0120000 /* Hacks to make things compile... */ #define S_ISBLK(mode) (((mode) & S_IFMT) == S_IFBLK) +int os2_chmod(const char *name, int pmode); +int os2_fstat(int handle, struct stat *st); + #else #define Stat(fname,bufptr) stat((fname),(bufptr)) @@ -563,11 +672,14 @@ void CroakWinError(int die, char *name); #define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n)) char *perllib_mangle(char *, unsigned int); +#define fork fork_with_resources + typedef int (*Perl_PFN)(); Perl_PFN loadByOrdinal(enum entries_ordinals ord, int fail); extern const Perl_PFN * const pExtFCN; char *os2error(int rc); int os2_stat(const char *name, struct stat *st); +int fork_with_resources(); int setpriority(int which, int pid, int val); int getpriority(int which /* ignored */, int pid); diff --git a/os2/os2thread.h b/os2/os2thread.h index 9516ddda0b..e4f8360f9c 100644 --- a/os2/os2thread.h +++ b/os2/os2thread.h @@ -7,6 +7,7 @@ typedef _rmutex perl_mutex; /*typedef HEV perl_cond;*/ /* Will include os2.h into all C files. */ typedef unsigned long perl_cond; +int os2_cond_wait(perl_cond *c, perl_mutex *m); #ifdef USE_SLOW_THREAD_SPECIFIC typedef int perl_key; @@ -490,8 +490,8 @@ END_EXTERN_C #define PL_savebegin (*Perl_Isavebegin_ptr(aTHX)) #undef PL_sawampersand #define PL_sawampersand (*Perl_Isawampersand_ptr(aTHX)) -#undef PL_sh_path -#define PL_sh_path (*Perl_Ish_path_ptr(aTHX)) +#undef PL_sh_path_compat +#define PL_sh_path_compat (*Perl_Ish_path_compat_ptr(aTHX)) #undef PL_sig_pending #define PL_sig_pending (*Perl_Isig_pending_ptr(aTHX)) #undef PL_sighandlerp @@ -928,6 +928,8 @@ END_EXTERN_C #define PL_runops_dbg (*Perl_Grunops_dbg_ptr(NULL)) #undef PL_runops_std #define PL_runops_std (*Perl_Grunops_std_ptr(NULL)) +#undef PL_sh_path +#define PL_sh_path (*Perl_Gsh_path_ptr(NULL)) #undef PL_sharehook #define PL_sharehook (*Perl_Gsharehook_ptr(NULL)) #undef PL_thr_key @@ -3343,7 +3343,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, #ifdef PERLIO_USING_CRLF # ifdef PERLIO_IS_BINMODE_FD if (PERLIO_IS_BINMODE_FD(fd)) - PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch); + PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, Nullch); else # endif /* diff --git a/perlvars.h b/perlvars.h index 0495f1acfc..f29d25b607 100644 --- a/perlvars.h +++ b/perlvars.h @@ -66,3 +66,6 @@ PERLVARI(Gppid, IV, 0) #ifdef USE_ITHREADS PERLVAR(Gdollarzero_mutex, perl_mutex) /* Modifying $0 */ #endif + +/* This is constant on most architectures, a global on OS/2 */ +PERLVARI(Gsh_path, char *, SH_PATH)/* full path of shell */ @@ -146,7 +146,7 @@ Perl_reentrant_init(pTHX) { New(31338, PL_reentrant_buffer->_asctime_buffer, PL_reentrant_buffer->_asctime_size, char); #endif /* HAS_ASCTIME_R */ #ifdef HAS_CRYPT_R -#ifdef __GLIBC__ +#if defined(__GLIBC__) || defined(__EMX__) PL_reentrant_buffer->_crypt_struct.initialized = 0; /* work around glibc-2.2.5 bug */ PL_reentrant_buffer->_crypt_struct.current_saltbits = 0; @@ -457,7 +457,7 @@ EOF #endif EOF push @init, <<EOF; -#ifdef __GLIBC__ +#if defined(__GLIBC__) || defined(__EMX__) PL_reentrant_buffer->_${func}_struct.initialized = 0; /* work around glibc-2.2.5 bug */ PL_reentrant_buffer->_${func}_struct.current_saltbits = 0; @@ -11027,7 +11027,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origalen = proto_perl->Iorigalen; PL_pidstatus = newHV(); /* XXX flag for cloning? */ PL_osname = SAVEPV(proto_perl->Iosname); - PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */ + PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */ PL_sighandlerp = proto_perl->Isighandlerp; |