# define PERL_MAYBE_ALIVE 1
#endif
+#ifndef MYMALLOC
+# error "MYMALLOC is not defined"
+#endif
+
#ifndef MUTEX_LOCK
# define MUTEX_LOCK(l)
#endif
};
# 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
# define MAX_PACKED_POW2 6
# define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
# define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
-# define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
+# define TWOK_MASK nBIT_MASK(LOG_OF_MIN_ARENA)
# define TWOK_MASKED(x) (PTR2UV(x) & ~TWOK_MASK)
# define TWOK_SHIFT(x) (PTR2UV(x) & TWOK_MASK)
# define OV_INDEXp(block) (INT2PTR(u_char*,TWOK_MASKED(block)))
#ifdef IGNORE_SMALL_BAD_FREE
#define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
# define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
- ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE_NO_SURPLUS(bucket) \
+ ? nBIT_MASK(LOG_OF_MIN_ARENA)/BUCKET_SIZE_NO_SURPLUS(bucket) \
: n_blks[bucket] )
#else
# define N_BLKS(bucket) n_blks[bucket]
#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
# 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)
#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
/* 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) {
}
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;
}
static void
botch(const char *diag, const char *s, const char *file, int line)
{
- dVAR;
dTHX;
if (!(PERL_MAYBE_ALIVE && PERL_GET_THX))
goto do_write;
return bucket;
}
+/*
+These have the same interfaces as the C lib ones, so are considered documented
+
+=for apidoc malloc
+=for apidoc calloc
+=for apidoc realloc
+=cut
+*/
+
Malloc_t
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)
|| (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))
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
MALLOC_UNLOCK;
DEBUG_m(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf": (%05lu) malloc %ld bytes\n",
- PTR2UV((Malloc_t)(p + CHUNK_SHIFT)), (unsigned long)(PL_an++),
+ "%p: (%05lu) malloc %ld bytes\n",
+ (Malloc_t)(p + CHUNK_SHIFT),
+ (unsigned long)(PL_an++),
(long)size));
FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT),
static union overhead *
getpages(MEM_SIZE needed, int *nblksp, int bucket)
{
- dVAR;
/* Need to do (possibly expensive) system call. Try to
optimize it for rare calling. */
MEM_SIZE require = needed - sbrked_remains;
if (add) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
- "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignement,\t%ld were assumed to come from the tail of the previous sbrk\n",
+ "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignment,\t%ld were assumed to come from the tail of the previous sbrk\n",
(long)add, (long) slack,
(long) sbrked_remains));
newcp = (char *)sbrk(add);
static void
morecore(int bucket)
{
- dVAR;
union overhead *ovp;
int rnu; /* 2^rnu bytes will be requested */
int nblks; /* become nblks blocks of the desired size */
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;
+ char *s = getenv("PERL_MALLOC_OPT"), *t = s;
+ const char *off;
const char *opts = PERL_MALLOC_OPT_CHARS;
int changed = 0;
IV val = 0;
t += 2;
- while (*t <= '9' && *t >= '0')
+ while (isDIGIT(*t))
val = 10*val + *t++ - '0';
if (!*t || *t == ';') {
if (MallocCfg[off - opts] != val)
Free_t
Perl_mfree(Malloc_t where)
{
- dVAR;
MEM_SIZE size;
union overhead *ovp;
char *cp = (char*)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)
if (bad_free_warn == -1) {
dTHX;
char *pbf = PerlEnv_getenv("PERL_BADFREE");
- bad_free_warn = (pbf) ? grok_atou(pbf, NULL) : 1;
+ bad_free_warn = (pbf) ? strNE("0", pbf) : 1;
}
if (!bad_free_warn)
return;
Malloc_t
Perl_realloc(void *mp, size_t nbytes)
{
- dVAR;
MEM_SIZE onb;
union overhead *ovp;
char *res;
if (bad_free_warn == -1) {
dTHX;
char *pbf = PerlEnv_getenv("PERL_BADFREE");
- bad_free_warn = (pbf) ? grok_atou(pbf, NULL) : 1;
+ bad_free_warn = (pbf) ? strNE("0", pbf) : 1;
}
if (!bad_free_warn)
return NULL;
#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)
} 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)
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)
- ? " %5"UVuf
- : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)),
+ ? " %5" UVuf
+ : ((i < 12*BUCKETS_PER_POW2) ? " %3" UVuf
+ : " %" UVuf)),
buffer.nfree[i]);
}
#ifdef BUCKETS_ROOT2
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)
- ? " %5"IVdf
- : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)),
+ ? " %5" IVdf
+ : ((i < 12*BUCKETS_PER_POW2) ? " %3" IVdf : " %" IVdf)),
buffer.ntotal[i] - buffer.nfree[i]);
}
#ifdef BUCKETS_ROOT2
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);
}
}
- 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;
}
#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:
*/
https://perl5.git.perl.org / perl5.git / blobdiff