This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[win32] s/PerlENV/PerlEnv/ just to be consistent
[perl5.git] / malloc.c
CommitLineData
a0d0e21e 1/* malloc.c
8d063cd8 2 *
8d063cd8
LW
3 */
4
3562ef9b
IZ
5#if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
6# define DEBUGGING_MSTATS
7#endif
8
8d063cd8 9#ifndef lint
1944739a
IZ
10# if defined(DEBUGGING) && !defined(NO_RCHECK)
11# define RCHECK
12# endif
8d063cd8
LW
13/*
14 * malloc.c (Caltech) 2/21/82
15 * Chris Kingsley, kingsley@cit-20.
16 *
17 * This is a very fast storage allocator. It allocates blocks of a small
18 * number of different sizes, and keeps free lists of each size. Blocks that
19 * don't exactly fit are passed up to the next larger size. In this
20 * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
cf5c4ad8 21 * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
8d063cd8
LW
22 * This is designed for use in a program that uses vast quantities of memory,
23 * but bombs when it runs out.
24 */
25
135863df 26#include "EXTERN.h"
135863df
AB
27#include "perl.h"
28
760ac839
LW
29#ifdef DEBUGGING
30#undef DEBUG_m
31#define DEBUG_m(a) if (debug & 128) a
32#endif
33
135863df
AB
34/* I don't much care whether these are defined in sys/types.h--LAW */
35
36#define u_char unsigned char
37#define u_int unsigned int
38#define u_short unsigned short
8d063cd8 39
cf5c4ad8
PP
40/* 286 and atarist like big chunks, which gives too much overhead. */
41#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
42#undef PACK_MALLOC
43#endif
44
45
8d063cd8 46/*
cf5c4ad8
PP
47 * The description below is applicable if PACK_MALLOC is not defined.
48 *
8d063cd8
LW
49 * The overhead on a block is at least 4 bytes. When free, this space
50 * contains a pointer to the next free block, and the bottom two bits must
51 * be zero. When in use, the first byte is set to MAGIC, and the second
52 * byte is the size index. The remaining bytes are for alignment.
53 * If range checking is enabled and the size of the block fits
54 * in two bytes, then the top two bytes hold the size of the requested block
55 * plus the range checking words, and the header word MINUS ONE.
56 */
57union overhead {
58 union overhead *ov_next; /* when free */
85e6fe83 59#if MEM_ALIGNBYTES > 4
c623bd54 60 double strut; /* alignment problems */
a687059c 61#endif
8d063cd8
LW
62 struct {
63 u_char ovu_magic; /* magic number */
64 u_char ovu_index; /* bucket # */
65#ifdef RCHECK
66 u_short ovu_size; /* actual block size */
67 u_int ovu_rmagic; /* range magic number */
68#endif
69 } ovu;
70#define ov_magic ovu.ovu_magic
71#define ov_index ovu.ovu_index
72#define ov_size ovu.ovu_size
73#define ov_rmagic ovu.ovu_rmagic
74};
75
760ac839 76#ifdef DEBUGGING
a0d0e21e
LW
77static void botch _((char *s));
78#endif
79static void morecore _((int bucket));
80static int findbucket _((union overhead *freep, int srchlen));
81
8d063cd8
LW
82#define MAGIC 0xff /* magic # on accounting info */
83#define RMAGIC 0x55555555 /* magic # on range info */
84#ifdef RCHECK
c2a5c2d2
IZ
85# define RSLOP sizeof (u_int)
86# ifdef TWO_POT_OPTIMIZE
87# define MAX_SHORT_BUCKET 12
88# else
89# define MAX_SHORT_BUCKET 13
90# endif
8d063cd8 91#else
c2a5c2d2 92# define RSLOP 0
8d063cd8
LW
93#endif
94
cf5c4ad8
PP
95#ifdef PACK_MALLOC
96/*
97 * In this case it is assumed that if we do sbrk() in 2K units, we
98 * will get 2K aligned blocks. The bucket number of the given subblock is
99 * on the boundary of 2K block which contains the subblock.
100 * Several following bytes contain the magic numbers for the subblocks
101 * in the block.
102 *
103 * Sizes of chunks are powers of 2 for chunks in buckets <=
104 * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to
105 * get alignment right).
106 *
107 * We suppose that starts of all the chunks in a 2K block are in
108 * different 2^n-byte-long chunks. If the top of the last chunk is
109 * aligned on a boundary of 2K block, this means that
110 * sizeof(union overhead)*"number of chunks" < 2^n, or
111 * sizeof(union overhead)*2K < 4^n, or n > 6 + log2(sizeof()/2)/2, if a
112 * chunk of size 2^n - overhead is used. Since this rules out n = 7
113 * for 8 byte alignment, we specialcase allocation of the first of 16
114 * 128-byte-long chunks.
115 *
116 * Note that with the above assumption we automatically have enough
117 * place for MAGIC at the start of 2K block. Note also that we
118 * overlay union overhead over the chunk, thus the start of the chunk
119 * is immediately overwritten after freeing.
120 */
121# define MAX_PACKED 6
122# define MAX_2_POT_ALGO ((1<<(MAX_PACKED + 1)) - M_OVERHEAD)
123# define TWOK_MASK ((1<<11) - 1)
ff68c719
PP
124# define TWOK_MASKED(x) ((u_int)(x) & ~TWOK_MASK)
125# define TWOK_SHIFT(x) ((u_int)(x) & TWOK_MASK)
cf5c4ad8
PP
126# define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block)))
127# define OV_INDEX(block) (*OV_INDEXp(block))
128# define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \
129 (TWOK_SHIFT(block)>>(bucket + 3)) + \
130 (bucket > MAX_NONSHIFT ? 1 : 0)))
131# define CHUNK_SHIFT 0
132
133static u_char n_blks[11 - 3] = {224, 120, 62, 31, 16, 8, 4, 2};
134static u_short blk_shift[11 - 3] = {256, 128, 64, 32,
135 16*sizeof(union overhead),
136 8*sizeof(union overhead),
137 4*sizeof(union overhead),
138 2*sizeof(union overhead),
139# define MAX_NONSHIFT 2 /* Shift 64 greater than chunk 32. */
140};
141
cf5c4ad8
PP
142#else /* !PACK_MALLOC */
143
144# define OV_MAGIC(block,bucket) (block)->ov_magic
145# define OV_INDEX(block) (block)->ov_index
146# define CHUNK_SHIFT 1
147#endif /* !PACK_MALLOC */
148
149# define M_OVERHEAD (sizeof(union overhead) + RSLOP)
150
8d063cd8 151/*
55497cff
PP
152 * Big allocations are often of the size 2^n bytes. To make them a
153 * little bit better, make blocks of size 2^n+pagesize for big n.
154 */
155
156#ifdef TWO_POT_OPTIMIZE
157
5f05dabc
PP
158# ifndef PERL_PAGESIZE
159# define PERL_PAGESIZE 4096
160# endif
161# ifndef FIRST_BIG_TWO_POT
162# define FIRST_BIG_TWO_POT 14 /* 16K */
163# endif
55497cff
PP
164# define FIRST_BIG_BLOCK (1<<FIRST_BIG_TWO_POT) /* 16K */
165/* If this value or more, check against bigger blocks. */
166# define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD)
167/* If less than this value, goes into 2^n-overhead-block. */
168# define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD)
169
170#endif /* TWO_POT_OPTIMIZE */
171
72e5b9db 172#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
55497cff
PP
173
174#ifndef BIG_SIZE
175# define BIG_SIZE (1<<16) /* 64K */
176#endif
177
178static char *emergency_buffer;
179static MEM_SIZE emergency_buffer_size;
180
181static char *
182emergency_sbrk(size)
183 MEM_SIZE size;
184{
185 if (size >= BIG_SIZE) {
186 /* Give the possibility to recover: */
187 die("Out of memory during request for %i bytes", size);
188 /* croak may eat too much memory. */
189 }
190
191 if (!emergency_buffer) {
18f739ee 192 dTHR;
55497cff
PP
193 /* First offense, give a possibility to recover by dieing. */
194 /* No malloc involved here: */
195 GV **gvp = (GV**)hv_fetch(defstash, "^M", 2, 0);
196 SV *sv;
197 char *pv;
198
199 if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0);
200 if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
201 || (SvLEN(sv) < (1<<11) - M_OVERHEAD))
202 return (char *)-1; /* Now die die die... */
203
204 /* Got it, now detach SvPV: */
bbce6d69 205 pv = SvPV(sv, na);
55497cff 206 /* Check alignment: */
ff68c719 207 if (((u_int)(pv - M_OVERHEAD)) & ((1<<11) - 1)) {
55497cff 208 PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
bbce6d69 209 return (char *)-1; /* die die die */
55497cff
PP
210 }
211
212 emergency_buffer = pv - M_OVERHEAD;
213 emergency_buffer_size = SvLEN(sv) + M_OVERHEAD;
214 SvPOK_off(sv);
215 SvREADONLY_on(sv);
216 die("Out of memory!"); /* croak may eat too much memory. */
ff68c719
PP
217 }
218 else if (emergency_buffer_size >= size) {
55497cff
PP
219 emergency_buffer_size -= size;
220 return emergency_buffer + emergency_buffer_size;
221 }
222
223 return (char *)-1; /* poor guy... */
224}
225
72e5b9db 226#else /* !(defined(TWO_POT_OPTIMIZE) && defined(PERL_CORE)) */
55497cff 227# define emergency_sbrk(size) -1
72e5b9db 228#endif /* !(defined(TWO_POT_OPTIMIZE) && defined(PERL_CORE)) */
55497cff
PP
229
230/*
8d063cd8
LW
231 * nextf[i] is the pointer to the next free block of size 2^(i+3). The
232 * smallest allocatable block is 8 bytes. The overhead information
233 * precedes the data area returned to the user.
234 */
235#define NBUCKETS 30
236static union overhead *nextf[NBUCKETS];
cf5c4ad8
PP
237
238#ifdef USE_PERL_SBRK
239#define sbrk(a) Perl_sbrk(a)
240char * Perl_sbrk _((int size));
8ac85365
NIS
241#else
242#ifdef DONT_DECLARE_STD
243#ifdef I_UNISTD
244#include <unistd.h>
245#endif
cf5c4ad8 246#else
8ac85365
NIS
247extern char *sbrk(int);
248#endif
cf5c4ad8 249#endif
8d063cd8 250
c07a80fd 251#ifdef DEBUGGING_MSTATS
8d063cd8
LW
252/*
253 * nmalloc[i] is the difference between the number of mallocs and frees
254 * for a given block size.
255 */
256static u_int nmalloc[NBUCKETS];
5f05dabc
PP
257static u_int goodsbrk;
258static u_int sbrk_slack;
259static u_int start_slack;
8d063cd8
LW
260#endif
261
760ac839 262#ifdef DEBUGGING
4dfc412b 263#define ASSERT(p) if (!(p)) botch(STRINGIFY(p)); else
ee0007ab 264static void
8ac85365 265botch(char *s)
8d063cd8 266{
4dfc412b 267 PerlIO_printf(PerlIO_stderr(), "assertion botched: %s\n", s);
3028581b 268 PerlProc_abort();
8d063cd8
LW
269}
270#else
271#define ASSERT(p)
272#endif
273
2304df62 274Malloc_t
8ac85365 275malloc(register size_t nbytes)
8d063cd8
LW
276{
277 register union overhead *p;
278 register int bucket = 0;
ee0007ab 279 register MEM_SIZE shiftr;
8d063cd8 280
c2a5c2d2 281#if defined(DEBUGGING) || defined(RCHECK)
ee0007ab 282 MEM_SIZE size = nbytes;
45d8adaa
LW
283#endif
284
043bf814 285#ifdef PERL_CORE
55497cff 286#ifdef HAS_64K_LIMIT
45d8adaa 287 if (nbytes > 0xffff) {
043bf814
RB
288 PerlIO_printf(PerlIO_stderr(),
289 "Allocation too large: %lx\n", (long)nbytes);
79072805 290 my_exit(1);
45d8adaa 291 }
55497cff 292#endif /* HAS_64K_LIMIT */
45d8adaa
LW
293#ifdef DEBUGGING
294 if ((long)nbytes < 0)
043bf814 295 croak("panic: malloc");
45d8adaa 296#endif
55497cff 297#endif /* PERL_CORE */
45d8adaa 298
11343788 299 MUTEX_LOCK(&malloc_mutex);
8d063cd8
LW
300 /*
301 * Convert amount of memory requested into
302 * closest block size stored in hash buckets
303 * which satisfies request. Account for
304 * space used per block for accounting.
305 */
cf5c4ad8 306#ifdef PACK_MALLOC
043bf814
RB
307 if (nbytes == 0)
308 nbytes = 1;
309 else if (nbytes > MAX_2_POT_ALGO)
cf5c4ad8 310#endif
043bf814 311 {
55497cff 312#ifdef TWO_POT_OPTIMIZE
043bf814
RB
313 if (nbytes >= FIRST_BIG_BOUND)
314 nbytes -= PERL_PAGESIZE;
55497cff 315#endif
043bf814
RB
316 nbytes += M_OVERHEAD;
317 nbytes = (nbytes + 3) &~ 3;
cf5c4ad8 318 }
8d063cd8
LW
319 shiftr = (nbytes - 1) >> 2;
320 /* apart from this loop, this is O(1) */
321 while (shiftr >>= 1)
322 bucket++;
323 /*
324 * If nothing in hash bucket right now,
325 * request more memory from the system.
326 */
327 if (nextf[bucket] == NULL)
328 morecore(bucket);
45d8adaa 329 if ((p = (union overhead *)nextf[bucket]) == NULL) {
11343788 330 MUTEX_UNLOCK(&malloc_mutex);
55497cff 331#ifdef PERL_CORE
ee0007ab 332 if (!nomemok) {
760ac839 333 PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
79072805 334 my_exit(1);
ee0007ab 335 }
45d8adaa 336#else
8d063cd8 337 return (NULL);
45d8adaa
LW
338#endif
339 }
340
55497cff 341#ifdef PERL_CORE
68dc0745
PP
342 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) malloc %ld bytes\n",
343 (unsigned long)(p+1),(unsigned long)(an++),(long)size));
55497cff 344#endif /* PERL_CORE */
45d8adaa 345
8d063cd8 346 /* remove from linked list */
bf38876a
LW
347#ifdef RCHECK
348 if (*((int*)p) & (sizeof(union overhead) - 1))
760ac839 349 PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n",
a0d0e21e 350 (unsigned long)*((int*)p),(unsigned long)p);
bf38876a
LW
351#endif
352 nextf[bucket] = p->ov_next;
cf5c4ad8
PP
353 OV_MAGIC(p, bucket) = MAGIC;
354#ifndef PACK_MALLOC
355 OV_INDEX(p) = bucket;
356#endif
8d063cd8
LW
357#ifdef RCHECK
358 /*
359 * Record allocated size of block and
360 * bound space with magic numbers.
361 */
c2a5c2d2 362 nbytes = (size + M_OVERHEAD + 3) &~ 3;
8d063cd8
LW
363 if (nbytes <= 0x10000)
364 p->ov_size = nbytes - 1;
365 p->ov_rmagic = RMAGIC;
366 *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
367#endif
11343788 368 MUTEX_UNLOCK(&malloc_mutex);
cf5c4ad8 369 return ((Malloc_t)(p + CHUNK_SHIFT));
8d063cd8
LW
370}
371
372/*
373 * Allocate more memory to the indicated bucket.
374 */
a0d0e21e 375static void
8ac85365 376morecore(register int bucket)
8d063cd8 377{
72aaf631 378 register union overhead *ovp;
8d063cd8
LW
379 register int rnu; /* 2^rnu bytes will be requested */
380 register int nblks; /* become nblks blocks of the desired size */
bbce6d69 381 register MEM_SIZE siz, needed;
cf5c4ad8 382 int slack = 0;
8d063cd8
LW
383
384 if (nextf[bucket])
385 return;
55497cff
PP
386 if (bucket == (sizeof(MEM_SIZE)*8 - 3)) {
387 croak("Allocation too large");
388 }
8d063cd8
LW
389 /*
390 * Insure memory is allocated
391 * on a page boundary. Should
392 * make getpageize call?
393 */
ee0007ab 394#ifndef atarist /* on the atari we dont have to worry about this */
72aaf631 395 ovp = (union overhead *)sbrk(0);
cf5c4ad8 396# ifndef I286
72aaf631
MB
397 if ((UV)ovp & (0x7FF >> CHUNK_SHIFT)) {
398 slack = (0x800 >> CHUNK_SHIFT) - ((UV)ovp & (0x7FF >> CHUNK_SHIFT));
c030ccd9 399 (void)sbrk(slack);
5f05dabc 400# if defined(DEBUGGING_MSTATS)
c030ccd9 401 sbrk_slack += slack;
cf5c4ad8 402# endif
c030ccd9 403 }
cf5c4ad8 404# else
a687059c 405 /* The sbrk(0) call on the I286 always returns the next segment */
cf5c4ad8 406# endif
ee0007ab 407#endif /* atarist */
a687059c 408
ee0007ab 409#if !(defined(I286) || defined(atarist))
8d063cd8
LW
410 /* take 2k unless the block is bigger than that */
411 rnu = (bucket <= 8) ? 11 : bucket + 3;
a687059c
LW
412#else
413 /* take 16k unless the block is bigger than that
ee0007ab 414 (80286s like large segments!), probably good on the atari too */
a687059c
LW
415 rnu = (bucket <= 11) ? 14 : bucket + 3;
416#endif
8d063cd8 417 nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */
bbce6d69 418 needed = (MEM_SIZE)1 << rnu;
55497cff 419#ifdef TWO_POT_OPTIMIZE
bbce6d69 420 needed += (bucket >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0);
55497cff 421#endif
72aaf631 422 ovp = (union overhead *)sbrk(needed);
8d063cd8 423 /* no more room! */
72aaf631
MB
424 if (ovp == (union overhead *)-1) {
425 ovp = (union overhead *)emergency_sbrk(needed);
426 if (ovp == (union overhead *)-1)
8d063cd8 427 return;
ff68c719 428 }
5f05dabc
PP
429#ifdef DEBUGGING_MSTATS
430 goodsbrk += needed;
431#endif
8d063cd8
LW
432 /*
433 * Round up to minimum allocation size boundary
434 * and deduct from block count to reflect.
435 */
a687059c 436#ifndef I286
cf5c4ad8 437# ifdef PACK_MALLOC
72aaf631 438 if ((UV)ovp & 0x7FF)
cf5c4ad8
PP
439 croak("panic: Off-page sbrk");
440# endif
72aaf631
MB
441 if ((UV)ovp & 7) {
442 ovp = (union overhead *)(((UV)ovp + 8) & ~7);
8d063cd8
LW
443 nblks--;
444 }
a687059c
LW
445#else
446 /* Again, this should always be ok on an 80286 */
447#endif
8d063cd8
LW
448 /*
449 * Add new memory allocated to that on
450 * free list for this hash bucket.
451 */
8d063cd8 452 siz = 1 << (bucket + 3);
cf5c4ad8 453#ifdef PACK_MALLOC
72aaf631 454 *(u_char*)ovp = bucket; /* Fill index. */
cf5c4ad8 455 if (bucket <= MAX_PACKED - 3) {
72aaf631 456 ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]);
cf5c4ad8
PP
457 nblks = n_blks[bucket];
458# ifdef DEBUGGING_MSTATS
459 start_slack += blk_shift[bucket];
460# endif
461 } else if (bucket <= 11 - 1 - 3) {
72aaf631 462 ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]);
cf5c4ad8
PP
463 /* nblks = n_blks[bucket]; */
464 siz -= sizeof(union overhead);
72aaf631 465 } else ovp++; /* One chunk per block. */
cf5c4ad8 466#endif /* !PACK_MALLOC */
72aaf631 467 nextf[bucket] = ovp;
5f05dabc
PP
468#ifdef DEBUGGING_MSTATS
469 nmalloc[bucket] += nblks;
470#endif
8d063cd8 471 while (--nblks > 0) {
72aaf631
MB
472 ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
473 ovp = (union overhead *)((caddr_t)ovp + siz);
8d063cd8 474 }
8595d6f1 475 /* Not all sbrks return zeroed memory.*/
72aaf631 476 ovp->ov_next = (union overhead *)NULL;
cf5c4ad8
PP
477#ifdef PACK_MALLOC
478 if (bucket == 7 - 3) { /* Special case, explanation is above. */
479 union overhead *n_op = nextf[7 - 3]->ov_next;
480 nextf[7 - 3] = (union overhead *)((caddr_t)nextf[7 - 3]
481 - sizeof(union overhead));
482 nextf[7 - 3]->ov_next = n_op;
483 }
484#endif /* !PACK_MALLOC */
8d063cd8
LW
485}
486
94b6baf5 487Free_t
8ac85365 488free(void *mp)
8d063cd8 489{
ee0007ab 490 register MEM_SIZE size;
72aaf631 491 register union overhead *ovp;
352d5a3a 492 char *cp = (char*)mp;
cf5c4ad8
PP
493#ifdef PACK_MALLOC
494 u_char bucket;
495#endif
8d063cd8 496
55497cff 497#ifdef PERL_CORE
68dc0745 498 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) free\n",(unsigned long)cp,(unsigned long)(an++)));
55497cff 499#endif /* PERL_CORE */
45d8adaa 500
cf5c4ad8
PP
501 if (cp == NULL)
502 return;
72aaf631
MB
503 ovp = (union overhead *)((caddr_t)cp
504 - sizeof (union overhead) * CHUNK_SHIFT);
cf5c4ad8 505#ifdef PACK_MALLOC
72aaf631 506 bucket = OV_INDEX(ovp);
cf5c4ad8 507#endif
72aaf631 508 if (OV_MAGIC(ovp, bucket) != MAGIC) {
68dc0745 509 static int bad_free_warn = -1;
cf5c4ad8 510 if (bad_free_warn == -1) {
5fd9e9a4 511 char *pbf = PerlEnv_getenv("PERL_BADFREE");
cf5c4ad8
PP
512 bad_free_warn = (pbf) ? atoi(pbf) : 1;
513 }
514 if (!bad_free_warn)
515 return;
8990e307 516#ifdef RCHECK
a687059c 517 warn("%s free() ignored",
72aaf631 518 ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
8990e307
LW
519#else
520 warn("Bad free() ignored");
521#endif
8d063cd8 522 return; /* sanity */
378cc40b 523 }
11343788 524 MUTEX_LOCK(&malloc_mutex);
8d063cd8 525#ifdef RCHECK
72aaf631
MB
526 ASSERT(ovp->ov_rmagic == RMAGIC);
527 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET)
528 ASSERT(*(u_int *)((caddr_t)ovp + ovp->ov_size + 1 - RSLOP) == RMAGIC);
529 ovp->ov_rmagic = RMAGIC - 1;
8d063cd8 530#endif
72aaf631
MB
531 ASSERT(OV_INDEX(ovp) < NBUCKETS);
532 size = OV_INDEX(ovp);
533 ovp->ov_next = nextf[size];
534 nextf[size] = ovp;
11343788 535 MUTEX_UNLOCK(&malloc_mutex);
8d063cd8
LW
536}
537
538/*
539 * When a program attempts "storage compaction" as mentioned in the
540 * old malloc man page, it realloc's an already freed block. Usually
541 * this is the last block it freed; occasionally it might be farther
542 * back. We have to search all the free lists for the block in order
543 * to determine its bucket: 1st we make one pass thru the lists
544 * checking only the first block in each; if that fails we search
378cc40b 545 * ``reall_srchlen'' blocks in each list for a match (the variable
8d063cd8
LW
546 * is extern so the caller can modify it). If that fails we just copy
547 * however many bytes was given to realloc() and hope it's not huge.
548 */
378cc40b 549int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
8d063cd8 550
2304df62 551Malloc_t
8ac85365 552realloc(void *mp, size_t nbytes)
8d063cd8 553{
ee0007ab 554 register MEM_SIZE onb;
72aaf631 555 union overhead *ovp;
8d063cd8
LW
556 char *res;
557 register int i;
558 int was_alloced = 0;
352d5a3a 559 char *cp = (char*)mp;
8d063cd8 560
45d8adaa 561#ifdef DEBUGGING
ee0007ab 562 MEM_SIZE size = nbytes;
45d8adaa
LW
563#endif
564
043bf814 565#ifdef PERL_CORE
55497cff 566#ifdef HAS_64K_LIMIT
45d8adaa 567 if (nbytes > 0xffff) {
043bf814
RB
568 PerlIO_printf(PerlIO_stderr(),
569 "Reallocation too large: %lx\n", size);
79072805 570 my_exit(1);
45d8adaa 571 }
55497cff 572#endif /* HAS_64K_LIMIT */
45d8adaa 573 if (!cp)
ee0007ab 574 return malloc(nbytes);
45d8adaa
LW
575#ifdef DEBUGGING
576 if ((long)nbytes < 0)
463ee0b2 577 croak("panic: realloc");
45d8adaa 578#endif
55497cff 579#endif /* PERL_CORE */
45d8adaa 580
11343788 581 MUTEX_LOCK(&malloc_mutex);
72aaf631
MB
582 ovp = (union overhead *)((caddr_t)cp
583 - sizeof (union overhead) * CHUNK_SHIFT);
584 i = OV_INDEX(ovp);
585 if (OV_MAGIC(ovp, i) == MAGIC) {
55497cff 586 was_alloced = 1;
8d063cd8
LW
587 } else {
588 /*
589 * Already free, doing "compaction".
590 *
591 * Search for the old block of memory on the
592 * free list. First, check the most common
593 * case (last element free'd), then (this failing)
378cc40b 594 * the last ``reall_srchlen'' items free'd.
8d063cd8
LW
595 * If all lookups fail, then assume the size of
596 * the memory block being realloc'd is the
597 * smallest possible.
598 */
72aaf631
MB
599 if ((i = findbucket(ovp, 1)) < 0 &&
600 (i = findbucket(ovp, reall_srchlen)) < 0)
8d063cd8
LW
601 i = 0;
602 }
cf5c4ad8
PP
603 onb = (1L << (i + 3)) -
604#ifdef PACK_MALLOC
605 (i <= (MAX_PACKED - 3) ? 0 : M_OVERHEAD)
606#else
607 M_OVERHEAD
608#endif
55497cff
PP
609#ifdef TWO_POT_OPTIMIZE
610 + (i >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0)
611#endif
cf5c4ad8 612 ;
55497cff
PP
613 /*
614 * avoid the copy if same size block.
615 * We are not agressive with boundary cases. Note that it is
616 * possible for small number of cases give false negative if
617 * both new size and old one are in the bucket for
618 * FIRST_BIG_TWO_POT, but the new one is near the lower end.
619 */
8d063cd8 620 if (was_alloced &&
55497cff
PP
621 nbytes <= onb && (nbytes > ( (onb >> 1) - M_OVERHEAD )
622#ifdef TWO_POT_OPTIMIZE
623 || (i == (FIRST_BIG_TWO_POT - 3)
624 && nbytes >= LAST_SMALL_BOUND )
625#endif
626 )) {
a687059c
LW
627#ifdef RCHECK
628 /*
629 * Record new allocated size of block and
630 * bound space with magic numbers.
631 */
72aaf631 632 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
a687059c
LW
633 /*
634 * Convert amount of memory requested into
635 * closest block size stored in hash buckets
636 * which satisfies request. Account for
637 * space used per block for accounting.
638 */
cf5c4ad8 639 nbytes += M_OVERHEAD;
a687059c 640 nbytes = (nbytes + 3) &~ 3;
72aaf631
MB
641 ovp->ov_size = nbytes - 1;
642 *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
a687059c
LW
643 }
644#endif
45d8adaa 645 res = cp;
11343788 646 MUTEX_UNLOCK(&malloc_mutex);
a687059c 647 }
45d8adaa 648 else {
11343788 649 MUTEX_UNLOCK(&malloc_mutex);
45d8adaa
LW
650 if ((res = (char*)malloc(nbytes)) == NULL)
651 return (NULL);
652 if (cp != res) /* common optimization */
ee0007ab 653 Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
45d8adaa
LW
654 if (was_alloced)
655 free(cp);
656 }
657
55497cff 658#ifdef PERL_CORE
45d8adaa 659#ifdef DEBUGGING
a0d0e21e 660 if (debug & 128) {
fb73857a
PP
661 PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) rfree\n",(unsigned long)res,(unsigned long)(an++));
662 PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) realloc %ld bytes\n",
68dc0745 663 (unsigned long)res,(unsigned long)(an++),(long)size);
a0d0e21e 664 }
45d8adaa 665#endif
55497cff 666#endif /* PERL_CORE */
2304df62 667 return ((Malloc_t)res);
8d063cd8
LW
668}
669
670/*
671 * Search ``srchlen'' elements of each free list for a block whose
672 * header starts at ``freep''. If srchlen is -1 search the whole list.
673 * Return bucket number, or -1 if not found.
674 */
ee0007ab 675static int
8ac85365 676findbucket(union overhead *freep, int srchlen)
8d063cd8
LW
677{
678 register union overhead *p;
679 register int i, j;
680
681 for (i = 0; i < NBUCKETS; i++) {
682 j = 0;
683 for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
684 if (p == freep)
685 return (i);
686 j++;
687 }
688 }
689 return (-1);
690}
691
cf5c4ad8 692Malloc_t
8ac85365 693calloc(register size_t elements, register size_t size)
cf5c4ad8
PP
694{
695 long sz = elements * size;
696 Malloc_t p = malloc(sz);
697
698 if (p) {
699 memset((void*)p, 0, sz);
700 }
701 return p;
702}
703
c07a80fd 704#ifdef DEBUGGING_MSTATS
8d063cd8
LW
705/*
706 * mstats - print out statistics about malloc
707 *
708 * Prints two lines of numbers, one showing the length of the free list
709 * for each size category, the second showing the number of mallocs -
710 * frees for each size category.
711 */
ee0007ab 712void
8ac85365 713dump_mstats(char *s)
8d063cd8
LW
714{
715 register int i, j;
716 register union overhead *p;
5f05dabc 717 int topbucket=0, totfree=0, total=0;
c07a80fd 718 u_int nfree[NBUCKETS];
8d063cd8 719
c07a80fd 720 for (i=0; i < NBUCKETS; i++) {
8d063cd8
LW
721 for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
722 ;
c07a80fd
PP
723 nfree[i] = j;
724 totfree += nfree[i] * (1 << (i + 3));
5f05dabc
PP
725 total += nmalloc[i] * (1 << (i + 3));
726 if (nmalloc[i])
c07a80fd
PP
727 topbucket = i;
728 }
729 if (s)
760ac839 730 PerlIO_printf(PerlIO_stderr(), "Memory allocation statistics %s (buckets 8..%d)\n",
c07a80fd 731 s, (1 << (topbucket + 3)) );
5f05dabc 732 PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree);
c07a80fd 733 for (i=0; i <= topbucket; i++) {
5f05dabc 734 PerlIO_printf(PerlIO_stderr(), (i<5 || i==7)?" %5d": (i<9)?" %3d":" %d", nfree[i]);
8d063cd8 735 }
5f05dabc 736 PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree);
c07a80fd 737 for (i=0; i <= topbucket; i++) {
5f05dabc 738 PerlIO_printf(PerlIO_stderr(), (i<5 || i==7)?" %5d": (i<9)?" %3d":" %d", nmalloc[i] - nfree[i]);
c07a80fd 739 }
5f05dabc
PP
740 PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %8d. Odd ends: sbrk(): %7d, malloc(): %7d bytes.\n",
741 goodsbrk + sbrk_slack, sbrk_slack, start_slack);
c07a80fd
PP
742}
743#else
744void
8ac85365 745dump_mstats(char *s)
c07a80fd 746{
8d063cd8
LW
747}
748#endif
a687059c 749#endif /* lint */
cf5c4ad8
PP
750
751
752#ifdef USE_PERL_SBRK
753
760ac839
LW
754# ifdef NeXT
755# define PERL_SBRK_VIA_MALLOC
756# endif
757
758# ifdef PERL_SBRK_VIA_MALLOC
72e5b9db 759# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
760ac839
LW
760# undef malloc
761# else
72e5b9db 762# include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC"
760ac839 763# endif
cf5c4ad8
PP
764
765/* it may seem schizophrenic to use perl's malloc and let it call system */
766/* malloc, the reason for that is only the 3.2 version of the OS that had */
767/* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
768/* end to the cores */
769
760ac839 770# define SYSTEM_ALLOC(a) malloc(a)
cf5c4ad8 771
760ac839 772# endif /* PERL_SBRK_VIA_MALLOC */
cf5c4ad8
PP
773
774static IV Perl_sbrk_oldchunk;
775static long Perl_sbrk_oldsize;
776
760ac839
LW
777# define PERLSBRK_32_K (1<<15)
778# define PERLSBRK_64_K (1<<16)
cf5c4ad8
PP
779
780char *
781Perl_sbrk(size)
782int size;
783{
784 IV got;
785 int small, reqsize;
786
787 if (!size) return 0;
55497cff 788#ifdef PERL_CORE
cf5c4ad8
PP
789 reqsize = size; /* just for the DEBUG_m statement */
790#endif
57569e04
HM
791#ifdef PACK_MALLOC
792 size = (size + 0x7ff) & ~0x7ff;
793#endif
cf5c4ad8
PP
794 if (size <= Perl_sbrk_oldsize) {
795 got = Perl_sbrk_oldchunk;
796 Perl_sbrk_oldchunk += size;
797 Perl_sbrk_oldsize -= size;
798 } else {
799 if (size >= PERLSBRK_32_K) {
800 small = 0;
801 } else {
55497cff 802#ifndef PERL_CORE
cf5c4ad8
PP
803 reqsize = size;
804#endif
805 size = PERLSBRK_64_K;
806 small = 1;
807 }
808 got = (IV)SYSTEM_ALLOC(size);
57569e04
HM
809#ifdef PACK_MALLOC
810 got = (got + 0x7ff) & ~0x7ff;
811#endif
cf5c4ad8
PP
812 if (small) {
813 /* Chunk is small, register the rest for future allocs. */
814 Perl_sbrk_oldchunk = got + reqsize;
815 Perl_sbrk_oldsize = size - reqsize;
816 }
817 }
818
55497cff 819#ifdef PERL_CORE
fb73857a 820 DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
cf5c4ad8
PP
821 size, reqsize, Perl_sbrk_oldsize, got));
822#endif
823
824 return (void *)got;
825}
826
827#endif /* ! defined USE_PERL_SBRK */