#include "EXTERN.h"
#include "perl.h"
+#include "perlmem.h"
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
#define FLUSH
#ifdef LEAKTEST
-static void xstat _((void));
-#endif
-#ifdef USE_THREADS
-static U32 threadnum = 0;
-#endif /* USE_THREADS */
+static void xstat _((int));
+long xcount[MAXXCOUNT];
+long lastxcount[MAXXCOUNT];
+long xycount[MAXXCOUNT][MAXYCOUNT];
+long lastxycount[MAXXCOUNT][MAXYCOUNT];
+
+#endif
#ifndef MYMALLOC
#ifdef LEAKTEST
-#define ALIGN sizeof(long)
+struct mem_test_strut {
+ union {
+ long type;
+ char c[2];
+ } u;
+ long size;
+};
+
+# define ALIGN sizeof(struct mem_test_strut)
+
+# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
+# define typeof_chunk(ch) \
+ (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
+# define set_typeof_chunk(ch,t) \
+ (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
+#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \
+ ? MAXYCOUNT - 1 \
+ : ( (size) > 40 \
+ ? ((size) - 1)/8 + 5 \
+ : ((size) - 1)/4))
Malloc_t
safexmalloc(I32 x, MEM_SIZE size)
{
- register Malloc_t where;
+ register char* where = (char*)safemalloc(size + ALIGN);
- where = safemalloc(size + ALIGN);
- xcount[x]++;
- where[0] = x % 100;
- where[1] = x / 100;
- return where + ALIGN;
+ xcount[x] += size;
+ xycount[x][SIZE_TO_Y(size)]++;
+ set_typeof_chunk(where, x);
+ sizeof_chunk(where) = size;
+ return (Malloc_t)(where + ALIGN);
}
Malloc_t
-safexrealloc(Malloc_t where, MEM_SIZE size)
+safexrealloc(Malloc_t wh, MEM_SIZE size)
{
- register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN);
- return new + ALIGN;
+ char *where = (char*)wh;
+
+ if (!wh)
+ return safexmalloc(0,size);
+
+ {
+ MEM_SIZE old = sizeof_chunk(where - ALIGN);
+ int t = typeof_chunk(where - ALIGN);
+ register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
+
+ xycount[t][SIZE_TO_Y(old)]--;
+ xycount[t][SIZE_TO_Y(size)]++;
+ xcount[t] += size - old;
+ sizeof_chunk(new) = size;
+ return (Malloc_t)(new + ALIGN);
+ }
}
void
-safexfree(Malloc_t where)
+safexfree(Malloc_t wh)
{
I32 x;
-
+ char *where = (char*)wh;
+ MEM_SIZE size;
+
if (!where)
return;
where -= ALIGN;
+ size = sizeof_chunk(where);
x = where[0] + 100 * where[1];
- xcount[x]--;
+ xcount[x] -= size;
+ xycount[x][SIZE_TO_Y(size)]--;
safefree(where);
}
Malloc_t
safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
{
- register Malloc_t where;
-
- where = safexmalloc(x, size * count + ALIGN);
- xcount[x]++;
- memset((void*)where + ALIGN, 0, size * count);
- where[0] = x % 100;
- where[1] = x / 100;
- return where + ALIGN;
+ register char * where = (char*)safexmalloc(x, size * count + ALIGN);
+ xcount[x] += size;
+ xycount[x][SIZE_TO_Y(size)]++;
+ memset((void*)(where + ALIGN), 0, size * count);
+ set_typeof_chunk(where, x);
+ sizeof_chunk(where) = size;
+ return (Malloc_t)(where + ALIGN);
}
static void
-xstat(void)
+xstat(int flag)
{
- register I32 i;
+ register I32 i, j, total = 0;
+ I32 subtot[MAXYCOUNT];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ subtot[j] = 0;
+ }
+
+ PerlIO_printf(PerlIO_stderr(), " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
for (i = 0; i < MAXXCOUNT; i++) {
- if (xcount[i] > lastxcount[i]) {
- PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
+ total += xcount[i];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ subtot[j] += xycount[i][j];
+ }
+ if (flag == 0
+ ? xcount[i] /* Have something */
+ : (flag == 2
+ ? xcount[i] != lastxcount[i] /* Changed */
+ : xcount[i] > lastxcount[i])) { /* Growed */
+ PerlIO_printf(PerlIO_stderr(),"%2d %02d %7ld ", i / 100, i % 100,
+ flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
lastxcount[i] = xcount[i];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ if ( flag == 0
+ ? xycount[i][j] /* Have something */
+ : (flag == 2
+ ? xycount[i][j] != lastxycount[i][j] /* Changed */
+ : xycount[i][j] > lastxycount[i][j])) { /* Growed */
+ PerlIO_printf(PerlIO_stderr(),"%3ld ",
+ flag == 2
+ ? xycount[i][j] - lastxycount[i][j]
+ : xycount[i][j]);
+ lastxycount[i][j] = xycount[i][j];
+ } else {
+ PerlIO_printf(PerlIO_stderr(), " . ", xycount[i][j]);
+ }
+ }
+ PerlIO_printf(PerlIO_stderr(), "\n");
}
}
+ if (flag != 2) {
+ PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total);
+ for (j = 0; j < MAXYCOUNT; j++) {
+ if (subtot[j]) {
+ PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]);
+ } else {
+ PerlIO_printf(PerlIO_stderr(), " . ");
+ }
+ }
+ PerlIO_printf(PerlIO_stderr(), "\n");
+ }
}
#endif /* LEAKTEST */
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
- char *lc_all = PerlENV_getenv("LC_ALL");
- char *lang = PerlENV_getenv("LANG");
+ char *lc_all = PerlEnv_getenv("LC_ALL");
+ char *lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
#ifdef LOCALE_ENVIRON_REQUIRED
{
#ifdef USE_LOCALE_CTYPE
if (! (curctype = setlocale(LC_CTYPE,
- (!done && (lang || PerlENV_getenv("LC_CTYPE")))
+ (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll = setlocale(LC_COLLATE,
- (!done && (lang || PerlENV_getenv("LC_COLLATE")))
+ (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum = setlocale(LC_NUMERIC,
- (!done && (lang || PerlENV_getenv("LC_NUMERIC")))
+ (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_NUMERIC */
char *p;
bool locwarn = (printwarn > 1 ||
printwarn &&
- (!(p = PerlENV_getenv("PERL_BADLANG")) || atoi(p)));
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
if (locwarn) {
#ifdef LC_ALL
#endif /* USE_LOCALE_COLLATE */
void
-fbm_compile(SV *sv)
+fbm_compile(SV *sv, U32 flags /* not used yet */)
{
register unsigned char *s;
register unsigned char *table;
"%p: die: curstack = %p, mainstack = %p\n",
thr, curstack, mainstack));
#endif /* USE_THREADS */
- /* We have to switch back to mainstack or die_where may try to pop
- * the eval block from the wrong stack if die is being called from a
- * signal handler. - dkindred@cs.cmu.edu */
- if (curstack != mainstack) {
- dSP;
- SWITCHSTACK(curstack, mainstack);
- }
#ifdef I_STDARG
va_start(args, pat);
SvREADONLY_on(msg);
SAVEFREESV(msg);
- PUSHMARK(sp);
+ PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
SvREADONLY_on(msg);
SAVEFREESV(msg);
- PUSHMARK(sp);
+ PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
SvREADONLY_on(msg);
SAVEFREESV(msg);
- PUSHMARK(sp);
+ PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
}
PerlIO_puts(PerlIO_stderr(),message);
#ifdef LEAKTEST
- DEBUG_L(xstat());
+ DEBUG_L(*message == '!'
+ ? (xstat(message[1]=='!'
+ ? (message[2]=='!' ? 2 : 1)
+ : 0)
+ , 0)
+ : 0);
#endif
(void)PerlIO_flush(PerlIO_stderr());
}
vallen = strlen(val);
New(904, envstr, namlen + vallen + 3, char);
(void)sprintf(envstr,"%s=%s",nam,val);
- (void)PerlENV_putenv(envstr);
+ (void)PerlEnv_putenv(envstr);
if (oldstr)
Safefree(oldstr);
#ifdef _MSC_VER
#ifdef MYSWAP
#if BYTEORDER != 0x4321
short
-#ifndef CAN_PROTOTYPE
-my_swap(s)
-short s;
-#else
my_swap(short s)
-#endif
{
#if (BYTEORDER & 1) == 0
short result;
}
long
-#ifndef CAN_PROTOTYPE
-my_htonl(l)
-register long l;
-#else
my_htonl(long l)
-#endif
{
union {
long result;
}
long
-#ifndef CAN_PROTOTYPE
-my_ntohl(l)
-register long l;
-#else
my_ntohl(long l)
-#endif
{
union {
long l;
return my_syspopen(cmd,mode);
}
#endif
- if (PerlProc_pipe(p) < 0)
- return Nullfp;
This = (*mode == 'w');
that = !This;
if (doexec && tainting) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
+ if (PerlProc_pipe(p) < 0)
+ return Nullfp;
while ((pid = (doexec?vfork():fork())) < 0) {
if (errno != EAGAIN) {
PerlLIO_close(p[This]);
sv_setpv(tmpsv, ".");
else
sv_setpvn(tmpsv, a, fa - a);
- if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
+ if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
return FALSE;
if (fb == b)
sv_setpv(tmpsv, ".");
else
sv_setpvn(tmpsv, b, fb - b);
- if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
+ if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
return FALSE;
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
COND_INIT(&cp->owner_cond);
COND_INIT(&cp->cond);
cp->owner = 0;
- MUTEX_LOCK(&sv_mutex);
+ LOCK_SV_MUTEX;
mg = mg_find(sv, 'm');
if (mg) {
/* someone else beat us to initialising it */
- MUTEX_UNLOCK(&sv_mutex);
+ UNLOCK_SV_MUTEX;
MUTEX_DESTROY(&cp->mutex);
COND_DESTROY(&cp->owner_cond);
COND_DESTROY(&cp->cond);
mg = SvMAGIC(sv);
mg->mg_ptr = (char *)cp;
mg->mg_len = sizeof(cp);
- MUTEX_UNLOCK(&sv_mutex);
+ UNLOCK_SV_MUTEX;
DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
"%p: condpair_magic %p\n", thr, sv));)
}
"new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
}
}
+ thr->threadsvp = AvARRAY(thr->threadsv);
MUTEX_LOCK(&threads_mutex);
nthreads++;
projects / p5sagit/p5-mst-13.2.git / blobdiff