*/
/*
- * "'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'"
+ * 'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'
+ *
+ * [p.321 of _The Lord of the Rings_, II/v: "The Bridge of Khazad-Dûm"]
*/
/* This file contains Perl's own implementation of the malloc library.
#define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
#define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
-#if !(defined(I286) || defined(atarist) || defined(__MINT__))
+#if !(defined(I286) || defined(atarist))
/* take 2k unless the block is bigger than that */
# define LOG_OF_MIN_ARENA 11
#else
* than it was, and takes 67% of old heap size for typical usage.)
*
* Allocations of small blocks are now table-driven to many different
- * buckets. Sizes of really big buckets are increased to accomodata
+ * buckets. Sizes of really big buckets are increased to accommodate
* common size=power-of-2 blocks. Running-out-of-memory is made into
* an exception. Deeply configurable and thread-safe.
*
# ifndef UVxf
# define UVxf "lx"
# endif
-# ifndef Nullch
-# define Nullch NULL
-# endif
# ifndef MEM_ALIGNBYTES
# define MEM_ALIGNBYTES 4
# endif
# define pTHX void
# define pTHX_
# ifdef HASATTRIBUTE_UNUSED
-# define dTHX PERL_UNUSED_DECL(extern int Perl___notused)
+# define dTHX extern int Perl___notused PERL_UNUSED_DECL
# else
# define dTHX extern int Perl___notused
# endif
#define u_short unsigned short
/* 286 and atarist like big chunks, which gives too much overhead. */
-#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC)
+#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
# undef PACK_MALLOC
#endif
* encodes the size of the chunk, while MAGICn encodes state (used,
* free or non-managed-by-us-so-it-indicates-a-bug) of CHUNKn. MAGIC
* is used for sanity checking purposes only. SOMETHING is 0 or 4K
- * (to make size of big CHUNK accomodate allocations for powers of two
+ * (to make size of big CHUNK accommodate allocations for powers of two
* better).
*
* [There is no need to alignment between chunks, since C rules ensure
static void morecore (register int bucket);
# if defined(DEBUGGING)
-static void botch (char *diag, char *s, char *file, int line);
+static void botch (const char *diag, const char *s, const char *file, int line);
# endif
static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip);
static void* get_from_chain (MEM_SIZE size);
#endif /* defined PERL_EMERGENCY_SBRK */
static void
-write2(char *mess)
+write2(const char *mess)
{
write(2, mess, strlen(mess));
}
#ifdef DEBUGGING
#undef ASSERT
-#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__); else
+#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__);
+
static void
-botch(char *diag, char *s, char *file, int line)
+botch(const char *diag, const char *s, const char *file, int line)
{
+ dVAR;
+ dTHX;
if (!(PERL_MAYBE_ALIVE && PERL_GET_THX))
goto do_write;
else {
- dTHX;
if (PerlIO_printf(PerlIO_stderr(),
"assertion botched (%s?): %s %s:%d\n",
diag, s, file, line) != 0) {
# define FILLCHECK_DEADBEEF(s, n) ((void)0)
#endif
-Malloc_t
-Perl_malloc(register size_t nbytes)
+int
+S_ajust_size_and_find_bucket(size_t *nbytes_p)
{
- register union overhead *p;
- register int bucket;
- register MEM_SIZE shiftr;
-
-#if defined(DEBUGGING) || defined(RCHECK)
- MEM_SIZE size = nbytes;
-#endif
-
- BARK_64K_LIMIT("Allocation",nbytes,nbytes);
-#ifdef DEBUGGING
- if ((long)nbytes < 0)
- croak("%s", "panic: malloc");
-#endif
+ MEM_SIZE shiftr;
+ int bucket;
+ size_t nbytes = *nbytes_p;
/*
* Convert amount of memory requested into
while (shiftr >>= 1)
bucket += BUCKETS_PER_POW2;
}
+ *nbytes_p = nbytes;
+ return bucket;
+}
+
+Malloc_t
+Perl_malloc(size_t nbytes)
+{
+ dVAR;
+ register union overhead *p;
+ register int bucket;
+
+#if defined(DEBUGGING) || defined(RCHECK)
+ MEM_SIZE size = nbytes;
+#endif
+
+ BARK_64K_LIMIT("Allocation",nbytes,nbytes);
+#ifdef DEBUGGING
+ if ((long)nbytes < 0)
+ croak("%s", "panic: malloc");
+#endif
+
+ bucket = S_ajust_size_and_find_bucket(&nbytes);
MALLOC_LOCK;
/*
* If nothing in hash bucket right now,
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;
/* Second, check alignment. */
slack = 0;
-#if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */
+#if !defined(atarist) /* on the atari we dont have to worry about this */
# ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */
/* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may
improve performance of memory access. */
add += slack;
}
# endif
-#endif /* !atarist && !MINT */
+#endif /* !atarist */
if (add) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
#ifndef I286 /* Again, this should always be ok on an 80286 */
if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
- "fixing sbrk(): %d bytes off machine alignement\n",
+ "fixing sbrk(): %d bytes off machine alignment\n",
(int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1))));
ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) &
(MEM_ALIGNBYTES - 1));
static void
morecore(register int bucket)
{
+ dVAR;
register union overhead *ovp;
register int rnu; /* 2^rnu bytes will be requested */
int nblks; /* become nblks blocks of the desired size */
}
Free_t
-Perl_mfree(void *mp)
+Perl_mfree(Malloc_t where)
{
+ dVAR;
register MEM_SIZE size;
register union overhead *ovp;
- char *cp = (char*)mp;
+ char *cp = (char*)where;
#ifdef PACK_MALLOC
u_char bucket;
#endif
#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
- ovp->ov_rmagic == RMAGIC - 1 ?
- "Duplicate" : "Bad");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
+ ovp->ov_rmagic == RMAGIC - 1 ?
+ "Duplicate" : "Bad");
}
#else
warn("%s free() ignored (RMAGIC)",
#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
}
#else
warn("%s", "Bad free() ignored");
Malloc_t
Perl_realloc(void *mp, size_t nbytes)
{
+ dVAR;
register MEM_SIZE onb;
union overhead *ovp;
char *res;
#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
- (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
- ovp->ov_rmagic == RMAGIC - 1
- ? "of freed memory " : "");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
+ (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
+ ovp->ov_rmagic == RMAGIC - 1
+ ? "of freed memory " : "");
}
#else
warn2("%srealloc() %signored",
#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s",
- "Bad realloc() ignored");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s",
+ "Bad realloc() ignored");
}
#else
warn("%s", "Bad realloc() ignored");
onb = BUCKET_SIZE_REAL(bucket);
/*
* avoid the copy if same size block.
- * We are not agressive with boundary cases. Note that it might
+ * We are not aggressive with boundary cases. Note that it might
* (for a small number of cases) give false negative if
* both new size and old one are in the bucket for
* FIRST_BIG_POW2, but the new one is near the lower end.
nmalloc[bucket]--;
nmalloc[pow * BUCKETS_PER_POW2]++;
#endif
+ if (pow * BUCKETS_PER_POW2 > (MEM_SIZE)max_bucket)
+ max_bucket = pow * BUCKETS_PER_POW2;
*(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
MALLOC_UNLOCK;
goto inplace_label;
MEM_SIZE l = strlen(s);
char *s1 = (char *)Perl_malloc(l+1);
- return CopyD(s, s1, (MEM_SIZE)(l+1), char);
+ return (char *)CopyD(s, s1, (MEM_SIZE)(l+1), char);
}
#ifdef PERL_CORE
if (l < sizeof(buf))
var = buf;
else
- var = Perl_malloc(l + 1);
+ var = (char *)Perl_malloc(l + 1);
Copy(a, var, l, char);
var[l + 1] = 0;
my_setenv(var, val+1);
union overhead * const ovp = (union overhead *)
((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
const int bucket = OV_INDEX(ovp);
+
+ PERL_ARGS_ASSERT_MALLOCED_SIZE;
+
#ifdef RCHECK
/* The caller wants to have a complete control over the chunk,
disable the memory checking inside the chunk. */
return BUCKET_SIZE_REAL(bucket);
}
+
+MEM_SIZE
+Perl_malloc_good_size(size_t wanted)
+{
+ return BUCKET_SIZE_REAL(S_ajust_size_and_find_bucket(&wanted));
+}
+
# ifdef BUCKETS_ROOT2
# define MIN_EVEN_REPORT 6
# else
register union overhead *p;
struct chunk_chain_s* nextchain;
+ PERL_ARGS_ASSERT_GET_MSTATS;
+
buf->topbucket = buf->topbucket_ev = buf->topbucket_odd
= buf->totfree = buf->total = buf->total_chain = 0;
buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i);
}
}
+#else /* defined DEBUGGING_MSTATS */
+ PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n");
#endif /* defined DEBUGGING_MSTATS */
return 0; /* XXX unused */
}
* frees for each size category.
*/
void
-Perl_dump_mstats(pTHX_ char *s)
+Perl_dump_mstats(pTHX_ const char *s)
{
#ifdef DEBUGGING_MSTATS
register int i;
UV nf[NBUCKETS];
UV nt[NBUCKETS];
+ PERL_ARGS_ASSERT_DUMP_MSTATS;
+
buffer.nfree = nf;
buffer.ntotal = nt;
get_mstats(&buffer, NBUCKETS, 0);
buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good,
buffer.sbrk_slack, buffer.start_slack,
buffer.total_chain, buffer.sbrked_remains);
+#else /* DEBUGGING_MSTATS */
+ PerlIO_printf(Perl_error_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",s);
#endif /* DEBUGGING_MSTATS */
}
#ifdef USE_PERL_SBRK
-# if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__) || defined(PURIFY)
+# if defined(NeXT) || defined(__NeXT__) || defined(PURIFY)
# define PERL_SBRK_VIA_MALLOC
# endif
https://perl5.git.perl.org / perl5.git / blobdiff