This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH: [perl #134126] -Dusemymalloc, -Dusethreads
[perl5.git] / malloc.c
index a797e7e..0c80a08 100644 (file)
--- a/malloc.c
+++ b/malloc.c
 #     define PERL_MAYBE_ALIVE  1
 #endif
 
+#ifndef MYMALLOC
+#  error "MYMALLOC is not defined"
+#endif
+
 #ifndef MUTEX_LOCK
 #  define MUTEX_LOCK(l)
 #endif 
@@ -462,12 +466,12 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
   };
 #  define BUCKET_SIZE_NO_SURPLUS(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
 #  define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE              \
-                              ? buck_size[i]                           \
-                              : ((1 << ((i) >> BUCKET_POW2_SHIFT))     \
+                              ? ((size_t)buck_size[i])                 \
+                              : ((((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) \
                                  - MEM_OVERHEAD(i)                     \
                                  + POW2_OPTIMIZE_SURPLUS(i)))
 #else
-#  define BUCKET_SIZE_NO_SURPLUS(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
+#  define BUCKET_SIZE_NO_SURPLUS(i) (((size_t)1) << ((i) >> BUCKET_POW2_SHIFT))
 #  define BUCKET_SIZE(i) (BUCKET_SIZE_NO_SURPLUS(i) + POW2_OPTIMIZE_SURPLUS(i))
 #  define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i))
 #endif 
@@ -682,7 +686,7 @@ static const u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
 
 #ifdef PACK_MALLOC
 #  define MEM_OVERHEAD(bucket) \
-  (bucket <= MAX_PACKED ? 0 : M_OVERHEAD)
+  (bucket <= MAX_PACKED ? ((size_t)0) : M_OVERHEAD)
 #  ifdef SMALL_BUCKET_VIA_TABLE
 #    define START_SHIFTS_BUCKET ((MAX_PACKED_POW2 + 1) * BUCKETS_PER_POW2)
 #    define START_SHIFT MAX_PACKED_POW2
@@ -748,11 +752,11 @@ static const char bucket_of[] =
 #  define POW2_OPTIMIZE_ADJUST(nbytes)                         \
    ((nbytes >= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0)
 #  define POW2_OPTIMIZE_SURPLUS(bucket)                                \
-   ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)
+   ((size_t)((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0))
 
 #else  /* !TWO_POT_OPTIMIZE */
 #  define POW2_OPTIMIZE_ADJUST(nbytes)
-#  define POW2_OPTIMIZE_SURPLUS(bucket) 0
+#  define POW2_OPTIMIZE_SURPLUS(bucket) ((size_t)0)
 #endif /* !TWO_POT_OPTIMIZE */
 
 #define BARK_64K_LIMIT(what,nbytes,size)
@@ -818,32 +822,14 @@ static    union overhead *nextf[NBUCKETS];
 #ifdef USE_PERL_SBRK
 # define sbrk(a) Perl_sbrk(a)
 Malloc_t Perl_sbrk (int size);
-#else
-# ifndef HAS_SBRK_PROTO /* <unistd.h> usually takes care of this */
+#elif !defined(HAS_SBRK_PROTO) /* <unistd.h> usually takes care of this */
 extern Malloc_t sbrk(int);
-# endif
 #endif
 
 #ifndef MIN_SBRK_FRAC1000      /* Backward compatibility */
 #  define MIN_SBRK_FRAC1000    (MIN_SBRK_FRAC * 10)
 #endif
 
-#ifndef START_EXTERN_C
-#  ifdef __cplusplus
-#    define START_EXTERN_C     extern "C" {
-#  else
-#    define START_EXTERN_C
-#  endif
-#endif
-
-#ifndef END_EXTERN_C
-#  ifdef __cplusplus
-#    define END_EXTERN_C               };
-#  else
-#    define END_EXTERN_C
-#  endif
-#endif
-
 #include "malloc_ctl.h"
 
 #ifndef NO_MALLOC_DYNAMIC_CFG
@@ -1011,7 +997,9 @@ emergency_sbrk(MEM_SIZE size)
        /* Give the possibility to recover, but avoid an infinite cycle. */
        MALLOC_UNLOCK;
        emergency_buffer_last_req = size;
-       emergency_sbrk_croak("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
+       emergency_sbrk_croak("Out of memory during \"large\" request for %" UVuf
+                             " bytes, total sbrk() is %" UVuf " bytes",
+                             (UV)size, (UV)(goodsbrk + sbrk_slack));
     }
 
     if ((MEM_SIZE)emergency_buffer_size >= rsize) {
@@ -1055,7 +1043,9 @@ emergency_sbrk(MEM_SIZE size)
     }
   do_croak:
     MALLOC_UNLOCK;
-    emergency_sbrk_croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
+    emergency_sbrk_croak("Out of memory during request for %" UVuf
+                         " bytes, total sbrk() is %" UVuf " bytes",
+                         (UV)size, (UV)(goodsbrk + sbrk_slack));
     NOT_REACHED; /* NOTREACHED */
     return NULL;
 }
@@ -1239,11 +1229,23 @@ Perl_malloc(size_t nbytes)
         dVAR;
        union overhead *p;
        int bucket;
-
 #if defined(DEBUGGING) || defined(RCHECK)
        MEM_SIZE size = nbytes;
 #endif
 
+        /* A structure that has more than PTRDIFF_MAX bytes is unfortunately
+         * legal in C, but in such, if two elements are far enough apart, we
+         * can't legally find out how far apart they are.  Limit the size of a
+         * malloc so that pointer subtraction in the same structure is always
+         * well defined */
+        if (nbytes > PTRDIFF_MAX) {
+            dTHX;
+            MYMALLOC_WRITE2STDERR("Memory requests are limited to PTRDIFF_MAX"
+                                  " bytes to prevent possible undefined"
+                                  " behavior");
+            return NULL;
+        }
+
        BARK_64K_LIMIT("Allocation",nbytes,nbytes);
 #ifdef DEBUGGING
        if ((long)nbytes < 0)
@@ -1302,7 +1304,7 @@ Perl_malloc(size_t nbytes)
             || (p && PTR2UV(p) < (1<<LOG_OF_MIN_ARENA)) ) {
            dTHX;
            PerlIO_printf(PerlIO_stderr(),
-                         "Unaligned pointer in the free chain 0x%"UVxf"\n",
+                         "Unaligned pointer in the free chain 0x%" UVxf "\n",
                          PTR2UV(p));
        }
        if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1))
@@ -1310,7 +1312,7 @@ Perl_malloc(size_t nbytes)
            dTHX;
            PerlIO_printf(PerlIO_stderr(),
                          "Unaligned \"next\" pointer in the free "
-                         "chain 0x%"UVxf" at 0x%"UVxf"\n",
+                         "chain 0x%" UVxf " at 0x%" UVxf "\n",
                          PTR2UV(p->ov_next), PTR2UV(p));
        }
 #endif
@@ -1319,7 +1321,7 @@ Perl_malloc(size_t nbytes)
        MALLOC_UNLOCK;
 
        DEBUG_m(PerlIO_printf(Perl_debug_log,
-                             "0x%"UVxf": (%05lu) malloc %ld bytes\n",
+                             "0x% "UVxf ": (%05lu) malloc %ld bytes\n",
                              PTR2UV((Malloc_t)(p + CHUNK_SHIFT)), (unsigned long)(PL_an++),
                              (long)size));
 
@@ -1665,7 +1667,7 @@ morecore(int bucket)
                return;
 #ifndef NO_PERL_MALLOC_ENV
        if (!were_called) {
-           /* It's the our first time.  Initialize ourselves */
+           /* It's our first time.  Initialize ourselves */
            were_called = 1;    /* Avoid a loop */
            if (!MallocCfg[MallocCfg_skip_cfg_env]) {
                char *s = getenv("PERL_MALLOC_OPT"), *t = s, *off;
@@ -1799,7 +1801,7 @@ Perl_mfree(Malloc_t where)
 #endif 
 
        DEBUG_m(PerlIO_printf(Perl_debug_log, 
-                             "0x%"UVxf": (%05lu) free\n",
+                             "0x%" UVxf ": (%05lu) free\n",
                              PTR2UV(cp), (unsigned long)(PL_an++)));
 
        if (cp == NULL)
@@ -2026,7 +2028,7 @@ Perl_realloc(void *mp, size_t nbytes)
 #endif
                res = cp;
                DEBUG_m(PerlIO_printf(Perl_debug_log, 
-                             "0x%"UVxf": (%05lu) realloc %ld bytes inplace\n",
+                             "0x%" UVxf ": (%05lu) realloc %ld bytes inplace\n",
                              PTR2UV(res),(unsigned long)(PL_an++),
                              (long)size));
        } else if (incr == 1 && (cp - M_OVERHEAD == last_op) 
@@ -2064,7 +2066,7 @@ Perl_realloc(void *mp, size_t nbytes)
        } else {
          hard_way:
            DEBUG_m(PerlIO_printf(Perl_debug_log, 
-                             "0x%"UVxf": (%05lu) realloc %ld bytes the hard way\n",
+                             "0x%" UVxf ": (%05lu) realloc %ld bytes the hard way\n",
                              PTR2UV(cp),(unsigned long)(PL_an++),
                              (long)size));
            if ((res = (char*)Perl_malloc(nbytes)) == NULL)
@@ -2238,13 +2240,14 @@ Perl_dump_mstats(pTHX_ const char *s)
 
        if (s)
            PerlIO_printf(Perl_error_log,
-                         "Memory allocation statistics %s (buckets %"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n",
+                         "Memory allocation statistics %s (buckets %" IVdf
+                          "(%" IVdf ")..%" IVdf "(%" IVdf ")\n",
                          s, 
                          (IV)BUCKET_SIZE_REAL(MIN_BUCKET), 
                          (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET),
                          (IV)BUCKET_SIZE_REAL(buffer.topbucket), 
                          (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket));
-       PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree);
+        PerlIO_printf(Perl_error_log, "%8" IVdf " free:", buffer.totfree);
        for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
                PerlIO_printf(Perl_error_log, 
                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
@@ -2262,7 +2265,8 @@ Perl_dump_mstats(pTHX_ const char *s)
                              buffer.nfree[i]);
        }
 #endif 
-       PerlIO_printf(Perl_error_log, "\n%8"IVdf" used:", buffer.total - buffer.totfree);
+        PerlIO_printf(Perl_error_log, "\n%8" IVdf " used:",
+                                      buffer.total - buffer.totfree);
        for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
                PerlIO_printf(Perl_error_log, 
                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
@@ -2280,7 +2284,9 @@ Perl_dump_mstats(pTHX_ const char *s)
                              buffer.ntotal[i] - buffer.nfree[i]);
        }
 #endif 
-       PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %"IVdf"/%"IVdf":%"IVdf". Odd ends: pad+heads+chain+tail: %"IVdf"+%"IVdf"+%"IVdf"+%"IVdf".\n",
+       PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %" IVdf "/%" IVdf ":%"
+                      IVdf ". Odd ends: pad+heads+chain+tail: %" IVdf "+%"
+                      IVdf "+%" IVdf "+%" IVdf ".\n",
                      buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good,
                      buffer.sbrk_slack, buffer.start_slack,
                      buffer.total_chain, buffer.sbrked_remains);
@@ -2353,8 +2359,10 @@ Perl_sbrk(int size)
       }
     }
 
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%"UVxf"\n",
-                   size, reqsize, Perl_sbrk_oldsize, PTR2UV(got)));
+    DEBUG_m(PerlIO_printf(Perl_debug_log,
+            "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%"
+            UVxf "\n",
+            size, reqsize, Perl_sbrk_oldsize, PTR2UV(got)));
 
     return (void *)got;
 }
@@ -2362,11 +2370,5 @@ Perl_sbrk(int size)
 #endif /* ! defined USE_PERL_SBRK */
 
 /*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
  * ex: set ts=8 sts=4 sw=4 et:
  */