Rework constant.pm to take advantage of the space savings of proxy

[p5sagit/p5-mst-13.2.git] / util.c

diff --git a/util.c b/util.c
index 67ed393..5263dd4 100644 (file)
--- a/util.c
+++ b/util.c
@@ -64,7 +64,7 @@ S_write_no_mem(pTHX)
     PerlLIO_write(PerlIO_fileno(Perl_error_log),
                  PL_no_mem, strlen(PL_no_mem));
     my_exit(1);
-    return Nullch;
+    NORETURN_FUNCTION_END;
 }
 
 /* paranoid version of system's malloc() */
@@ -81,6 +81,9 @@ Perl_safesysmalloc(MEM_SIZE size)
            my_exit(1);
        }
 #endif /* HAS_64K_LIMIT */
+#ifdef PERL_TRACK_MEMPOOL
+    size += sTHX;
+#endif
 #ifdef DEBUGGING
     if ((long)size < 0)
        Perl_croak_nocontext("panic: malloc");
@@ -88,12 +91,21 @@ Perl_safesysmalloc(MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-    if (ptr != Nullch)
+    if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+        ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+#  ifdef PERL_POISON
+        ((struct perl_memory_debug_header *)ptr)->size = size;
+        ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+#  endif
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
        return ptr;
+}
     else if (PL_nomemok)
        return Nullch;
     else {
-       return S_write_no_mem(aTHX);
+       return write_no_mem();
     }
     /*NOTREACHED*/
 }
@@ -123,6 +135,23 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 
     if (!where)
        return safesysmalloc(size);
+#ifdef PERL_TRACK_MEMPOOL
+    where = (Malloc_t)((char*)where-sTHX);
+    size += sTHX;
+    if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
+       /* int *nowhere = NULL; *nowhere = 0; */
+        Perl_croak_nocontext("panic: realloc from wrong pool");
+    }
+#  ifdef PERL_POISON
+    if (((struct perl_memory_debug_header *)where)->size > size) {
+       const MEM_SIZE freed_up =
+           ((struct perl_memory_debug_header *)where)->size - size;
+       char *start_of_freed = ((char *)where) + size;
+       Poison(start_of_freed, freed_up, char);
+    }
+    ((struct perl_memory_debug_header *)where)->size = size;
+#  endif
+#endif
 #ifdef DEBUGGING
     if ((long)size < 0)
        Perl_croak_nocontext("panic: realloc");
@@ -133,12 +162,16 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 
-    if (ptr != Nullch)
+    if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
        return ptr;
+    }
     else if (PL_nomemok)
        return Nullch;
     else {
-       return S_write_no_mem(aTHX);
+       return write_no_mem();
     }
     /*NOTREACHED*/
 }
@@ -149,11 +182,33 @@ Free_t
 Perl_safesysfree(Malloc_t where)
 {
     dVAR;
-#ifdef PERL_IMPLICIT_SYS
+#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
     dTHX;
 #endif
     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
     if (where) {
+#ifdef PERL_TRACK_MEMPOOL
+        where = (Malloc_t)((char*)where-sTHX);
+        if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
+           /* int *nowhere = NULL; *nowhere = 0; */
+            Perl_croak_nocontext("panic: free from wrong pool");
+       }
+#  ifdef PERL_POISON
+       {
+           if (((struct perl_memory_debug_header *)where)->in_use
+               == PERL_POISON_FREE) {
+               Perl_croak_nocontext("panic: duplicate free");
+           }
+           if (((struct perl_memory_debug_header *)where)->in_use
+               != PERL_POISON_INUSE) {
+               Perl_croak_nocontext("panic: bad free ");
+           }
+           ((struct perl_memory_debug_header *)where)->in_use
+               = PERL_POISON_FREE;
+       }
+       Poison(where, ((struct perl_memory_debug_header *)where)->size, char);
+#  endif
+#endif
        PerlMem_free(where);
     }
 }
@@ -178,19 +233,27 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
        Perl_croak_nocontext("panic: calloc");
 #endif
     size *= count;
+#ifdef PERL_TRACK_MEMPOOL
+    size += sTHX;
+#endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
     if (ptr != Nullch) {
        memset((void*)ptr, 0, size);
+#ifdef PERL_TRACK_MEMPOOL
+        ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+#  ifdef PERL_POISON
+        ((struct perl_memory_debug_header *)ptr)->size = size;
+        ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+#  endif
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
        return ptr;
     }
     else if (PL_nomemok)
        return Nullch;
-    else {
-       return S_write_no_mem(aTHX);
-    }
-    /*NOTREACHED*/
+    return write_no_mem();
 }
 
 /* These must be defined when not using Perl's malloc for binary
@@ -272,9 +335,11 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
        for (x=big,s=little; *s; /**/ ) {
            if (!*x)
                return Nullch;
-           if (*s++ != *x++) {
-               s--;
+           if (*s != *x)
                break;
+           else {
+               s++;
+               x++;
            }
        }
        if (!*s)
@@ -301,9 +366,11 @@ Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const c
        if (*big++ != first)
            continue;
        for (x=big,s=little; s < littleend; /**/ ) {
-           if (*s++ != *x++) {
-               s--;
+           if (*s != *x)
                break;
+           else {
+               s++;
+               x++;
            }
        }
        if (s >= littleend)
@@ -330,9 +397,11 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
        if (*big-- != first)
            continue;
        for (x=big+2,s=little; s < littleend; /**/ ) {
-           if (*s++ != *x++) {
-               s--;
+           if (*s != *x)
                break;
+           else {
+               x++;
+               s++;
            }
        }
        if (s >= littleend)
@@ -817,7 +886,7 @@ Perl_savesharedpv(pTHX_ const char *pv)
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
-       return S_write_no_mem(aTHX);
+       return write_no_mem();
     }
     return memcpy(newaddr,pv,pvlen);
 }
@@ -4264,7 +4333,7 @@ Perl_vnumify(pTHX_ SV *vs)
     {
        digit = SvIV(*av_fetch(av, i, 0));
        if ( width < 3 ) {
-           const int denom = (int)pow(10,(3-width));
+           const int denom = (width == 2 ? 10 : 100);
            const div_t term = div((int)PERL_ABS(digit),denom);
            Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
        }
@@ -5024,7 +5093,7 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t
                                  " %s = %"IVdf": %"UVxf"\n",
                                  filename, linenumber, funcname, n, typesize,
                                  typename, n * typesize, PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, len));
+    PerlLIO_write(2,  buf, len);
 #endif
     return newalloc;
 }