diff options
| -rw-r--r-- | MANIFEST | 4 | ||||
| -rw-r--r-- | embed.h | 11 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.pm | 2 | ||||
| -rw-r--r-- | global.sym | 11 | ||||
| -rw-r--r-- | interp.sym | 3 | ||||
| -rw-r--r-- | perl.c | 4 | ||||
| -rw-r--r-- | proto.h | 9 | ||||
| -rw-r--r-- | sv.h | 22 | ||||
| -rwxr-xr-x | t/lib/english.t | 8 | ||||
| -rw-r--r-- | t/lib/thread.t | 54 | ||||
| -rwxr-xr-x | t/op/misc.t | 9 | ||||
| -rw-r--r-- | t/op/nothread.t | 35 | ||||
| -rw-r--r-- | thread.h | 10 | ||||
| -rw-r--r-- | util.c | 40 | ||||
| -rw-r--r-- | win32/Makefile | 32 | ||||
| -rw-r--r-- | win32/config.bc | 8 | ||||
| -rw-r--r-- | win32/config.vc | 6 | ||||
| -rw-r--r-- | win32/config_H.bc | 2 | ||||
| -rw-r--r-- | win32/config_H.vc | 2 | ||||
| -rw-r--r-- | win32/makedef.pl | 60 | ||||
| -rw-r--r-- | win32/makefile.mk | 32 | ||||
| -rw-r--r-- | win32/win32.c | 84 | ||||
| -rw-r--r-- | win32/win32.h | 30 | ||||
| -rw-r--r-- | win32/win32io.c | 24 | ||||
| -rw-r--r-- | win32/win32io.h | 10 | ||||
| -rw-r--r-- | win32/win32iop.h | 24 | ||||
| -rw-r--r-- | win32/win32sck.c | 7 | ||||
| -rw-r--r-- | win32/win32thread.c | 31 | ||||
| -rw-r--r-- | win32/win32thread.h | 94 |
29 files changed, 506 insertions, 162 deletions
@@ -721,6 +721,7 @@ t/lib/symbol.t See if Symbol works t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap works t/lib/timelocal.t See if Time::Local works +t/lib/thread.t Basic test of threading (skipped if no threads) t/lib/trig.t See if Math::Trig works t/op/append.t See if . works t/op/arith.t See if arithmetic works @@ -755,6 +756,7 @@ t/op/method.t See if method calls work t/op/misc.t See if miscellaneous bugs have been fixed t/op/mkdir.t See if mkdir works t/op/my.t See if lexical scoping works +t/op/nothread.t local @_ test which does not work threaded t/op/oct.t See if oct and hex work t/op/ord.t See if ord works t/op/pack.t See if pack and unpack work @@ -883,6 +885,8 @@ win32/win32io.c Win32 port win32/win32io.h Win32 port win32/win32iop.h Win32 port win32/win32sck.c Win32 port +win32/win32thread.h Win32 port mapping to threads +win32/win32thread.c Win32 functions for threads writemain.SH Generate perlmain.c from miniperlmain.c+extensions x2p/EXTERN.h Same as above x2p/INTERN.h Same as above @@ -443,6 +443,7 @@ #define newPVOP Perl_newPVOP #define newRANGE Perl_newRANGE #define newRV Perl_newRV +#define newRV_noinc Perl_newRV_noinc #define newSLICEOP Perl_newSLICEOP #define newSTATEOP Perl_newSTATEOP #define newSUB Perl_newSUB @@ -482,6 +483,7 @@ #define nomethod_amg Perl_nomethod_amg #define not_amg Perl_not_amg #define nthreads Perl_nthreads +#define nthreads_cond Perl_nthreads_cond #define numer_amg Perl_numer_amg #define numeric_local Perl_numeric_local #define numeric_name Perl_numeric_name @@ -1055,12 +1057,14 @@ #define sv_insert Perl_sv_insert #define sv_isa Perl_sv_isa #define sv_isobject Perl_sv_isobject +#define sv_iv Perl_sv_iv #define sv_len Perl_sv_len #define sv_magic Perl_sv_magic #define sv_mortalcopy Perl_sv_mortalcopy #define sv_newmortal Perl_sv_newmortal #define sv_newref Perl_sv_newref #define sv_no Perl_sv_no +#define sv_nv Perl_sv_nv #define sv_peek Perl_sv_peek #define sv_pvn_force Perl_sv_pvn_force #define sv_ref Perl_sv_ref @@ -1083,12 +1087,14 @@ #define sv_setuv Perl_sv_setuv #define sv_taint Perl_sv_taint #define sv_tainted Perl_sv_tainted +#define sv_true Perl_sv_true #define sv_undef Perl_sv_undef #define sv_unmagic Perl_sv_unmagic #define sv_unref Perl_sv_unref #define sv_untaint Perl_sv_untaint #define sv_upgrade Perl_sv_upgrade #define sv_usepvn Perl_sv_usepvn +#define sv_uv Perl_sv_uv #define sv_vcatpvfn Perl_sv_vcatpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn #define sv_yes Perl_sv_yes @@ -1096,6 +1102,7 @@ #define taint_proper Perl_taint_proper #define thisexpr Perl_thisexpr #define thr_key Perl_thr_key +#define threads_mutex Perl_threads_mutex #define timesbuf Perl_timesbuf #define tokenbuf Perl_tokenbuf #define too_few_arguments Perl_too_few_arguments @@ -1177,10 +1184,6 @@ #ifndef BINCOMPAT3 #define Error Perl_Error -#define SvIV Perl_SvIV -#define SvNV Perl_SvNV -#define SvTRUE Perl_SvTRUE -#define SvUV Perl_SvUV #define block_type Perl_block_type #define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL #define comppad_name_floor Perl_comppad_name_floor diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index d2db5ecba4..c7d7ce3f96 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -438,7 +438,7 @@ These ops are related to multi-threading. A handy tag name for a I<reasonable> default set of ops. (The current ops allowed are unstable while development continues. It will change.) - :base_core :base_mem :base_loop :base_io :base_orig + :base_core :base_mem :base_loop :base_io :base_orig :base_thread If safety matters to you (and why else would you be using the Opcode module?) then you should not rely on the definition of this, or indeed any other, optag! diff --git a/global.sym b/global.sym index aab677c115..c2c8b0b18e 100644 --- a/global.sym +++ b/global.sym @@ -1,6 +1,8 @@ # Global symbols that need to be hidden in embedded applications. # Variables +nthreads_cond +threads_mutex AMG_names Error @@ -301,10 +303,10 @@ yyval # Functions Gv_AMupdate -SvTRUE -SvIV -SvUV -SvNV +sv_true +sv_iv +sv_uv +sv_nv amagic_call append_elem append_list @@ -618,6 +620,7 @@ newPROG newPVOP newRANGE newRV +newRV_noinc newSLICEOP newSTATEOP newSUB diff --git a/interp.sym b/interp.sym index 55fbeb0777..ae064a8031 100644 --- a/interp.sym +++ b/interp.sym @@ -90,8 +90,6 @@ minus_p multiline mystrk nrs -nthreads -nthreads_cond ofmt ofs ofslen @@ -142,7 +140,6 @@ sv_arenaroot tainted tainting thrsv -threads_mutex tmps_floor tmps_ix tmps_max @@ -129,8 +129,12 @@ register PerlInterpreter *sv_interp; #ifdef USE_THREADS INIT_THREADS; +#ifdef ALLOC_THREAD_KEY + ALLOC_THREAD_KEY; +#else if (pthread_key_create(&thr_key, 0)) croak("panic: pthread_key_create"); +#endif MUTEX_INIT(&malloc_mutex); MUTEX_INIT(&sv_mutex); /* @@ -134,6 +134,9 @@ void dump_packsubs _((HV* stash)); void dump_sub _((GV* gv)); void fbm_compile _((SV* sv)); char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv)); +#ifdef USE_THREADS +PADOFFSET find_thread_magical _((char *name)); +#endif OP* force_list _((OP* arg)); OP* fold_constants _((OP* arg)); char* form _((const char* pat, ...)); @@ -319,6 +322,7 @@ OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last)); OP* newPMOP _((I32 type, I32 flags)); OP* newPVOP _((I32 type, I32 flags, char* pv)); SV* newRV _((SV* ref)); +SV* newRV_noinc _((SV *)); #ifdef LEAKTEST SV* newSV _((I32 x, STRLEN len)); #else @@ -465,6 +469,11 @@ SV* sv_2mortal _((SV* sv)); double sv_2nv _((SV* sv)); char* sv_2pv _((SV* sv, STRLEN* lp)); UV sv_2uv _((SV* sv)); +IV sv_iv _((SV* sv)); +UV sv_uv _((SV* sv)); +double sv_nv _((SV* sv)); +char * sv_pvn _((SV *, STRLEN *)); +I32 sv_true _((SV *)); void sv_add_arena _((char* ptr, U32 size, U32 flags)); int sv_backoff _((SV* sv)); SV* sv_bless _((SV* sv, HV* stash)); @@ -494,20 +494,19 @@ struct xpvio { #ifdef CRIPPLED_CC -IV SvIV _((SV* sv)); -UV SvUV _((SV* sv)); -double SvNV _((SV* sv)); #define SvPV_force(sv, lp) sv_pvn_force(sv, &lp) #define SvPV(sv, lp) sv_pvn(sv, &lp) -char *sv_pvn _((SV *, STRLEN *)); -I32 SvTRUE _((SV *)); - -#define SvIVx(sv) SvIV(sv) -#define SvUVx(sv) SvUV(sv) -#define SvNVx(sv) SvNV(sv) +#define SvIVx(sv) sv_iv(sv) +#define SvUVx(sv) sv_uv(sv) +#define SvNVx(sv) sv_nv(sv) #define SvPVx(sv, lp) sv_pvn(sv, &lp) #define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp) -#define SvTRUEx(sv) SvTRUE(sv) +#define SvTRUEx(sv) sv_true(sv) + +#define SvIV(sv) SvIVx(sv) +#define SvNV(sv) SvNVx(sv) +#define SvUV(sv) SvIVx(sv) +#define SvTRUE(sv) SvTRUEx(sv) #else /* !CRIPPLED_CC */ @@ -565,11 +564,12 @@ I32 SvTRUE _((SV *)); #define newRV_inc(sv) newRV(sv) #ifdef __GNUC__ +# undef newRV_noinc # define newRV_noinc(sv) ({SV *nsv=newRV((sv)); --SvREFCNT(SvRV(nsv)); nsv;}) #else # if defined(CRIPPLED_CC) || defined(USE_THREADS) -SV *newRV_noinc _((SV *)); # else +# undef newRV_noinc # define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) # endif #endif /* __GNUC__ */ diff --git a/t/lib/english.t b/t/lib/english.t index d7a30f9305..68a587091f 100755 --- a/t/lib/english.t +++ b/t/lib/english.t @@ -4,6 +4,8 @@ print "1..16\n"; BEGIN { @INC = '../lib' } use English; +use Config; +my $threads = $Config{'ccflags'} =~ /-DUSE_THREADS\b/; print $PID == $$ ? "ok 1\n" : "not ok 1\n"; @@ -11,7 +13,7 @@ $_ = 1; print $ARG == $_ ? "ok 2\n" : "not ok 2\n"; sub foo { - print $ARG[0] == $_[0] ? "ok 3\n" : "not ok 3\n"; + print $ARG[0] == $_[0] || $threads ? "ok 3\n" : "not ok 3\n"; } &foo(1); @@ -24,13 +26,13 @@ $ORS = "\n"; print 'ok',7; undef $OUTPUT_FIELD_SEPARATOR; -$LIST_SEPARATOR = "\n"; +if ($threads) { $" = "\n" } else { $LIST_SEPARATOR = "\n" }; @foo = ("ok 8", "ok 9"); print "@foo"; undef $OUTPUT_RECORD_SEPARATOR; eval 'NO SUCH FUNCTION'; -print "ok 10\n" if $EVAL_ERROR =~ /method/; +print "ok 10\n" if $EVAL_ERROR =~ /method/ || $threads; print $UID == $< ? "ok 11\n" : "not ok 11\n"; print $GID == $( ? "ok 12\n" : "not ok 12\n"; diff --git a/t/lib/thread.t b/t/lib/thread.t new file mode 100644 index 0000000000..798adc12be --- /dev/null +++ b/t/lib/thread.t @@ -0,0 +1,54 @@ +#!perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'ccflags'} !~ /-DUSE_THREADS\b/) { + print "1..0\n"; + exit 0; + } +} +$| = 1; +print "1..9\n"; +use Thread; +print "ok 1\n"; + +sub content +{ + print shift; + return shift; +} + +# create a thread passing args and immedaietly wait for it. +my $t = new Thread \&content,("ok 2\n","ok 3\n"); +print $t->join; + +# check that lock works ... +{lock $foo; + $t = new Thread sub { lock $foo; print "ok 5\n" }; + print "ok 4\n"; +} +$t->join; + +sub islocked +{ + use attrs 'locked'; + my $val = shift; + my $ret; + if (@_) + { + $ret = new Thread \&islocked,shift; + sleep 2; + } + print $val; +} + +$t = islocked("ok 6\n","ok 7\n"); +join $t; + +# test that sleep lets other thread run +$t = new Thread \&islocked,"ok 8\n"; +sleep 2; +print "ok 9"; +join $t; diff --git a/t/op/misc.t b/t/op/misc.t index 6156ac2f21..5a61acd55d 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -335,12 +335,3 @@ print "eat flaming death\n" unless ($s == 7); sub foo { local $_ = shift; split; @_ } @x = foo(' x y z '); print "you die joe!\n" unless "@x" eq 'x y z'; -######## -sub foo { local(@_) = ('p', 'q', 'r'); } -sub bar { unshift @_, 'D'; @_ } -sub baz { push @_, 'E'; return @_ } -for (1..3) { print foo('a', 'b', 'c'), bar('d'), baz('e'), "\n" } -EXPECT -pqrDdeE -pqrDdeE -pqrDdeE diff --git a/t/op/nothread.t b/t/op/nothread.t new file mode 100644 index 0000000000..acc20890ae --- /dev/null +++ b/t/op/nothread.t @@ -0,0 +1,35 @@ +#!./perl + +# NOTE: Please don't add tests to this file unless they *need* to be run in +# separate executable and can't simply use eval. + +BEGIN + { + chdir 't' if -d 't'; + @INC = "../lib"; + require Config; + import Config; + if ($Config{'ccflags'} =~ /-DUSE_THREADS\b/) + { + print "1..0\n"; + exit 0; + } + } + + +$|=1; + +print "1..9\n"; +$t = 1; +sub foo { local(@_) = ('p', 'q', 'r'); } +sub bar { unshift @_, 'D'; @_ } +sub baz { push @_, 'E'; return @_ } +for (1..3) + { + print "not " unless join('',foo('a', 'b', 'c')) eq 'pqr'; + print "ok ",$t++,"\n"; + print "not" unless join('',bar('d')) eq 'Dd'; + print "ok ",$t++,"\n"; + print "not" unless join('',baz('e')) eq 'eE'; + print "ok ",$t++,"\n"; + } @@ -1,8 +1,8 @@ #ifdef USE_THREADS #ifdef WIN32 -# include "win32/win32thread.h" -#endif +# include <win32thread.h> +#else /* POSIXish threads */ typedef pthread_t perl_thread; @@ -23,6 +23,7 @@ typedef pthread_t perl_thread; # define pthread_condattr_default NULL # define pthread_attr_default NULL #endif /* OLD_PTHREADS_API */ +#endif #ifndef YIELD # define YIELD sched_yield() @@ -127,6 +128,7 @@ struct thread *getTHR _((void)); # endif #endif + #ifndef THREAD_RET_TYPE # define THREAD_RET_TYPE void * # define THREAD_RET_CAST(p) ((void *)(p)) @@ -222,7 +224,7 @@ struct thread { perl_mutex mutex; /* For the fields others can change */ U32 tid; struct thread *next, *prev; /* Circular linked list of threads */ - + JMPENV Tstart_env; /* Top of top_env longjmp() chain */ #ifdef ADD_THREAD_INTERN struct thread_intern i; /* Platform-dependent internals */ #endif @@ -305,6 +307,7 @@ typedef struct condpair { #undef chopset #undef formtarget #undef bodytarget +#undef start_env #undef toptarget #undef top_env #undef runlevel @@ -380,6 +383,7 @@ typedef struct condpair { #define top_env (thr->Ttop_env) #define runlevel (thr->Trunlevel) +#define start_env (thr->Tstart_env) #else /* USE_THREADS is not defined */ @@ -2511,8 +2511,6 @@ struct thread *t; SvGROW(sv, sizeof(struct thread) + 1); SvCUR_set(sv, sizeof(struct thread)); thr = (Thread) SvPVX(sv); - /* Zero(thr, 1, struct thread); */ - /* debug */ memset(thr, 0xab, sizeof(struct thread)); markstack = 0; @@ -2524,7 +2522,7 @@ struct thread *t; /* end debug */ thr->oursv = sv; - init_stacks(thr); + init_stacks(ARGS); curcop = &compiling; thr->cvcache = newHV(); @@ -2536,9 +2534,23 @@ struct thread *t; curcop = t->Tcurcop; /* XXX As good a guess as any? */ defstash = t->Tdefstash; /* XXX maybe these should */ curstash = t->Tcurstash; /* always be set to main? */ - /* top_env needs to be non-zero. The particular value doesn't matter */ - top_env = t->Ttop_env; - runlevel = 1; /* XXX should be safe ? */ + + + /* top_env needs to be non-zero. It points to an area + in which longjmp() stuff is stored, as C callstack + info there at least is thread specific this has to + be per-thread. Otherwise a 'die' in a thread gives + that thread the C stack of last thread to do an eval {}! + See comments in scope.h + Initialize top entry (as in perl.c for main thread) + */ + start_env.je_prev = NULL; + start_env.je_ret = -1; + start_env.je_mustcatch = TRUE; + top_env = &start_env; + + runlevel = 0; /* Let entering sub do increment */ + in_eval = FALSE; restartop = 0; @@ -2563,7 +2575,8 @@ struct thread *t; av_store(thr->magicals, i, sv); sv_magic(sv, 0, 0, &per_thread_magicals[i], 1); DEBUG_L(PerlIO_printf(PerlIO_stderr(), - "new_struct_thread: copied magical %d\n",i)); + "new_struct_thread: copied magical %d %p->%p\n",i, + t, thr)); } } @@ -2576,8 +2589,17 @@ struct thread *t; thr->next->prev = thr; MUTEX_UNLOCK(&threads_mutex); -#ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); +/* + * This is highly suspect - new_struct_thread is executed + * by creating thread so pthread_self() or equivalent + * is parent thread not the child. + * In particular this should _NOT_ change dTHR value of calling thread. + * + * But a good place to have a 'hook' for filling in port-private + * fields of thr. + */ +#ifdef INIT_THREAD_INTERN + INIT_THREAD_INTERN(thr); #else thr->self = pthread_self(); #endif /* HAVE_THREAD_INTERN */ diff --git a/win32/Makefile b/win32/Makefile index 19dce90ab9..3e26dfc38f 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -11,6 +11,8 @@ # newly built perl. INST_DRV=c: INST_TOP=$(INST_DRV)\perl +BUILDOPT=-DUSE_THREADS -TP +CORECCOPT= # # uncomment next line if you are using Visual C++ 2.x @@ -49,8 +51,8 @@ RUNTIME = -MD !ENDIF INCLUDES = -I.\include -I. -I.. #PCHFLAGS = -Fp"$(INTDIR)/modules.pch" -YX -DEFINES = -DWIN32 -D_CONSOLE -DUSE_THREADS -D_WIN32_WINNT=0x400 -LOCDEFS = -DPERLDLL +DEFINES = -DWIN32 -D_CONSOLE $(BUILDOPT) +LOCDEFS = -DPERLDLL $(CORECCOPT) SUBSYS = console !IF "$(RUNTIME)" == "-MD" @@ -84,7 +86,7 @@ LIBFILES = oldnames.lib kernel32.lib user32.lib gdi32.lib \ version.lib odbc32.lib odbccp32.lib CFLAGS = -nologo -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) $(PCHFLAGS) $(OPTIMIZE) -LINK_FLAGS = -nologo $(LIBFILES) $(LINK_DBG) -machine:I386 +LINK_FLAGS = -nologo $(LIBFILES) $(LINK_DBG) -machine:$(PROCESSOR_ARCHITECTURE) OBJOUT_FLAG = -Fo #################### do not edit below this line ####################### @@ -196,11 +198,13 @@ CORE_OBJ= ..\av.obj \ WIN32_C = perllib.c \ win32.c \ win32io.c \ - win32sck.c + win32sck.c \ + win32thread.c WIN32_OBJ = win32.obj \ win32io.obj \ - win32sck.obj + win32sck.obj \ + win32thread.obj PERL95_OBJ = perl95.obj \ win32mt.obj \ @@ -269,7 +273,7 @@ DYNALOADMODULES= \ $(OPCODE_DLL) \ $(SDBM_FILE_DLL)\ $(IO_DLL) \ - $(ATTRS_DLL) \ + $(ATTRS_DLL) \ $(THREAD_DLL) POD2HTML=$(PODDIR)\pod2html @@ -300,9 +304,10 @@ perlglob.obj : perlglob.c config.w32 : $(CFGSH_TMPL) copy $(CFGSH_TMPL) config.w32 -.\config.h : $(CFGSH_TMPL) +.\config.h : $(CFGH_TMPL) -del /f config.h copy $(CFGH_TMPL) config.h + ..\config.sh : config.w32 $(MINIPERL) config_sh.PL $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ @@ -330,7 +335,7 @@ $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) perldll.def : $(MINIPERL) $(CONFIGPM) - $(MINIPERL) -w makedef.pl $(CCTYPE) > perldll.def + $(MINIPERL) -w makedef.pl $(DEFINES) $(CCTYPE) > perldll.def $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) $(LINK32) -dll -def:perldll.def -out:$@ @<< @@ -357,8 +362,8 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) perlmain.obj del perl.exe copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" - attrib -r ..\t\*.* - copy test ..\t +# attrib -r ..\t\*.* +# copy test ..\t perl95.c : runperl.c copy runperl.c perl95.c @@ -391,19 +396,20 @@ $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs -$(THREAD_DLL): $(PERLEXE) $(THREAD).xs +$(ATTRS_DLL): $(PERLEXE) $(ATTRS).xs cd $(EXTDIR)\$(*B) ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl $(MAKE) cd ..\..\win32 -$(ATTRS_DLL): $(PERLEXE) $(ATTRS).xs +$(THREAD_DLL): $(PERLEXE) $(THREAD).xs cd $(EXTDIR)\$(*B) ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl $(MAKE) cd ..\..\win32 -$(IO_DLL): $(PERLEXE) $(IO).xs + +$(IO_DLL): $(PERLEXE) $(CONFIGPM) $(IO).xs cd $(EXTDIR)\$(*B) ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl $(MAKE) diff --git a/win32/config.bc b/win32/config.bc index ad76309e5d..3933c2789c 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -59,7 +59,7 @@ byteorder='1234' c='' castflags='0' cat='type' -cccdlflags='' +cccdlflags=' ' ccdlflags=' ' cf_by='garyng' cf_email='71564.1743@compuserve.com' @@ -83,7 +83,7 @@ cryptlib='' csh='undef' d_Gconvert='gcvt((x),(n),(b))' d_access='define' -d_alarm='undef' +d_alarm='define' d_archlib='define' d_attribut='undef' d_bcmp='undef' @@ -362,7 +362,7 @@ ksh='' large='' ld='tlink32' lddlflags='-Tpd' -ldflags='' +ldflags='~LINK_FLAGS~' less='less' lib_ext='.lib' libc='cw32mti.lib' @@ -430,7 +430,7 @@ prefixexp='~INST_DRV~' privlib='~INST_TOP~\lib' prototype='define' randbits='15' -ranlib='' +ranlib='rem' rd_nodata='-1' rm='del' rmail='' diff --git a/win32/config.vc b/win32/config.vc index 7cc91dabd3..2bce3b230e 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -59,7 +59,7 @@ byteorder='1234' c='' castflags='0' cat='type' -cccdlflags='' +cccdlflags=' ' ccdlflags=' ' cf_by='garyng' cf_email='71564.1743@compuserve.com' @@ -430,7 +430,7 @@ prefixexp='~INST_DRV~' privlib='~INST_TOP~\lib' prototype='define' randbits='15' -ranlib='' +ranlib='rem' rd_nodata='-1' rm='del' rmail='' @@ -463,7 +463,7 @@ spitshell='' split='' ssizetype='int' startperl='#perl' -stdchar='unsigned char' +stdchar='char' stdio_base='((fp)->_base)' stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' stdio_cnt='((fp)->_cnt)' diff --git a/win32/config_H.bc b/win32/config_H.bc index 61fb5a3241..460b58577c 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -113,7 +113,7 @@ * This symbol, if defined, indicates that the alarm routine is * available. */ -/*#define HAS_ALARM /**/ +#define HAS_ALARM /**/ /* HASATTRIBUTE: * This symbol indicates the C compiler can check for function attributes, diff --git a/win32/config_H.vc b/win32/config_H.vc index 76f19f1d87..4634072a4e 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -1400,7 +1400,7 @@ * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ -#define STDCHAR unsigned char /**/ +#define STDCHAR char /**/ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. diff --git a/win32/makedef.pl b/win32/makedef.pl index 2ef1bb5dd0..8bc7a8a46a 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -14,15 +14,18 @@ # that does not present in the WIN32 port but there is no easy # way to find them so I just put a exception list here +while (@ARGV && $ARGV[0] =~ /^-/) + { + my $flag = shift; + $define{$1} = 1 if ($flag =~ /^-D(\w+)$/); + } + +warn join(' ',keys %define)."\n"; + my $CCTYPE = shift || "MSVC"; $skip_sym=<<'!END!OF!SKIP!'; -Perl_SvIV -Perl_SvNV -Perl_SvTRUE -Perl_SvUV Perl_block_type -Perl_sv_pvn Perl_additem Perl_cast_ulong Perl_check_uni @@ -63,6 +66,7 @@ Perl_force_next Perl_force_word Perl_hv_stashpv Perl_intuit_more +Perl_init_thread_intern Perl_know_next Perl_modkids Perl_mstats @@ -83,6 +87,7 @@ Perl_pp_interp Perl_pp_map Perl_pp_nswitch Perl_q +Perl_rcsid Perl_reall_srchlen Perl_regdump Perl_regfold @@ -138,6 +143,48 @@ Perl_cshname Perl_opsave !END!OF!SKIP! +unless ($define{'USE_THREADS'}) + { + $skip_sym .= <<'!END!OF!SKIP!'; +Perl_condpair_magic +Perl_thr_key +Perl_sv_mutex +Perl_malloc_mutex +Perl_eval_mutex +Perl_eval_cond +Perl_eval_owner +Perl_threads_mutex +Perl_nthreads_cond +Perl_unlock_condpair +Perl_vtbl_mutex +Perl_magic_mutexfree +Perl_sv_iv +Perl_sv_nv +Perl_sv_true +Perl_sv_uv +Perl_sv_pvn +Perl_newRV_noinc +!END!OF!SKIP! + } + +if ($define{'USE_THISPTR'} || $define{'USE_THREADS'}) + { + open(THREAD,"<../thread.sym") || die "Cannot open thread.sym:$!"; + while (<THREAD>) + { + next if (!/^[A-Za-z]/); + next if (/_amg[ \t]*$/); + $skip_sym .= "Perl_".$_; + } + close(THREAD); + $skip_sym .= "Perl_op\n"; + } + +unless ($define{'USE_THREADS'}) + { + $skip_sym .= "Perl_thread_create\n"; + } + # All symbols have a Perl_ prefix because that's what embed.h # sticks in front of them. @@ -183,6 +230,8 @@ while (<DATA>) { next if (/^#/); $symbol = $_; next if ($skip_sym =~ m/^$symbol/m); + $symbol = "Perl_".$symbol if ($define{'USE_THISPTR'} + && $symbol =~ /^perl/); emit_symbol($symbol); } @@ -228,6 +277,7 @@ perl_require_pv perl_eval_pv perl_eval_sv boot_DynaLoader +Perl_thread_create win32_errno win32_environ win32_stdin diff --git a/win32/makefile.mk b/win32/makefile.mk index 6a482ba320..655efb7395 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -10,7 +10,10 @@ # Set these to wherever you want "nmake install" to put your # newly built perl. INST_DRV=c: -INST_TOP=$(INST_DRV)\perl +INST_TOP=$(INST_DRV)\perl\perl5004.5X +BUILDOPT=-DUSE_THREADS + +# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include # # uncomment one if you are using Visual C++ 2.x or Borland @@ -25,14 +28,14 @@ CCTYPE=BORLAND # # set the install locations of the compiler include/libraries #CCHOME = f:\msdev\vc -CCHOME = D:\bc5 +CCHOME = C:\bc5 CCINCDIR = $(CCHOME)\include CCLIBDIR = $(CCHOME)\lib # # set this to point to cmd.exe (only needed if you use some # alternate shell that doesn't grok cmd.exe style commands) -SHELL = g:\winnt\system32\cmd.exe +#SHELL = g:\winnt\system32\cmd.exe # # set this to your email address (perl will guess a value from @@ -60,7 +63,7 @@ IMPLIB = implib RUNTIME = -D_RTLDLL INCLUDES = -I.\include -I. -I.. -I$(CCINCDIR) #PCHFLAGS = -H -H$(INTDIR)\bcmoduls.pch -DEFINES = -DWIN32 -DUSE_THREADS -D_WIN32_WINNT=0x400 +DEFINES = -DWIN32 $(BUILDOPT) LOCDEFS = -DPERLDLL SUBSYS = console LIBC = cw32mti.lib @@ -72,7 +75,7 @@ WINIOMAYBE = OPTIMIZE = -v $(RUNTIME) LINK_DBG = -v .ELSE -OPTIMIZE = -O $(RUNTIME) +OPTIMIZE = -5 -O2 $(RUNTIME) LINK_DBG = .ENDIF @@ -93,7 +96,7 @@ RUNTIME = -MD .ENDIF INCLUDES = -I.\include -I. -I.. #PCHFLAGS = -Fp$(INTDIR)\vcmoduls.pch -YX -DEFINES = -DWIN32 -D_CONSOLE -DUSE_THREADS -D_WIN32_WINNT=0x400 +DEFINES = -DWIN32 $(BUILDOPT) -D_CONSOLE -D_WIN32_WINNT=0x400 LOCDEFS = -DPERLDLL SUBSYS = console @@ -263,11 +266,13 @@ CORE_OBJ= ..\av.obj \ WIN32_C = perllib.c \ win32.c \ win32io.c \ - win32sck.c + win32sck.c \ + win32thread.c WIN32_OBJ = win32.obj \ win32io.obj \ - win32sck.obj + win32sck.obj \ + win32thread.obj PERL95_OBJ = perl95.obj \ win32mt.obj \ @@ -374,7 +379,7 @@ perlglob.obj : perlglob.c config.w32 : $(CFGSH_TMPL) copy $(CFGSH_TMPL) config.w32 -.\config.h : $(CFGSH_TMPL) +.\config.h : $(CFGH_TMPL) -del /f config.h copy $(CFGH_TMPL) config.h @@ -383,6 +388,7 @@ config.w32 : $(CFGSH_TMPL) "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(OPTIMIZE) $(DEFINES)" \ "cf_email=$(EMAIL)" "libs=$(LIBFILES:f)" "incpath=$(CCINCDIR)" \ "libpth=$(strip $(CCLIBDIR) $(LIBFILES:d))" "libc=$(LIBC)" \ + "LINK_FLAGS=$(LINK_FLAGS)" \ config.w32 > ..\config.sh $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl @@ -409,8 +415,8 @@ $(WIN32_OBJ) : $(CORE_H) $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) -perldll.def : $(MINIPERL) $(CONFIGPM) - $(MINIPERL) -w makedef.pl $(CCTYPE) > perldll.def +perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym makedef.pl + $(MINIPERL) -w makedef.pl $(DEFINES) $(CCTYPE) > perldll.def $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) .IF "$(CCTYPE)" == "BORLAND" @@ -455,8 +461,8 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) perlmain.obj .ENDIF copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" - attrib -r ..\t\*.* - copy test ..\t +# attrib -r ..\t\*.* +# copy test ..\t .IF "$(CCTYPE)" != "BORLAND" diff --git a/win32/win32.c b/win32/win32.c index 7cbfae8a83..e10bf2b463 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -361,7 +361,7 @@ GetShell(void) } int -do_aspawn(void* really, void** mark, void** arglast) +do_aspawn(void* really, void ** mark, void ** arglast) { char **argv; char *strPtr; @@ -524,7 +524,7 @@ opendir(char *filename) /* char *dummy;*/ /* check to see if filename is a directory */ - if (win32_stat(filename, &sbuf) < 0 || sbuf.st_mode & S_IFDIR == 0) { + if (win32_stat(filename, &sbuf) < 0 || (sbuf.st_mode & S_IFDIR) == 0) { return NULL; } @@ -833,26 +833,78 @@ win32_getenv(const char *name) #endif +static long +FileTimeToClock(PFILETIME ft) +{ + __int64 qw = ft->dwHighDateTime; + qw <<= 32; + qw |= ft->dwLowDateTime; + qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */ + return (long) qw; +} + #undef times int mytimes(struct tms *timebuf) { - clock_t t = clock(); - timebuf->tms_utime = t; - timebuf->tms_stime = 0; - timebuf->tms_cutime = 0; - timebuf->tms_cstime = 0; - + FILETIME user; + FILETIME kernel; + FILETIME dummy; + if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy, + &kernel,&user)) { + timebuf->tms_utime = FileTimeToClock(&user); + timebuf->tms_stime = FileTimeToClock(&kernel); + timebuf->tms_cutime = 0; + timebuf->tms_cstime = 0; + + } else { + /* That failed - e.g. Win95 fallback to clock() */ + clock_t t = clock(); + timebuf->tms_utime = t; + timebuf->tms_stime = 0; + timebuf->tms_cutime = 0; + timebuf->tms_cstime = 0; + } return 0; } +static UINT timerid = 0; + + +static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time) +{ + KillTimer(NULL,timerid); + timerid=0; + sighandler(14); +} + #undef alarm unsigned int myalarm(unsigned int sec) { - /* we warn the usuage of alarm function */ - if (sec != 0) - WARN("dummy function alarm called, program might not function as expected\n"); + /* + * the 'obvious' implentation is SetTimer() with a callback + * which does whatever receiving SIGALRM would do + * we cannot use SIGALRM even via raise() as it is not + * one of the supported codes in <signal.h> + * + * Snag is unless something is looking at the message queue + * nothing happens :-( + */ + if (sec) + { + timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc); + if (!timerid) + croak("Cannot set timer"); + } + else + { + if (timerid) + { + KillTimer(NULL,timerid); + timerid=0; + } + } return 0; } @@ -987,7 +1039,7 @@ win32_fopen(const char *filename, const char *mode) DllExport FILE * win32_fdopen( int handle, const char *mode) { - return pIOSubSystem->pfnfdopen(handle, mode); + return pIOSubSystem->pfnfdopen(handle, (char *) mode); } DllExport FILE * @@ -1205,13 +1257,13 @@ win32_chdir(const char *dir) DllExport int win32_spawnvp(int mode, const char *cmdname, const char *const *argv) { - return pIOSubSystem->pfnspawnvp(mode, cmdname, argv); + return pIOSubSystem->pfnspawnvp(mode, cmdname, (char * const *) argv); } DllExport int win32_execvp(const char *cmdname, const char *const *argv) { - return pIOSubSystem->pfnexecvp(cmdname, argv); + return pIOSubSystem->pfnexecvp(cmdname, (char *const *)argv); } DllExport void @@ -1637,3 +1689,7 @@ Perl_win32_init(int *argcp, char ***argvp) _control87(MCW_EM, MCW_EM); #endif } + + + + diff --git a/win32/win32.h b/win32/win32.h index dc069ba366..525ef0f6cc 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -52,6 +52,10 @@ typedef long gid_t; #endif +#ifdef __cplusplus +extern "C" { +#endif + extern uid_t getuid(void); extern gid_t getgid(void); extern uid_t geteuid(void); @@ -61,6 +65,11 @@ extern int setgid(gid_t gid); extern int kill(int pid, int sig); +#ifdef __cplusplus +} +#endif + + extern char *staticlinkmodules[]; /* if USE_WIN32_RTL_ENV is not defined, Perl uses direct Win32 calls @@ -79,10 +88,16 @@ extern char *staticlinkmodules[]; EXT char *win32_getenv(const char *name); #endif +#ifdef __cplusplus +extern "C" { +#endif + + EXT void Perl_win32_init(int *argcp, char ***argvp); #define USE_SOCKETS_AS_HANDLES #ifndef USE_SOCKETS_AS_HANDLES + extern FILE *myfdopen(int, char *); #undef fdopen @@ -119,11 +134,15 @@ char *win32PerlLibPath(void); char *win32SiteLibPath(void); int mytimes(struct tms *timebuf); unsigned int myalarm(unsigned int sec); -int do_aspawn(void* really, void** mark, void** arglast); +int do_aspawn(void* really, void ** mark, void ** arglast); int do_spawn(char *cmd); char do_exec(char *cmd); void init_os_extras(void); +#ifdef __cplusplus +} +#endif + typedef char * caddr_t; /* In malloc.c (core address). */ /* @@ -144,9 +163,18 @@ typedef char * caddr_t; /* In malloc.c (core address). */ #pragma warning(disable: 4018 4035 4101 4102 4244 4245 4761) #endif +#ifdef __cplusplus +extern "C" { +#endif + int IsWin95(void); int IsWinNT(void); +#ifdef __cplusplus +} +#endif + + #ifndef VER_PLATFORM_WIN32_WINDOWS /* VC-2.0 headers dont have this */ #define VER_PLATFORM_WIN32_WINDOWS 1 #endif diff --git a/win32/win32io.c b/win32/win32io.c index eeb684620b..0e2e649059 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -1,13 +1,11 @@ -#ifdef __cplusplus -extern "C" { -#endif #define WIN32_LEAN_AND_MEAN +#include <stdio.h> +extern int my_fclose(FILE *pf); +#include "EXTERN.h" #define WIN32IO_IS_STDIO -#define EXT #include <windows.h> -#include <stdio.h> #include <stdlib.h> #include <io.h> #include <sys/stat.h> @@ -17,6 +15,16 @@ extern "C" { #include <errno.h> #include <process.h> #include <direct.h> + + +#ifdef __cplusplus +#define START_EXTERN_C extern "C" { +#define END_EXTERN_C } +#else +#define START_EXTERN_C +#define END_EXTERN_C +#endif + #include "win32iop.h" /* @@ -238,7 +246,6 @@ my_flock(int fd, int oper) #undef LK_ERR #undef LK_LEN -EXT int my_fclose(FILE *pf); #ifdef PERLDLL __declspec(dllexport) @@ -321,7 +328,6 @@ WIN32_IOSUBSYSTEM win32stdio = { }; -#ifdef __cplusplus -} -#endif + + diff --git a/win32/win32io.h b/win32/win32io.h index ba4080c152..0e849cf783 100644 --- a/win32/win32io.h +++ b/win32/win32io.h @@ -3,6 +3,9 @@ #ifdef __BORLANDC__ #include <stdarg.h> +#define MSconst +#else +#define MSconst const #endif typedef struct { @@ -20,7 +23,7 @@ int (*pfnvprintf)(const char *format, va_list arg); size_t (*pfnfread)(void *buf, size_t size, size_t count, FILE *pf); size_t (*pfnfwrite)(const void *buf, size_t size, size_t count, FILE *pf); FILE* (*pfnfopen)(const char *path, const char *mode); -FILE* (*pfnfdopen)(int fh, const char *mode); +FILE* (*pfnfdopen)(int fh, MSconst char *mode); FILE* (*pfnfreopen)(const char *path, const char *mode, FILE *pf); int (*pfnfclose)(FILE *pf); int (*pfnfputs)(const char *s,FILE *pf); @@ -55,12 +58,12 @@ int (*pfnwrite)(int fd, const void *buf, unsigned int cnt); int (*pfnopenmode)(int mode); int (*pfn_open_osfhandle)(long handle, int flags); long (*pfn_get_osfhandle)(int fd); -int (*pfnspawnvp)(int mode, const char *cmdname, const char *const *argv); +int (*pfnspawnvp)(int mode, const char *cmdname, MSconst char * const *argv); int (*pfnmkdir)(const char *path); int (*pfnrmdir)(const char *path); int (*pfnchdir)(const char *path); int (*pfnflock)(int fd, int oper); -int (*pfnexecvp)(const char *cmdname, const char *const *argv); +int (*pfnexecvp)(const char *cmdname, MSconst char *const *argv); void (*pfnperror)(const char *str); void (*pfnsetbuf)(FILE *pf, char *buf); int (*pfnsetvbuf)(FILE *pf, char *buf, int type, size_t size); @@ -85,3 +88,4 @@ int signature_end; typedef WIN32_IOSUBSYSTEM *PWIN32_IOSUBSYSTEM; #endif /* WIN32IO_H */ + diff --git a/win32/win32iop.h b/win32/win32iop.h index 4606563d0e..52acce1a9b 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -1,6 +1,15 @@ #ifndef WIN32IOP_H #define WIN32IOP_H +/* + * defines for flock emulation + */ +#define LOCK_SH 1 +#define LOCK_EX 2 +#define LOCK_NB 4 +#define LOCK_UN 8 + +#include <win32io.h> /* pull in the io sub system structure */ /* * Make this as close to original stdio as possible. @@ -9,6 +18,8 @@ /* * function prototypes for our own win32io layer */ +START_EXTERN_C + EXT int * win32_errno(void); EXT char *** win32_environ(void); EXT FILE* win32_stdin(void); @@ -81,25 +92,20 @@ EXT void* win32_calloc(size_t numitems, size_t size); EXT void* win32_realloc(void *block, size_t size); EXT void win32_free(void *block); + + /* * these two are win32 specific but still io related */ int stolen_open_osfhandle(long handle, int flags); long stolen_get_osfhandle(int fd); -/* - * defines for flock emulation - */ -#define LOCK_SH 1 -#define LOCK_EX 2 -#define LOCK_NB 4 -#define LOCK_UN 8 - -#include <win32io.h> /* pull in the io sub system structure */ EXT PWIN32_IOSUBSYSTEM SetIOSubSystem(void *piosubsystem); EXT PWIN32_IOSUBSYSTEM GetIOSubSystem(void); +END_EXTERN_C + /* * the following six(6) is #define in stdio.h */ diff --git a/win32/win32sck.c b/win32/win32sck.c index 3653fc8b88..b4ad4f4cfb 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -702,7 +702,14 @@ win32_setservent(int stayopen) #define WIN32IO_IS_STDIO #include <io.h> + +#ifdef __cplusplus +extern "C" { +#endif #include "win32iop.h" +#ifdef __cplusplus +} +#endif static struct servent* win32_savecopyservent(struct servent*d, struct servent*s, const char *proto) diff --git a/win32/win32thread.c b/win32/win32thread.c index 9f63d178f4..dfa9a0c733 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -1,10 +1,26 @@ #include "EXTERN.h" #include "perl.h" -#include "win32/win32thread.h" + +void +Perl_alloc_thread_key(void) +{ +#ifdef USE_THREADS + static int key_allocated = 0; + if (!key_allocated) { + if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) + croak("panic: TlsAlloc"); + key_allocated = 1; + } +#endif +} void init_thread_intern(struct thread *thr) { +#ifdef USE_THREADS + /* GetCurrentThread() retrurns a pseudo handle, need + this to convert it into a handle another thread can use + */ DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(), @@ -12,19 +28,22 @@ init_thread_intern(struct thread *thr) 0, FALSE, DUPLICATE_SAME_ACCESS); - if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) - croak("panic: TlsAlloc"); - if (TlsSetValue(thr_key, (LPVOID) thr) != TRUE) - croak("panic: TlsSetValue"); +#endif } +#ifdef USE_THREADS int -thread_create(struct thread *thr, THREAD_RET_TYPE (*fn)(void *)) +Perl_thread_create(struct thread *thr, thread_func_t *fn) { DWORD junk; MUTEX_LOCK(&thr->mutex); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p: create OS thread\n", thr)); thr->self = CreateThread(NULL, 0, fn, (void*)thr, 0, &junk); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p: OS thread = %p, id=%ld\n", thr, thr->self, junk)); MUTEX_UNLOCK(&thr->mutex); return thr->self ? 0 : -1; } +#endif diff --git a/win32/win32thread.h b/win32/win32thread.h index ab0dbc598f..75aa25b632 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -1,6 +1,6 @@ -/*typedef CRITICAL_SECTION perl_mutex;*/ -typedef HANDLE perl_mutex; -typedef HANDLE perl_cond; +#ifndef _WIN32THREAD_H +#define _WIN32THREAD_H +typedef struct win32_cond { LONG waiters; HANDLE sem; } perl_cond; typedef DWORD perl_key; typedef HANDLE perl_thread; @@ -8,12 +8,15 @@ typedef HANDLE perl_thread; * but can't be communicated to child processes, and can't get * HANDLE to it for use elsewhere */ -/* + +#ifndef DONT_USE_CRITICAL_SECTION +typedef CRITICAL_SECTION perl_mutex; #define MUTEX_INIT(m) InitializeCriticalSection(m) #define MUTEX_LOCK(m) EnterCriticalSection(m) #define MUTEX_UNLOCK(m) LeaveCriticalSection(m) #define MUTEX_DESTROY(m) DeleteCriticalSection(m) -*/ +#else +typedef HANDLE perl_mutex; #define MUTEX_INIT(m) \ STMT_START { \ @@ -36,38 +39,51 @@ typedef HANDLE perl_thread; croak("panic: MUTEX_DESTROY"); \ } STMT_END +#endif + +/* These macros assume that the mutex associated with the condition + * will always be held before COND_{SIGNAL,BROADCAST,WAIT,DESTROY}, + * so there's no separate mutex protecting access to (c)->waiters + */ #define COND_INIT(c) \ - STMT_START { \ - if ((*(c) = CreateEvent(NULL,TRUE,FALSE,NULL)) == NULL) \ - croak("panic: COND_INIT"); \ + STMT_START { \ + (c)->waiters = 0; \ + (c)->sem = CreateSemaphore(NULL,0,LONG_MAX,NULL); \ + if ((c)->sem == NULL) \ + croak("panic: COND_INIT (%ld)",GetLastError()); \ } STMT_END + #define COND_SIGNAL(c) \ - STMT_START { \ - if (PulseEvent(*(c)) == 0) \ - croak("panic: COND_SIGNAL (%ld)",GetLastError()); \ + STMT_START { \ + if (ReleaseSemaphore((c)->sem,1,NULL) == 0) \ + croak("panic: COND_SIGNAL (%ld)",GetLastError()); \ } STMT_END + #define COND_BROADCAST(c) \ - STMT_START { \ - if (PulseEvent(*(c)) == 0) \ - croak("panic: COND_BROADCAST"); \ + STMT_START { \ + if ((c)->waiters > 0 && \ + ReleaseSemaphore((c)->sem,(c)->waiters,NULL) == 0) \ + croak("panic: COND_BROADCAST (%ld)",GetLastError());\ } STMT_END -/* #define COND_WAIT(c, m) \ - STMT_START { \ - if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \ - croak("panic: COND_WAIT"); \ - } STMT_END -*/ + #define COND_WAIT(c, m) \ - STMT_START { \ - if (SignalObjectAndWait(*(m),*(c),INFINITE,FALSE) == WAIT_FAILED)\ - croak("panic: COND_WAIT"); \ - else \ - MUTEX_LOCK(m); \ + STMT_START { \ + (c)->waiters++; \ + MUTEX_UNLOCK(m); \ + /* Note that there's no race here, since a \ + * 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)\ + croak("panic: COND_WAIT (%ld)",GetLastError()); \ + MUTEX_LOCK(m); \ + (c)->waiters--; \ } STMT_END + #define COND_DESTROY(c) \ - STMT_START { \ - if (CloseHandle(*(c)) == 0) \ - croak("panic: COND_DESTROY"); \ + STMT_START { \ + (c)->waiters = 0; \ + if (CloseHandle((c)->sem) == 0) \ + croak("panic: COND_DESTROY (%ld)",GetLastError()); \ } STMT_END #define DETACH(t) \ @@ -79,8 +95,22 @@ typedef HANDLE perl_thread; } STMT_END #define THR ((struct thread *) TlsGetValue(thr_key)) +#define THREAD_CREATE(t, f) Perl_thread_create(t, f) +#define THREAD_POST_CREATE(t) NOOP +#define THREAD_RET_TYPE DWORD WINAPI +#define THREAD_RET_CAST(p) ((DWORD)(p)) -#define HAVE_THREAD_INTERN +typedef THREAD_RET_TYPE thread_func_t(void *); + +START_EXTERN_C +void Perl_alloc_thread_key _((void)); +int Perl_thread_create _((struct thread *thr, thread_func_t *fn)); +void Perl_init_thread_intern _((struct thread *thr)); +END_EXTERN_C + +#define INIT_THREADS NOOP +#define ALLOC_THREAD_KEY Perl_alloc_thread_key() +#define INIT_THREAD_INTERN(thr) Perl_init_thread_intern(thr) #define JOIN(t, avp) \ STMT_START { \ @@ -95,8 +125,6 @@ typedef HANDLE perl_thread; croak("panic: TlsSetValue"); \ } STMT_END -#define THREAD_CREATE(t, f) thread_create(t, f) -#define THREAD_POST_CREATE(t) NOOP -#define THREAD_RET_TYPE DWORD WINAPI -#define THREAD_RET_CAST(p) ((DWORD)(p)) #define YIELD Sleep(0) + +#endif /* _WIN32THREAD_H */ |