Initial (untested) merge of all non-ansi changes on ansiperl branch
authorGurusamy Sarathy <gsar@cpan.org>
Mon, 10 Nov 1997 00:57:53 +0000 (00:57 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 10 Nov 1997 00:57:53 +0000 (00:57 +0000)
into win32 branch.

p4raw-id: //depot/win32/perl@221

29 files changed:
MANIFEST
embed.h
ext/Opcode/Opcode.pm
global.sym
interp.sym
perl.c
proto.h
sv.h
t/lib/english.t
t/lib/thread.t [new file with mode: 0644]
t/op/misc.t
t/op/nothread.t [new file with mode: 0644]
thread.h
util.c
win32/Makefile
win32/config.bc
win32/config.vc
win32/config_H.bc
win32/config_H.vc
win32/makedef.pl
win32/makefile.mk
win32/win32.c
win32/win32.h
win32/win32io.c
win32/win32io.h
win32/win32iop.h
win32/win32sck.c
win32/win32thread.c
win32/win32thread.h

index 363b264..60040c8 100644 (file)
--- 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 762ce18..46709be 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
 #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
 #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
 #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
 #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
 #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
index d2db5ec..c7d7ce3 100644 (file)
@@ -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!
index aab677c..c2c8b0b 100644 (file)
@@ -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
index 55fbeb0..ae064a8 100644 (file)
@@ -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 fff0450..3db7f17 100644 (file)
--- 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 2bfc9be..039c23f 100644 (file)
--- 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 916dc17..fcf9297 100644 (file)
--- 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__ */
index d7a30f9..68a5870 100755 (executable)
@@ -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 (file)
index 0000000..798adc1
--- /dev/null
@@ -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;
index 6156ac2..5a61acd 100755 (executable)
@@ -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 (file)
index 0000000..acc2089
--- /dev/null
@@ -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";
+ } 
index 305155c..f18b38b 100644 (file)
--- 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 72c76a0..a4472c1 100644 (file)
--- 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 */
index 19dce90..3e26dfc 100644 (file)
@@ -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)
index ad76309..3933c27 100644 (file)
@@ -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=''
index 7cc91da..2bce3b2 100644 (file)
@@ -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)'
index 61fb5a3..460b585 100644 (file)
  *     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,
index 76f19f1..4634072 100644 (file)
  *     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.
index 2ef1bb5..8bc7a8a 100644 (file)
 # 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
index 6a482ba..655efb7 100644 (file)
 # 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"
 
index 7cbfae8..e10bf2b 100644 (file)
@@ -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
 }
+
+
+
+
index dc069ba..525ef0f 100644 (file)
@@ -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
index eeb6846..0e2e649 100644 (file)
@@ -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
+
+
 
index ba4080c..0e849cf 100644 (file)
@@ -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 */
+
index 4606563..52acce1 100644 (file)
@@ -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
  */
index 3653fc8..b4ad4f4 100644 (file)
@@ -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)
index 9f63d17..dfa9a0c 100644 (file)
@@ -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
index ab0dbc5..75aa25b 100644 (file)
@@ -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 */