summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGurusamy Sarathy <gsar@cpan.org>1997-11-10 00:57:53 +0000
committerGurusamy Sarathy <gsar@cpan.org>1997-11-10 00:57:53 +0000
commitd55594aef6b1fb9e305275c3d19a25e4cdfb2cda (patch)
treef7d6379858b9595f060beee6161b43a373132fe9
parent5cb186c2cd2ac09e46b98e7cfd9fde70c8a3481c (diff)
downloadperl-d55594aef6b1fb9e305275c3d19a25e4cdfb2cda.tar.gz
Initial (untested) merge of all non-ansi changes on ansiperl branch
into win32 branch. p4raw-id: //depot/win32/perl@221
-rw-r--r--MANIFEST4
-rw-r--r--embed.h11
-rw-r--r--ext/Opcode/Opcode.pm2
-rw-r--r--global.sym11
-rw-r--r--interp.sym3
-rw-r--r--perl.c4
-rw-r--r--proto.h9
-rw-r--r--sv.h22
-rwxr-xr-xt/lib/english.t8
-rw-r--r--t/lib/thread.t54
-rwxr-xr-xt/op/misc.t9
-rw-r--r--t/op/nothread.t35
-rw-r--r--thread.h10
-rw-r--r--util.c40
-rw-r--r--win32/Makefile32
-rw-r--r--win32/config.bc8
-rw-r--r--win32/config.vc6
-rw-r--r--win32/config_H.bc2
-rw-r--r--win32/config_H.vc2
-rw-r--r--win32/makedef.pl60
-rw-r--r--win32/makefile.mk32
-rw-r--r--win32/win32.c84
-rw-r--r--win32/win32.h30
-rw-r--r--win32/win32io.c24
-rw-r--r--win32/win32io.h10
-rw-r--r--win32/win32iop.h24
-rw-r--r--win32/win32sck.c7
-rw-r--r--win32/win32thread.c31
-rw-r--r--win32/win32thread.h94
29 files changed, 506 insertions, 162 deletions
diff --git a/MANIFEST b/MANIFEST
index 363b264919..60040c876b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/embed.h b/embed.h
index 762ce18fab..46709be1c1 100644
--- a/embed.h
+++ b/embed.h
@@ -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
diff --git a/perl.c b/perl.c
index fff0450593..3db7f175ff 100644
--- a/perl.c
+++ b/perl.c
@@ -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);
/*
diff --git a/proto.h b/proto.h
index 2bfc9be3d5..039c23f878 100644
--- a/proto.h
+++ b/proto.h
@@ -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));
diff --git a/sv.h b/sv.h
index 916dc17fe6..fcf92975f4 100644
--- a/sv.h
+++ b/sv.h
@@ -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";
+ }
diff --git a/thread.h b/thread.h
index 305155c3ff..f18b38b797 100644
--- a/thread.h
+++ b/thread.h
@@ -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 */
diff --git a/util.c b/util.c
index 72c76a0ade..a4472c1d33 100644
--- a/util.c
+++ b/util.c
@@ -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 */