diff options
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | miniperlmain.c | 4 | ||||
| -rw-r--r-- | op.c | 3 | ||||
| -rw-r--r-- | perl.c | 7 | ||||
| -rw-r--r-- | perl.h | 4 | ||||
| -rw-r--r-- | pp_ctl.c | 4 | ||||
| -rw-r--r-- | sv.c | 4 | ||||
| -rw-r--r-- | toke.c | 25 | ||||
| -rw-r--r-- | win32/Makefile | 10 | ||||
| -rw-r--r-- | win32/config.bc | 2 | ||||
| -rw-r--r-- | win32/config.vc | 2 | ||||
| -rw-r--r-- | win32/config_H.bc | 2 | ||||
| -rw-r--r-- | win32/config_H.vc | 2 | ||||
| -rw-r--r-- | win32/makedef.pl | 36 | ||||
| -rw-r--r-- | win32/makefile.mk | 6 | ||||
| -rw-r--r-- | win32/perllib.c | 4 | ||||
| -rw-r--r-- | win32/win32.c | 106 | ||||
| -rw-r--r-- | win32/win32.h | 18 | ||||
| -rw-r--r-- | win32/win32iop.h | 7 | ||||
| -rw-r--r-- | win32/win32thread.c | 14 | ||||
| -rw-r--r-- | win32/win32thread.h | 25 |
21 files changed, 254 insertions, 32 deletions
diff --git a/global.sym b/global.sym index ebd6d7e3f5..46378729d6 100644 --- a/global.sym +++ b/global.sym @@ -975,6 +975,7 @@ pp_tied pp_time pp_tms pp_trans +pp_threadsv pp_truncate pp_uc pp_ucfirst diff --git a/miniperlmain.c b/miniperlmain.c index 27ad541fb4..81e649344d 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -25,6 +25,10 @@ char **env; { int exitstatus; +#ifdef USE_THREADS + MUTEX_INIT(&malloc_mutex); +#endif + PERL_SYS_INIT(&argc,&argv); perl_init_i18nl10n(1); @@ -531,10 +531,9 @@ find_threadsv(char *name) case '\'': sawampersand = TRUE; SvREADONLY_on(sv); - sv_magic(sv, 0, 0, name, 1); - break; default: sv_magic(sv, 0, 0, name, 1); + break; } DEBUG_L(PerlIO_printf(PerlIO_stderr(), "find_threadsv: new SV %p for $%s%c\n", @@ -1686,6 +1686,9 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") break; case '-': case 0: +#ifdef WIN32 + case '\r': +#endif case '\n': case '\t': break; @@ -1987,7 +1990,7 @@ SV *sv; if (strEQ(origfilename,"-")) scriptname = ""; if (fdscript >= 0) { - rsfp = PerlIO_fdopen(fdscript,"r"); + rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ @@ -2071,7 +2074,7 @@ sed %s -e \"/^[^#]/b\" \ rsfp = PerlIO_stdin(); } else { - rsfp = PerlIO_open(scriptname,"r"); + rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ @@ -2297,6 +2297,10 @@ EXT bool numeric_local INIT(TRUE); /* Assume local numerics */ #define printf PerlIO_stdoutf #endif +#ifndef PERL_SCRIPT_MODE +#define PERL_SCRIPT_MODE "r" +#endif + /* * nice_chunk and nice_chunk size need to be set * and queried under the protection of sv_mutex @@ -2378,7 +2378,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,"r"); + tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(incgv); @@ -2401,7 +2401,7 @@ PP(pp_require) sv_setpvf(namesv, "%s/%s", dir, name); #endif tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, "r"); + tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -3219,6 +3219,10 @@ screamer2: } } +#ifdef WIN32 + win32_strip_return(sv); +#endif + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -187,7 +187,7 @@ missingterm(char *s) char q; if (s) { char *nl = strrchr(s,'\n'); - if (nl) + if (nl) *nl = '\0'; } else if (multi_close < 32 || multi_close == 127) { @@ -219,6 +219,19 @@ depcom(void) deprecate("comma-less variable list"); } +#ifdef WIN32 + +static I32 +win32_textfilter(int idx, SV *sv, int maxlen) +{ + I32 count = FILTER_READ(idx+1, sv, maxlen); + if (count > 0 && !maxlen) + win32_strip_return(sv); + return count; +} +#endif + + void lex_start(SV *line) { @@ -1158,6 +1171,7 @@ filter_read(int idx, SV *buf_sv, int maxlen) else return 0 ; /* end of file */ } + } return SvCUR(buf_sv); } @@ -1178,9 +1192,15 @@ filter_read(int idx, SV *buf_sv, int maxlen) return (*funcp)(idx, buf_sv, maxlen); } + static char * filter_gets(register SV *sv, register FILE *fp, STRLEN append) { +#ifdef WIN32FILTER + if (!rsfp_filters) { + filter_add(win32_textfilter,NULL); + } +#endif if (rsfp_filters) { if (!append) @@ -1192,7 +1212,6 @@ filter_gets(register SV *sv, register FILE *fp, STRLEN append) } else return (sv_gets(sv, fp, append)); - } @@ -1723,9 +1742,11 @@ yylex(void) } goto retry; case '\r': +#ifndef WIN32CHEAT warn("Illegal character \\%03o (carriage return)", '\r'); croak( "(Maybe you didn't strip carriage returns after a network transfer?)\n"); +#endif case ' ': case '\t': case '\f': case 013: s++; goto retry; diff --git a/win32/Makefile b/win32/Makefile index d2e464145a..8993691b42 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -20,7 +20,7 @@ CORECCOPT= # # uncomment next line if you want debug version of perl (big,slow) -#CFG=Debug +CFG=Debug # # set the install locations of the compiler include/libraries @@ -166,7 +166,8 @@ CORE_C= ..\av.c \ ..\taint.c \ ..\toke.c \ ..\universal.c \ - ..\util.c + ..\util.c \ + ..\malloc.c CORE_OBJ= ..\av.obj \ ..\deb.obj \ @@ -193,7 +194,8 @@ CORE_OBJ= ..\av.obj \ ..\taint.obj \ ..\toke.obj \ ..\universal.obj\ - ..\util.obj + ..\util.obj \ + ..\malloc.obj WIN32_C = perllib.c \ win32.c \ @@ -335,7 +337,7 @@ $(WIN32_OBJ) : $(CORE_H) $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) -perldll.def : $(MINIPERL) $(CONFIGPM) +perldll.def : $(MINIPERL) $(CONFIGPM) makedef.pl $(MINIPERL) -w makedef.pl $(DEFINES) $(CCTYPE) > perldll.def $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) diff --git a/win32/config.bc b/win32/config.bc index e3559a041a..7554ae5bd8 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -162,7 +162,7 @@ d_msgctl='define' d_msgget='define' d_msgrcv='define' d_msgsnd='define' -d_mymalloc='undef' +d_mymalloc='define' d_nice='undef' d_oldarchlib='undef' d_oldsock='undef' diff --git a/win32/config.vc b/win32/config.vc index c117689b0b..4e12767fd8 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -162,7 +162,7 @@ d_msgctl='define' d_msgget='define' d_msgrcv='define' d_msgsnd='define' -d_mymalloc='undef' +d_mymalloc='define' d_nice='undef' d_oldarchlib='undef' d_oldsock='undef' diff --git a/win32/config_H.bc b/win32/config_H.bc index 3ba2481a0f..ad7bcaf5a4 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -1654,7 +1654,7 @@ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ -/*#define MYMALLOC /**/ +#define MYMALLOC /**/ /* OLDARCHLIB: * This variable, if defined, holds the name of the directory in diff --git a/win32/config_H.vc b/win32/config_H.vc index d2c6d47afb..12321b23ef 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -1654,7 +1654,7 @@ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ -/*#define MYMALLOC /**/ +#define MYMALLOC /**/ /* OLDARCHLIB: * This variable, if defined, holds the name of the directory in diff --git a/win32/makedef.pl b/win32/makedef.pl index abc89d848a..55b3e29bcd 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -20,10 +20,23 @@ while (@ARGV && $ARGV[0] =~ /^-/) $define{$1} = 1 if ($flag =~ /^-D(\w+)$/); } +open(CFG,'config.h') || die "Cannot open config.h:$!"; +while (<CFG>) + { + $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/; + } +close(CFG); + warn join(' ',keys %define)."\n"; my $CCTYPE = shift || "MSVC"; +print "LIBRARY Perl\n"; +print "DESCRIPTION 'Perl interpreter, export autogenerated'\n"; +print "CODE LOADONCALL\n"; +print "DATA LOADONCALL NONSHARED MULTIPLE\n"; +print "EXPORTS\n"; + $skip_sym=<<'!END!OF!SKIP!'; Perl_block_type Perl_additem @@ -143,6 +156,20 @@ Perl_cshname Perl_opsave !END!OF!SKIP! +if ($define{'MYMALLOC'}) + { + $skip_sym .= <<'!END!OF!SKIP!'; +Perl_safefree +Perl_safemalloc +Perl_saferealloc +Perl_safecalloc +!END!OF!SKIP! + emit_symbol('Perl_malloc'); + emit_symbol('Perl_free'); + emit_symbol('Perl_realloc'); + emit_symbol('Perl_calloc'); + } + unless ($define{'USE_THREADS'}) { $skip_sym .= <<'!END!OF!SKIP!'; @@ -193,12 +220,6 @@ unless ($define{'USE_THREADS'}) # sticks in front of them. -print "LIBRARY Perl\n"; -print "DESCRIPTION 'Perl interpreter, export autogenerated'\n"; -print "CODE LOADONCALL\n"; -print "DATA LOADONCALL NONSHARED MULTIPLE\n"; -print "EXPORTS\n"; - open (GLOBAL, "<../global.sym") || die "failed to open global.sym" . $!; while (<GLOBAL>) { my $symbol; @@ -232,6 +253,7 @@ while (<DATA>) { my $symbol; next if (!/^[A-Za-z]/); next if (/^#/); + s/\r//g; $symbol = $_; next if ($skip_sym =~ m/^$symbol/m); $symbol = "Perl_".$symbol if ($define{'USE_THISPTR'} @@ -402,4 +424,6 @@ win32_open_osfhandle win32_get_osfhandle Perl_win32_init Perl_init_os_extras +Perl_getTHR +Perl_setTHR RunPerl diff --git a/win32/makefile.mk b/win32/makefile.mk index 2b7dc8ccbe..03788c731e 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -234,7 +234,8 @@ CORE_C= ..\av.c \ ..\taint.c \ ..\toke.c \ ..\universal.c \ - ..\util.c + ..\util.c \ + ..\malloc.c CORE_OBJ= ..\av.obj \ ..\deb.obj \ @@ -261,7 +262,8 @@ CORE_OBJ= ..\av.obj \ ..\taint.obj \ ..\toke.obj \ ..\universal.obj\ - ..\util.obj + ..\util.obj \ + ..\malloc.obj WIN32_C = perllib.c \ win32.c \ diff --git a/win32/perllib.c b/win32/perllib.c index 848360698b..c24941f111 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -15,6 +15,10 @@ RunPerl(int argc, char **argv, char **env, void *iosubsystem) int exitstatus; PerlInterpreter *my_perl; +#ifdef USE_THREADS + MUTEX_INIT(&malloc_mutex); +#endif + PERL_SYS_INIT(&argc,&argv); perl_init_i18nl10n(1); diff --git a/win32/win32.c b/win32/win32.c index 4551679f58..28454e80c6 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1303,6 +1303,85 @@ win32_putchar(int c) return putchar(c); } +#ifdef MYMALLOC + +#ifndef USE_PERL_SBRK + +static char *committed = NULL; +static char *base = NULL; +static char *reserved = NULL; +static char *brk = NULL; +static DWORD pagesize = 0; +static DWORD allocsize = 0; + +void * +sbrk(int need) +{ + void *result; + if (!pagesize) + {SYSTEM_INFO info; + GetSystemInfo(&info); + /* Pretend page size is larger so we don't perpetually + * call the OS to commit just one page ... + */ + pagesize = info.dwPageSize << 3; + allocsize = info.dwAllocationGranularity; + } + /* This scheme fails eventually if request for contiguous + * block is denied so reserve big blocks - this is only + * address space not memory ... + */ + if (brk+need >= reserved) + { + DWORD size = 64*1024*1024; + char *addr; + if (committed && reserved && committed < reserved) + { + /* Commit last of previous chunk cannot span allocations */ + addr = VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE); + if (addr) + committed = reserved; + } + /* Reserve some (more) space + * Note this is a little sneaky, 1st call passes NULL as reserved + * so lets system choose where we start, subsequent calls pass + * the old end address so ask for a contiguous block + */ + addr = VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS); + if (addr) + { + reserved = addr+size; + if (!base) + base = addr; + if (!committed) + committed = base; + if (!brk) + brk = committed; + } + else + { + return (void *) -1; + } + } + result = brk; + brk += need; + if (brk > committed) + { + DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize; + char *addr = VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE); + if (addr) + { + committed += size; + } + else + return (void *) -1; + } + return result; +} + +#endif +#endif + DllExport void* win32_malloc(size_t size) { @@ -1327,6 +1406,7 @@ win32_free(void *block) free(block); } + int win32_open_osfhandle(long handle, int flags) { @@ -1645,6 +1725,32 @@ Perl_win32_init(int *argcp, char ***argvp) #endif } +#ifdef USE_BINMODE_SCRIPTS + +void +win32_strip_return(SV *sv) +{ + char *s = SvPVX(sv); + char *e = s+SvCUR(sv); + char *d = s; + while (s < e) + { + if (*s == '\r' && s[1] == '\n') + { + *d++ = '\n'; + s += 2; + } + else + { + *d++ = *s++; + } + } + SvCUR_set(sv,d-SvPVX(sv)); +} + +#endif + + diff --git a/win32/win32.h b/win32/win32.h index 18bf8a2e96..9086f31701 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -145,4 +145,22 @@ typedef char * caddr_t; /* In malloc.c (core address). */ #include <sys/socket.h> #include <netdb.h> +#ifdef MYMALLOC +#define EMBEDMYMALLOC /**/ +/* #define USE_PERL_SBRK /**/ +/* #define PERL_SBRK_VIA_MALLOC /**/ +#endif + +#ifdef PERLDLL +#define PERL_CORE +#endif + +#ifdef USE_BINMODE_SCRIPTS +#define PERL_SCRIPT_MODE "rb" +EXT void win32_strip_return(struct sv *sv); +#else +#define PERL_SCRIPT_MODE "r" +#define win32_strip_return(sv) NOOP +#endif + #endif /* _INC_WIN32_PERL5 */ diff --git a/win32/win32iop.h b/win32/win32iop.h index a60194d0f0..bd70def18e 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -219,10 +219,17 @@ END_EXTERN_C #define puts win32_puts #define getchar win32_getchar #define putchar win32_putchar + +#if !defined(MYMALLOC) || !defined(PERLDLL) +#undef malloc +#undef calloc +#undef realloc +#undef free #define malloc win32_malloc #define calloc win32_calloc #define realloc win32_realloc #define free win32_free +#endif #define pipe(fd) win32_pipe((fd), 512, O_BINARY) #define pause() win32_sleep((32767L << 16) + 32767) diff --git a/win32/win32thread.c b/win32/win32thread.c index 4dbc750b05..c0c3c60239 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -1,6 +1,20 @@ #include "EXTERN.h" #include "perl.h" +__declspec(thread) struct thread *Perl_current_thread = NULL; + +void +Perl_setTHR(struct thread *t) +{ + Perl_current_thread = t; +} + +struct thread * +Perl_getTHR(void) +{ + return Perl_current_thread; +} + void Perl_alloc_thread_key(void) { diff --git a/win32/win32thread.h b/win32/win32thread.h index 0c6bb55b69..38e66e9fc9 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -97,7 +97,7 @@ typedef HANDLE perl_mutex; } \ } 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 @@ -105,14 +105,28 @@ typedef HANDLE perl_mutex; typedef THREAD_RET_TYPE thread_func_t(void *); + START_EXTERN_C + +#if defined(PERLDLL) && (!defined(__BORLANDC__) || defined(_DLL)) +extern __declspec(thread) struct thread *Perl_current_thread; +#define SET_THR(t) (Perl_current_thread = t) +#define THR Perl_current_thread +#else +#define THR Perl_getTHR() +#define SET_THR(t) Perl_setTHR(t) +#endif + void Perl_alloc_thread_key _((void)); int Perl_thread_create _((struct thread *thr, thread_func_t *fn)); void Perl_set_thread_self _((struct thread *thr)); +struct thread *Perl_getTHR _((void)); +void Perl_setTHR _((struct thread *t)); + END_EXTERN_C #define INIT_THREADS NOOP -#define ALLOC_THREAD_KEY Perl_alloc_thread_key() +#define ALLOC_THREAD_KEY NOOP #define SET_THREAD_SELF(thr) Perl_set_thread_self(thr) #define JOIN(t, avp) \ @@ -122,12 +136,7 @@ END_EXTERN_C croak("panic: JOIN"); \ } STMT_END -#define SET_THR(t) \ - STMT_START { \ - if (TlsSetValue(thr_key, (void *) (t)) == 0) \ - croak("panic: TlsSetValue"); \ - } STMT_END - #define YIELD Sleep(0) #endif /* _WIN32THREAD_H */ + |