into win32 branch.
p4raw-id: //depot/win32/perl@221
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
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
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
#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
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!
# Global symbols that need to be hidden in embedded applications.
# Variables
+nthreads_cond
+threads_mutex
AMG_names
Error
# Functions
Gv_AMupdate
-SvTRUE
-SvIV
-SvUV
-SvNV
+sv_true
+sv_iv
+sv_uv
+sv_nv
amagic_call
append_elem
append_list
newPVOP
newRANGE
newRV
+newRV_noinc
newSLICEOP
newSTATEOP
newSUB
multiline
mystrk
nrs
-nthreads
-nthreads_cond
ofmt
ofs
ofslen
tainted
tainting
thrsv
-threads_mutex
tmps_floor
tmps_ix
tmps_max
#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);
/*
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, ...));
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
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));
#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 */
#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__ */
BEGIN { @INC = '../lib' }
use English;
+use Config;
+my $threads = $Config{'ccflags'} =~ /-DUSE_THREADS\b/;
print $PID == $$ ? "ok 1\n" : "not ok 1\n";
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);
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";
--- /dev/null
+#!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;
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
--- /dev/null
+#!./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";
+ }
#ifdef USE_THREADS
#ifdef WIN32
-# include "win32/win32thread.h"
-#endif
+# include <win32thread.h>
+#else
/* POSIXish threads */
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()
# endif
#endif
+
#ifndef THREAD_RET_TYPE
# define THREAD_RET_TYPE void *
# define THREAD_RET_CAST(p) ((void *)(p))
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
#undef chopset
#undef formtarget
#undef bodytarget
+#undef start_env
#undef toptarget
#undef top_env
#undef runlevel
#define top_env (thr->Ttop_env)
#define runlevel (thr->Trunlevel)
+#define start_env (thr->Tstart_env)
#else
/* USE_THREADS is not defined */
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;
/* end debug */
thr->oursv = sv;
- init_stacks(thr);
+ init_stacks(ARGS);
curcop = &compiling;
thr->cvcache = newHV();
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;
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));
}
}
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 */
# 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
!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"
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 #######################
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 \
$(OPCODE_DLL) \
$(SDBM_FILE_DLL)\
$(IO_DLL) \
- $(ATTRS_DLL) \
+ $(ATTRS_DLL) \
$(THREAD_DLL)
POD2HTML=$(PODDIR)\pod2html
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)" \
$(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:$@ @<<
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
$(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)
c=''
castflags='0'
cat='type'
-cccdlflags=''
+cccdlflags=' '
ccdlflags=' '
cf_by='garyng'
cf_email='71564.1743@compuserve.com'
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'
large=''
ld='tlink32'
lddlflags='-Tpd'
-ldflags=''
+ldflags='~LINK_FLAGS~'
less='less'
lib_ext='.lib'
libc='cw32mti.lib'
privlib='~INST_TOP~\lib'
prototype='define'
randbits='15'
-ranlib=''
+ranlib='rem'
rd_nodata='-1'
rm='del'
rmail=''
c=''
castflags='0'
cat='type'
-cccdlflags=''
+cccdlflags=' '
ccdlflags=' '
cf_by='garyng'
cf_email='71564.1743@compuserve.com'
privlib='~INST_TOP~\lib'
prototype='define'
randbits='15'
-ranlib=''
+ranlib='rem'
rd_nodata='-1'
rm='del'
rmail=''
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)'
* 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,
* 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.
# 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
Perl_force_word
Perl_hv_stashpv
Perl_intuit_more
+Perl_init_thread_intern
Perl_know_next
Perl_modkids
Perl_mstats
Perl_pp_map
Perl_pp_nswitch
Perl_q
+Perl_rcsid
Perl_reall_srchlen
Perl_regdump
Perl_regfold
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.
next if (/^#/);
$symbol = $_;
next if ($skip_sym =~ m/^$symbol/m);
+ $symbol = "Perl_".$symbol if ($define{'USE_THISPTR'}
+ && $symbol =~ /^perl/);
emit_symbol($symbol);
}
perl_eval_pv
perl_eval_sv
boot_DynaLoader
+Perl_thread_create
win32_errno
win32_environ
win32_stdin
# 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
#
# 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
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
OPTIMIZE = -v $(RUNTIME)
LINK_DBG = -v
.ELSE
-OPTIMIZE = -O $(RUNTIME)
+OPTIMIZE = -5 -O2 $(RUNTIME)
LINK_DBG =
.ENDIF
.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
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 \
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
"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
$(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"
.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"
}
int
-do_aspawn(void* really, void** mark, void** arglast)
+do_aspawn(void* really, void ** mark, void ** arglast)
{
char **argv;
char *strPtr;
/* 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;
}
#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;
}
DllExport FILE *
win32_fdopen( int handle, const char *mode)
{
- return pIOSubSystem->pfnfdopen(handle, mode);
+ return pIOSubSystem->pfnfdopen(handle, (char *) mode);
}
DllExport FILE *
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
_control87(MCW_EM, MCW_EM);
#endif
}
+
+
+
+
#endif
+#ifdef __cplusplus
+extern "C" {
+#endif
+
extern uid_t getuid(void);
extern gid_t getgid(void);
extern uid_t geteuid(void);
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
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
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). */
/*
#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
-#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>
#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"
/*
#undef LK_ERR
#undef LK_LEN
-EXT int my_fclose(FILE *pf);
#ifdef PERLDLL
__declspec(dllexport)
};
-#ifdef __cplusplus
-}
-#endif
+
+
#ifdef __BORLANDC__
#include <stdarg.h>
+#define MSconst
+#else
+#define MSconst const
#endif
typedef struct {
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);
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);
typedef WIN32_IOSUBSYSTEM *PWIN32_IOSUBSYSTEM;
#endif /* WIN32IO_H */
+
#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.
/*
* 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);
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
*/
#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)
#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(),
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
-/*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;
* 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 { \
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) \
} 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 { \
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 */
projects / p5sagit/p5-mst-13.2.git / commitdiff