This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a12f768a9839eeb4f18811e00ec4ab923fa36cf5
[perl5.git] / malloc.c
1 /*    malloc.c
2  *
3  */
4
5 /*
6   Here are some notes on configuring Perl's malloc.
7  
8   There are two macros which serve as bulk disablers of advanced
9   features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by
10   default).  Look in the list of default values below to understand
11   their exact effect.  Defining NO_FANCY_MALLOC returns malloc.c to the
12   state of the malloc in Perl 5.004.  Additionally defining PLAIN_MALLOC
13   returns it to the state as of Perl 5.000.
14
15   Note that some of the settings below may be ignored in the code based
16   on values of other macros.  The PERL_CORE symbol is only defined when
17   perl itself is being compiled (so malloc can make some assumptions
18   about perl's facilities being available to it).
19
20   Each config option has a short description, followed by its name,
21   default value, and a comment about the default (if applicable).  Some
22   options take a precise value, while the others are just boolean.
23   The boolean ones are listed first.
24
25     # Enable code for an emergency memory pool in $^M.  See perlvar.pod
26     # for a description of $^M.
27     PERL_EMERGENCY_SBRK         (!PLAIN_MALLOC && PERL_CORE)
28
29     # Enable code for printing memory statistics.
30     DEBUGGING_MSTATS            (!PLAIN_MALLOC && PERL_CORE)
31
32     # Move allocation info for small buckets into separate areas.
33     # Memory optimization (especially for small allocations, of the
34     # less than 64 bytes).  Since perl usually makes a large number
35     # of small allocations, this is usually a win.
36     PACK_MALLOC                 (!PLAIN_MALLOC && !RCHECK)
37
38     # Add one page to big powers of two when calculating bucket size.
39     # This is targeted at big allocations, as are common in image
40     # processing.
41     TWO_POT_OPTIMIZE            !PLAIN_MALLOC
42  
43     # Use intermediate bucket sizes between powers-of-two.  This is
44     # generally a memory optimization, and a (small) speed pessimization.
45     BUCKETS_ROOT2               !NO_FANCY_MALLOC
46
47     # Do not check small deallocations for bad free().  Memory
48     # and speed optimization, error reporting pessimization.
49     IGNORE_SMALL_BAD_FREE       (!NO_FANCY_MALLOC && !RCHECK)
50
51     # Use table lookup to decide in which bucket a given allocation will go.
52     SMALL_BUCKET_VIA_TABLE      !NO_FANCY_MALLOC
53
54     # Use a perl-defined sbrk() instead of the (presumably broken or
55     # missing) system-supplied sbrk().
56     USE_PERL_SBRK               undef
57
58     # Use system malloc() (or calloc() etc.) to emulate sbrk(). Normally
59     # only used with broken sbrk()s.
60     PERL_SBRK_VIA_MALLOC        undef
61
62     # Which allocator to use if PERL_SBRK_VIA_MALLOC
63     SYSTEM_ALLOC(a)             malloc(a)
64
65     # Disable memory overwrite checking with DEBUGGING.  Memory and speed
66     # optimization, error reporting pessimization.
67     NO_RCHECK                   undef
68
69     # Enable memory overwrite checking with DEBUGGING.  Memory and speed
70     # pessimization, error reporting optimization
71     RCHECK                      (DEBUGGING && !NO_RCHECK)
72
73     # Failed allocations bigger than this size croak (if
74     # PERL_EMERGENCY_SBRK is enabled) without touching $^M.  See
75     # perlvar.pod for a description of $^M.
76     BIG_SIZE                     (1<<16)        # 64K
77
78     # Starting from this power of two, add an extra page to the
79     # size of the bucket. This enables optimized allocations of sizes
80     # close to powers of 2.  Note that the value is indexed at 0.
81     FIRST_BIG_POW2              15              # 32K, 16K is used too often
82
83     # Estimate of minimal memory footprint.  malloc uses this value to
84     # request the most reasonable largest blocks of memory from the system.
85     FIRST_SBRK                  (48*1024)
86
87     # Round up sbrk()s to multiples of this.
88     MIN_SBRK                    2048
89
90     # Round up sbrk()s to multiples of this percent of footprint.
91     MIN_SBRK_FRAC               3
92
93     # Add this much memory to big powers of two to get the bucket size.
94     PERL_PAGESIZE               4096
95
96     # This many sbrk() discontinuities should be tolerated even
97     # from the start without deciding that sbrk() is usually
98     # discontinuous.
99     SBRK_ALLOW_FAILURES         3
100
101     # This many continuous sbrk()s compensate for one discontinuous one.
102     SBRK_FAILURE_PRICE          50
103
104   This implementation assumes that calling PerlIO_printf() does not
105   result in any memory allocation calls (used during a panic).
106
107  */
108
109 #ifndef NO_FANCY_MALLOC
110 #  ifndef SMALL_BUCKET_VIA_TABLE
111 #    define SMALL_BUCKET_VIA_TABLE
112 #  endif 
113 #  ifndef BUCKETS_ROOT2
114 #    define BUCKETS_ROOT2
115 #  endif 
116 #  ifndef IGNORE_SMALL_BAD_FREE
117 #    define IGNORE_SMALL_BAD_FREE
118 #  endif 
119 #endif 
120
121 #ifndef PLAIN_MALLOC                    /* Bulk enable features */
122 #  ifndef PACK_MALLOC
123 #      define PACK_MALLOC
124 #  endif 
125 #  ifndef TWO_POT_OPTIMIZE
126 #    define TWO_POT_OPTIMIZE
127 #  endif 
128 #  if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK)
129 #    define PERL_EMERGENCY_SBRK
130 #  endif 
131 #  if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
132 #    define DEBUGGING_MSTATS
133 #  endif 
134 #endif
135
136 #define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
137 #define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
138
139 #if !(defined(I286) || defined(atarist))
140         /* take 2k unless the block is bigger than that */
141 #  define LOG_OF_MIN_ARENA 11
142 #else
143         /* take 16k unless the block is bigger than that 
144            (80286s like large segments!), probably good on the atari too */
145 #  define LOG_OF_MIN_ARENA 14
146 #endif
147
148 #ifndef lint
149 #  if defined(DEBUGGING) && !defined(NO_RCHECK)
150 #    define RCHECK
151 #  endif
152 #  if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE)
153 #    undef IGNORE_SMALL_BAD_FREE
154 #  endif 
155 /*
156  * malloc.c (Caltech) 2/21/82
157  * Chris Kingsley, kingsley@cit-20.
158  *
159  * This is a very fast storage allocator.  It allocates blocks of a small 
160  * number of different sizes, and keeps free lists of each size.  Blocks that
161  * don't exactly fit are passed up to the next larger size.  In this 
162  * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
163  * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
164  * This is designed for use in a program that uses vast quantities of memory,
165  * but bombs when it runs out. 
166  */
167
168 #ifdef PERL_CORE
169 #  include "EXTERN.h"
170 #  include "perl.h"
171 #else
172 #  ifdef PERL_FOR_X2P
173 #    include "../EXTERN.h"
174 #    include "../perl.h"
175 #  else
176 #    include <stdlib.h>
177 #    include <stdio.h>
178 #    include <memory.h>
179 #    define _(arg) arg
180 #    ifndef Malloc_t
181 #      define Malloc_t void *
182 #    endif
183 #    ifndef MEM_SIZE
184 #      define MEM_SIZE unsigned long
185 #    endif
186 #    ifndef LONG_MAX
187 #      define LONG_MAX 0x7FFFFFFF
188 #    endif
189 #    ifndef UV
190 #      define UV unsigned long
191 #    endif
192 #    ifndef caddr_t
193 #      define caddr_t char *
194 #    endif
195 #    ifndef Free_t
196 #      define Free_t void
197 #    endif
198 #    define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
199 #    define PerlEnv_getenv getenv
200 #    define PerlIO_printf fprintf
201 #    define PerlIO_stderr() stderr
202 #  endif
203 #  ifndef croak                         /* make depend */
204 #    define croak(mess, arg) warn((mess), (arg)); exit(1);
205 #  endif 
206 #  ifndef warn
207 #    define warn(mess, arg) fprintf(stderr, (mess), (arg));
208 #  endif 
209 #  ifdef DEBUG_m
210 #    undef DEBUG_m
211 #  endif 
212 #  define DEBUG_m(a)
213 #  ifdef DEBUGGING
214 #     undef DEBUGGING
215 #  endif
216 #endif
217
218 #ifndef MUTEX_LOCK
219 #  define MUTEX_LOCK(l)
220 #endif 
221
222 #ifndef MUTEX_UNLOCK
223 #  define MUTEX_UNLOCK(l)
224 #endif 
225
226 #ifdef DEBUGGING
227 #  undef DEBUG_m
228 #  define DEBUG_m(a)  if (debug & 128)   a
229 #endif
230
231 /* I don't much care whether these are defined in sys/types.h--LAW */
232
233 #define u_char unsigned char
234 #define u_int unsigned int
235
236 #ifdef HAS_QUAD
237 #  define u_bigint UV                   /* Needs to eat *void. */
238 #else  /* needed? */
239 #  define u_bigint unsigned long        /* Needs to eat *void. */
240 #endif
241
242 #define u_short unsigned short
243
244 /* 286 and atarist like big chunks, which gives too much overhead. */
245 #if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
246 #  undef PACK_MALLOC
247 #endif 
248
249 /*
250  * The description below is applicable if PACK_MALLOC is not defined.
251  *
252  * The overhead on a block is at least 4 bytes.  When free, this space
253  * contains a pointer to the next free block, and the bottom two bits must
254  * be zero.  When in use, the first byte is set to MAGIC, and the second
255  * byte is the size index.  The remaining bytes are for alignment.
256  * If range checking is enabled and the size of the block fits
257  * in two bytes, then the top two bytes hold the size of the requested block
258  * plus the range checking words, and the header word MINUS ONE.
259  */
260 union   overhead {
261         union   overhead *ov_next;      /* when free */
262 #if MEM_ALIGNBYTES > 4
263         double  strut;                  /* alignment problems */
264 #endif
265         struct {
266                 u_char  ovu_magic;      /* magic number */
267                 u_char  ovu_index;      /* bucket # */
268 #ifdef RCHECK
269                 u_short ovu_size;       /* actual block size */
270                 u_int   ovu_rmagic;     /* range magic number */
271 #endif
272         } ovu;
273 #define ov_magic        ovu.ovu_magic
274 #define ov_index        ovu.ovu_index
275 #define ov_size         ovu.ovu_size
276 #define ov_rmagic       ovu.ovu_rmagic
277 };
278
279 #ifdef DEBUGGING
280 static void botch _((char *diag, char *s));
281 #endif
282 static void morecore _((int bucket));
283 static int findbucket _((union overhead *freep, int srchlen));
284
285 #define MAGIC           0xff            /* magic # on accounting info */
286 #define RMAGIC          0x55555555      /* magic # on range info */
287 #define RMAGIC_C        0x55            /* magic # on range info */
288
289 #ifdef RCHECK
290 #  define       RSLOP           sizeof (u_int)
291 #  ifdef TWO_POT_OPTIMIZE
292 #    define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2)
293 #  else
294 #    define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
295 #  endif 
296 #else
297 #  define       RSLOP           0
298 #endif
299
300 #if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
301 #  undef BUCKETS_ROOT2
302 #endif 
303
304 #ifdef BUCKETS_ROOT2
305 #  define BUCKET_TABLE_SHIFT 2
306 #  define BUCKET_POW2_SHIFT 1
307 #  define BUCKETS_PER_POW2 2
308 #else
309 #  define BUCKET_TABLE_SHIFT MIN_BUC_POW2
310 #  define BUCKET_POW2_SHIFT 0
311 #  define BUCKETS_PER_POW2 1
312 #endif 
313
314 #if !defined(MEM_ALIGNBYTES) || ((MEM_ALIGNBYTES > 4) && !defined(STRICT_ALIGNMENT))
315 /* Figure out the alignment of void*. */
316 struct aligner {
317   char c;
318   void *p;
319 };
320 #  define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
321 #else
322 #  define ALIGN_SMALL MEM_ALIGNBYTES
323 #endif
324
325 #define IF_ALIGN_8(yes,no)      ((ALIGN_SMALL>4) ? (yes) : (no))
326
327 #ifdef BUCKETS_ROOT2
328 #  define MAX_BUCKET_BY_TABLE 13
329 static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = 
330   { 
331       0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
332   };
333 #  define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
334 #  define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE               \
335                                ? buck_size[i]                           \
336                                : ((1 << ((i) >> BUCKET_POW2_SHIFT))     \
337                                   - MEM_OVERHEAD(i)                     \
338                                   + POW2_OPTIMIZE_SURPLUS(i)))
339 #else
340 #  define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
341 #  define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) + POW2_OPTIMIZE_SURPLUS(i))
342 #endif 
343
344
345 #ifdef PACK_MALLOC
346 /* In this case it is assumed that if we do sbrk() in 2K units, we
347  * will get 2K aligned arenas (at least after some initial
348  * alignment). The bucket number of the given subblock is on the start
349  * of 2K arena which contains the subblock.  Several following bytes
350  * contain the magic numbers for the subblocks in the block.
351  *
352  * Sizes of chunks are powers of 2 for chunks in buckets <=
353  * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to
354  * get alignment right).
355  *
356  * Consider an arena for 2^n with n>MAX_PACKED.  We suppose that
357  * starts of all the chunks in a 2K arena are in different
358  * 2^n-byte-long chunks.  If the top of the last chunk is aligned on a
359  * boundary of 2K block, this means that sizeof(union
360  * overhead)*"number of chunks" < 2^n, or sizeof(union overhead)*2K <
361  * 4^n, or n > 6 + log2(sizeof()/2)/2, since a chunk of size 2^n -
362  * overhead is used.  Since this rules out n = 7 for 8 byte alignment,
363  * we specialcase allocation of the first of 16 128-byte-long chunks.
364  *
365  * Note that with the above assumption we automatically have enough
366  * place for MAGIC at the start of 2K block.  Note also that we
367  * overlay union overhead over the chunk, thus the start of small chunks
368  * is immediately overwritten after freeing.  */
369 #  define MAX_PACKED_POW2 6
370 #  define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
371 #  define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
372 #  define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
373 #  define TWOK_MASKED(x) ((u_bigint)(x) & ~TWOK_MASK)
374 #  define TWOK_SHIFT(x) ((u_bigint)(x) & TWOK_MASK)
375 #  define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block)))
376 #  define OV_INDEX(block) (*OV_INDEXp(block))
377 #  define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) +                  \
378                                     (TWOK_SHIFT(block)>>                \
379                                      (bucket>>BUCKET_POW2_SHIFT)) +     \
380                                     (bucket >= MIN_NEEDS_SHIFT ? 1 : 0)))
381     /* A bucket can have a shift smaller than it size, we need to
382        shift its magic number so it will not overwrite index: */
383 #  ifdef BUCKETS_ROOT2
384 #    define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2 - 1) /* Shift 80 greater than chunk 64. */
385 #  else
386 #    define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2) /* Shift 128 greater than chunk 32. */
387 #  endif 
388 #  define CHUNK_SHIFT 0
389
390 /* Number of active buckets of given ordinal. */
391 #ifdef IGNORE_SMALL_BAD_FREE
392 #define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
393 #  define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK           \
394                          ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE(bucket) \
395                          : n_blks[bucket] )
396 #else
397 #  define N_BLKS(bucket) n_blks[bucket]
398 #endif 
399
400 static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = 
401   {
402 #  if BUCKETS_PER_POW2==1
403       0, 0,
404       (MIN_BUC_POW2==2 ? 384 : 0),
405       224, 120, 62, 31, 16, 8, 4, 2
406 #  else
407       0, 0, 0, 0,
408       (MIN_BUC_POW2==2 ? 384 : 0), (MIN_BUC_POW2==2 ? 384 : 0), /* 4, 4 */
409       224, 149, 120, 80, 62, 41, 31, 25, 16, 16, 8, 8, 4, 4, 2, 2
410 #  endif
411   };
412
413 /* Shift of the first bucket with the given ordinal inside 2K chunk. */
414 #ifdef IGNORE_SMALL_BAD_FREE
415 #  define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK        \
416                               ? ((1<<LOG_OF_MIN_ARENA)                  \
417                                  - BUCKET_SIZE(bucket) * N_BLKS(bucket)) \
418                               : blk_shift[bucket])
419 #else
420 #  define BLK_SHIFT(bucket) blk_shift[bucket]
421 #endif 
422
423 static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = 
424   { 
425 #  if BUCKETS_PER_POW2==1
426       0, 0,
427       (MIN_BUC_POW2==2 ? 512 : 0),
428       256, 128, 64, 64,                 /* 8 to 64 */
429       16*sizeof(union overhead), 
430       8*sizeof(union overhead), 
431       4*sizeof(union overhead), 
432       2*sizeof(union overhead), 
433 #  else
434       0, 0, 0, 0,
435       (MIN_BUC_POW2==2 ? 512 : 0), (MIN_BUC_POW2==2 ? 512 : 0),
436       256, 260, 128, 128, 64, 80, 64, 48, /* 8 to 96 */
437       16*sizeof(union overhead), 16*sizeof(union overhead), 
438       8*sizeof(union overhead), 8*sizeof(union overhead), 
439       4*sizeof(union overhead), 4*sizeof(union overhead), 
440       2*sizeof(union overhead), 2*sizeof(union overhead), 
441 #  endif 
442   };
443
444 #else  /* !PACK_MALLOC */
445
446 #  define OV_MAGIC(block,bucket) (block)->ov_magic
447 #  define OV_INDEX(block) (block)->ov_index
448 #  define CHUNK_SHIFT 1
449 #  define MAX_PACKED -1
450 #endif /* !PACK_MALLOC */
451
452 #define M_OVERHEAD (sizeof(union overhead) + RSLOP)
453
454 #ifdef PACK_MALLOC
455 #  define MEM_OVERHEAD(bucket) \
456   (bucket <= MAX_PACKED ? 0 : M_OVERHEAD)
457 #  ifdef SMALL_BUCKET_VIA_TABLE
458 #    define START_SHIFTS_BUCKET ((MAX_PACKED_POW2 + 1) * BUCKETS_PER_POW2)
459 #    define START_SHIFT MAX_PACKED_POW2
460 #    ifdef BUCKETS_ROOT2                /* Chunks of size 3*2^n. */
461 #      define SIZE_TABLE_MAX 80
462 #    else
463 #      define SIZE_TABLE_MAX 64
464 #    endif 
465 static char bucket_of[] =
466   {
467 #    ifdef BUCKETS_ROOT2                /* Chunks of size 3*2^n. */
468       /* 0 to 15 in 4-byte increments. */
469       (sizeof(void*) > 4 ? 6 : 5),      /* 4/8, 5-th bucket for better reports */
470       6,                                /* 8 */
471       IF_ALIGN_8(8,7), 8,               /* 16/12, 16 */
472       9, 9, 10, 10,                     /* 24, 32 */
473       11, 11, 11, 11,                   /* 48 */
474       12, 12, 12, 12,                   /* 64 */
475       13, 13, 13, 13,                   /* 80 */
476       13, 13, 13, 13                    /* 80 */
477 #    else /* !BUCKETS_ROOT2 */
478       /* 0 to 15 in 4-byte increments. */
479       (sizeof(void*) > 4 ? 3 : 2),
480       3, 
481       4, 4, 
482       5, 5, 5, 5,
483       6, 6, 6, 6,
484       6, 6, 6, 6
485 #    endif /* !BUCKETS_ROOT2 */
486   };
487 #  else  /* !SMALL_BUCKET_VIA_TABLE */
488 #    define START_SHIFTS_BUCKET MIN_BUCKET
489 #    define START_SHIFT (MIN_BUC_POW2 - 1)
490 #  endif /* !SMALL_BUCKET_VIA_TABLE */
491 #else  /* !PACK_MALLOC */
492 #  define MEM_OVERHEAD(bucket) M_OVERHEAD
493 #  ifdef SMALL_BUCKET_VIA_TABLE
494 #    undef SMALL_BUCKET_VIA_TABLE
495 #  endif 
496 #  define START_SHIFTS_BUCKET MIN_BUCKET
497 #  define START_SHIFT (MIN_BUC_POW2 - 1)
498 #endif /* !PACK_MALLOC */
499
500 /*
501  * Big allocations are often of the size 2^n bytes. To make them a
502  * little bit better, make blocks of size 2^n+pagesize for big n.
503  */
504
505 #ifdef TWO_POT_OPTIMIZE
506
507 #  ifndef PERL_PAGESIZE
508 #    define PERL_PAGESIZE 4096
509 #  endif 
510 #  ifndef FIRST_BIG_POW2
511 #    define FIRST_BIG_POW2 15   /* 32K, 16K is used too often. */
512 #  endif
513 #  define FIRST_BIG_BLOCK (1<<FIRST_BIG_POW2)
514 /* If this value or more, check against bigger blocks. */
515 #  define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD)
516 /* If less than this value, goes into 2^n-overhead-block. */
517 #  define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD)
518
519 #  define POW2_OPTIMIZE_ADJUST(nbytes)                          \
520    ((nbytes >= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0)
521 #  define POW2_OPTIMIZE_SURPLUS(bucket)                         \
522    ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)
523
524 #else  /* !TWO_POT_OPTIMIZE */
525 #  define POW2_OPTIMIZE_ADJUST(nbytes)
526 #  define POW2_OPTIMIZE_SURPLUS(bucket) 0
527 #endif /* !TWO_POT_OPTIMIZE */
528
529 #if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
530 #  define BARK_64K_LIMIT(what,nbytes,size)                              \
531         if (nbytes > 0xffff) {                                          \
532                 PerlIO_printf(PerlIO_stderr(),                          \
533                               "%s too large: %lx\n", what, size);       \
534                 my_exit(1);                                             \
535         }
536 #else /* !HAS_64K_LIMIT || !PERL_CORE */
537 #  define BARK_64K_LIMIT(what,nbytes,size)
538 #endif /* !HAS_64K_LIMIT || !PERL_CORE */
539
540 #ifndef MIN_SBRK
541 #  define MIN_SBRK 2048
542 #endif 
543
544 #ifndef FIRST_SBRK
545 #  define FIRST_SBRK (48*1024)
546 #endif 
547
548 /* Minimal sbrk in percents of what is already alloced. */
549 #ifndef MIN_SBRK_FRAC
550 #  define MIN_SBRK_FRAC 3
551 #endif 
552
553 #ifndef SBRK_ALLOW_FAILURES
554 #  define SBRK_ALLOW_FAILURES 3
555 #endif 
556
557 #ifndef SBRK_FAILURE_PRICE
558 #  define SBRK_FAILURE_PRICE 50
559 #endif 
560
561 #if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
562
563 #  ifndef BIG_SIZE
564 #    define BIG_SIZE (1<<16)            /* 64K */
565 #  endif 
566
567 static char *emergency_buffer;
568 static MEM_SIZE emergency_buffer_size;
569
570 static Malloc_t
571 emergency_sbrk(size)
572     MEM_SIZE size;
573 {
574     if (size >= BIG_SIZE) {
575         /* Give the possibility to recover: */
576         MUTEX_UNLOCK(&malloc_mutex);
577         croak("Out of memory during \"large\" request for %i bytes", size);
578     }
579
580     if (!emergency_buffer) {            
581         dTHR;
582         /* First offense, give a possibility to recover by dieing. */
583         /* No malloc involved here: */
584         GV **gvp = (GV**)hv_fetch(defstash, "^M", 2, 0);
585         SV *sv;
586         char *pv;
587
588         if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0);
589         if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) 
590             || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) 
591             return (char *)-1;          /* Now die die die... */
592
593         /* Got it, now detach SvPV: */
594         pv = SvPV(sv, na);
595         /* Check alignment: */
596         if (((u_bigint)(pv - M_OVERHEAD)) & ((1<<LOG_OF_MIN_ARENA) - 1)) {
597             PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
598             return (char *)-1;          /* die die die */
599         }
600
601         emergency_buffer = pv - M_OVERHEAD;
602         emergency_buffer_size = SvLEN(sv) + M_OVERHEAD;
603         SvPOK_off(sv);
604         SvREADONLY_on(sv);
605         MUTEX_UNLOCK(&malloc_mutex);
606         croak("Out of memory during request for %i bytes", size);
607     }
608     else if (emergency_buffer_size >= size) {
609         emergency_buffer_size -= size;
610         return emergency_buffer + emergency_buffer_size;
611     }
612     
613     return (char *)-1;                  /* poor guy... */
614 }
615
616 #else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
617 #  define emergency_sbrk(size)  -1
618 #endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
619
620 /*
621  * nextf[i] is the pointer to the next free block of size 2^i.  The
622  * smallest allocatable block is 8 bytes.  The overhead information
623  * precedes the data area returned to the user.
624  */
625 #define NBUCKETS (32*BUCKETS_PER_POW2 + 1)
626 static  union overhead *nextf[NBUCKETS];
627
628 #ifdef USE_PERL_SBRK
629 #define sbrk(a) Perl_sbrk(a)
630 Malloc_t Perl_sbrk _((int size));
631 #else 
632 #ifdef DONT_DECLARE_STD
633 #ifdef I_UNISTD
634 #include <unistd.h>
635 #endif
636 #else
637 extern  Malloc_t sbrk(int);
638 #endif
639 #endif
640
641 #ifdef DEBUGGING_MSTATS
642 /*
643  * nmalloc[i] is the difference between the number of mallocs and frees
644  * for a given block size.
645  */
646 static  u_int nmalloc[NBUCKETS];
647 static  u_int sbrk_slack;
648 static  u_int start_slack;
649 #endif
650
651 static  u_int goodsbrk;
652
653 #ifdef DEBUGGING
654 #define ASSERT(p,diag)   if (!(p)) botch(diag,STRINGIFY(p));  else
655 static void
656 botch(char *diag, char *s)
657 {
658         PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
659         PerlProc_abort();
660 }
661 #else
662 #define ASSERT(p, diag)
663 #endif
664
665 Malloc_t
666 malloc(register size_t nbytes)
667 {
668         register union overhead *p;
669         register int bucket;
670         register MEM_SIZE shiftr;
671
672 #if defined(DEBUGGING) || defined(RCHECK)
673         MEM_SIZE size = nbytes;
674 #endif
675
676         BARK_64K_LIMIT("Allocation",nbytes,nbytes);
677 #ifdef DEBUGGING
678         if ((long)nbytes < 0)
679                 croak("%s", "panic: malloc");
680 #endif
681
682         MUTEX_LOCK(&malloc_mutex);
683         /*
684          * Convert amount of memory requested into
685          * closest block size stored in hash buckets
686          * which satisfies request.  Account for
687          * space used per block for accounting.
688          */
689 #ifdef PACK_MALLOC
690 #  ifdef SMALL_BUCKET_VIA_TABLE
691         if (nbytes == 0)
692             bucket = MIN_BUCKET;
693         else if (nbytes <= SIZE_TABLE_MAX) {
694             bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT];
695         } else
696 #  else
697         if (nbytes == 0)
698             nbytes = 1;
699         if (nbytes <= MAX_POW2_ALGO) goto do_shifts;
700         else
701 #  endif
702 #endif 
703         {
704             POW2_OPTIMIZE_ADJUST(nbytes);
705             nbytes += M_OVERHEAD;
706             nbytes = (nbytes + 3) &~ 3; 
707           do_shifts:
708             shiftr = (nbytes - 1) >> START_SHIFT;
709             bucket = START_SHIFTS_BUCKET;
710             /* apart from this loop, this is O(1) */
711             while (shiftr >>= 1)
712                 bucket += BUCKETS_PER_POW2;
713         }
714         /*
715          * If nothing in hash bucket right now,
716          * request more memory from the system.
717          */
718         if (nextf[bucket] == NULL)    
719                 morecore(bucket);
720         if ((p = nextf[bucket]) == NULL) {
721                 MUTEX_UNLOCK(&malloc_mutex);
722 #ifdef PERL_CORE
723                 if (!nomemok) {
724                     PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
725                     my_exit(1);
726                 }
727 #else
728                 return (NULL);
729 #endif
730         }
731
732         DEBUG_m(PerlIO_printf(Perl_debug_log,
733                               "0x%lx: (%05lu) malloc %ld bytes\n",
734                               (unsigned long)(p+1), (unsigned long)(an++),
735                               (long)size));
736
737         /* remove from linked list */
738 #ifdef RCHECK
739         if (*((int*)p) & (sizeof(union overhead) - 1))
740             PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n",
741                 (unsigned long)*((int*)p),(unsigned long)p);
742 #endif
743         nextf[bucket] = p->ov_next;
744 #ifdef IGNORE_SMALL_BAD_FREE
745         if (bucket >= FIRST_BUCKET_WITH_CHECK)
746 #endif 
747             OV_MAGIC(p, bucket) = MAGIC;
748 #ifndef PACK_MALLOC
749         OV_INDEX(p) = bucket;
750 #endif
751 #ifdef RCHECK
752         /*
753          * Record allocated size of block and
754          * bound space with magic numbers.
755          */
756         p->ov_rmagic = RMAGIC;
757         if (bucket <= MAX_SHORT_BUCKET) {
758             int i;
759             
760             nbytes = size + M_OVERHEAD; 
761             p->ov_size = nbytes - 1;
762             if ((i = nbytes & 3)) {
763                 i = 4 - i;
764                 while (i--)
765                     *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C;
766             }
767             nbytes = (nbytes + 3) &~ 3; 
768             *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
769         }
770 #endif
771         MUTEX_UNLOCK(&malloc_mutex);
772         return ((Malloc_t)(p + CHUNK_SHIFT));
773 }
774
775 static char *last_sbrk_top;
776 static char *last_op;                   /* This arena can be easily extended. */
777 static int sbrked_remains;
778 static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
779
780 #ifdef DEBUGGING_MSTATS
781 static int sbrks;
782 #endif 
783
784 struct chunk_chain_s {
785     struct chunk_chain_s *next;
786     MEM_SIZE size;
787 };
788 static struct chunk_chain_s *chunk_chain;
789 static int n_chunks;
790 static char max_bucket;
791
792 /* Cutoff a piece of one of the chunks in the chain.  Prefer smaller chunk. */
793 static void *
794 get_from_chain(MEM_SIZE size)
795 {
796     struct chunk_chain_s *elt = chunk_chain, **oldp = &chunk_chain;
797     struct chunk_chain_s **oldgoodp = NULL;
798     long min_remain = LONG_MAX;
799
800     while (elt) {
801         if (elt->size >= size) {
802             long remains = elt->size - size;
803             if (remains >= 0 && remains < min_remain) {
804                 oldgoodp = oldp;
805                 min_remain = remains;
806             }
807             if (remains == 0) {
808                 break;
809             }
810         }
811         oldp = &( elt->next );
812         elt = elt->next;
813     }
814     if (!oldgoodp) return NULL;
815     if (min_remain) {
816         void *ret = *oldgoodp;
817         struct chunk_chain_s *next = (*oldgoodp)->next;
818         
819         *oldgoodp = (struct chunk_chain_s *)((char*)ret + size);
820         (*oldgoodp)->size = min_remain;
821         (*oldgoodp)->next = next;
822         return ret;
823     } else {
824         void *ret = *oldgoodp;
825         *oldgoodp = (*oldgoodp)->next;
826         n_chunks--;
827         return ret;
828     }
829 }
830
831 static void
832 add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip)
833 {
834     struct chunk_chain_s *next = chunk_chain;
835     char *cp = (char*)p;
836     
837     cp += chip;
838     chunk_chain = (struct chunk_chain_s *)cp;
839     chunk_chain->size = size - chip;
840     chunk_chain->next = next;
841     n_chunks++;
842 }
843
844 static void *
845 get_from_bigger_buckets(int bucket, MEM_SIZE size)
846 {
847     int price = 1;
848     static int bucketprice[NBUCKETS];
849     while (bucket <= max_bucket) {
850         /* We postpone stealing from bigger buckets until we want it
851            often enough. */
852         if (nextf[bucket] && bucketprice[bucket]++ >= price) {
853             /* Steal it! */
854             void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT);
855             bucketprice[bucket] = 0;
856             if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) {
857                 last_op = NULL;         /* Disable optimization */
858             }
859             nextf[bucket] = nextf[bucket]->ov_next;
860 #ifdef DEBUGGING_MSTATS
861             nmalloc[bucket]--;
862             start_slack -= M_OVERHEAD;
863 #endif 
864             add_to_chain(ret, (BUCKET_SIZE(bucket) +
865                                POW2_OPTIMIZE_SURPLUS(bucket)), 
866                          size);
867             return ret;
868         }
869         bucket++;
870     }
871     return NULL;
872 }
873
874 static union overhead *
875 getpages(int needed, int *nblksp, int bucket)
876 {
877     /* Need to do (possibly expensive) system call. Try to
878        optimize it for rare calling. */
879     MEM_SIZE require = needed - sbrked_remains;
880     char *cp;
881     union overhead *ovp;
882     int slack = 0;
883
884     if (sbrk_good > 0) {
885         if (!last_sbrk_top && require < FIRST_SBRK) 
886             require = FIRST_SBRK;
887         else if (require < MIN_SBRK) require = MIN_SBRK;
888
889         if (require < goodsbrk * MIN_SBRK_FRAC / 100)
890             require = goodsbrk * MIN_SBRK_FRAC / 100;
891         require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
892     } else {
893         require = needed;
894         last_sbrk_top = 0;
895         sbrked_remains = 0;
896     }
897
898     DEBUG_m(PerlIO_printf(Perl_debug_log, 
899                           "sbrk(%ld) for %ld-byte-long arena\n",
900                           (long)require, (long) needed));
901     cp = (char *)sbrk(require);
902 #ifdef DEBUGGING_MSTATS
903     sbrks++;
904 #endif 
905     if (cp == last_sbrk_top) {
906         /* Common case, anything is fine. */
907         sbrk_good++;
908         ovp = (union overhead *) (cp - sbrked_remains);
909         sbrked_remains = require - (needed - sbrked_remains);
910     } else if (cp == (char *)-1) { /* no more room! */
911         ovp = (union overhead *)emergency_sbrk(needed);
912         if (ovp == (union overhead *)-1)
913             return 0;
914         return ovp;
915     } else {                    /* Non-continuous or first sbrk(). */
916         long add = sbrked_remains;
917         char *newcp;
918
919         if (sbrked_remains) {   /* Put rest into chain, we
920                                    cannot use it right now. */
921             add_to_chain((void*)(last_sbrk_top - sbrked_remains),
922                          sbrked_remains, 0);
923         }
924
925         /* Second, check alignment. */
926         slack = 0;
927
928 #ifndef atarist /* on the atari we dont have to worry about this */
929 #  ifndef I286  /* The sbrk(0) call on the I286 always returns the next segment */
930
931         /* CHUNK_SHIFT is 1 for PACK_MALLOC, 0 otherwise. */
932         if ((UV)cp & (0x7FF >> CHUNK_SHIFT)) { /* Not aligned. */
933             slack = (0x800 >> CHUNK_SHIFT)
934                 - ((UV)cp & (0x7FF >> CHUNK_SHIFT));
935             add += slack;
936         }
937 #  endif
938 #endif /* atarist */
939                 
940         if (add) {
941             DEBUG_m(PerlIO_printf(Perl_debug_log, 
942                                   "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",
943                                   (long)add, (long) slack,
944                                   (long) sbrked_remains));
945             newcp = (char *)sbrk(add);
946 #if defined(DEBUGGING_MSTATS)
947             sbrks++;
948             sbrk_slack += add;
949 #endif
950             if (newcp != cp + require) {
951                 /* Too bad: even rounding sbrk() is not continuous.*/
952                 DEBUG_m(PerlIO_printf(Perl_debug_log, 
953                                       "failed to fix bad sbrk()\n"));
954 #ifdef PACK_MALLOC
955                 if (slack) {
956                     MUTEX_UNLOCK(&malloc_mutex);
957                     croak("%s", "panic: Off-page sbrk");
958                 }
959 #endif
960                 if (sbrked_remains) {
961                     /* Try again. */
962 #if defined(DEBUGGING_MSTATS)
963                     sbrk_slack += require;
964 #endif
965                     require = needed;
966                     DEBUG_m(PerlIO_printf(Perl_debug_log, 
967                                           "straight sbrk(%ld)\n",
968                                           (long)require));
969                     cp = (char *)sbrk(require);
970 #ifdef DEBUGGING_MSTATS
971                     sbrks++;
972 #endif 
973                     if (cp == (char *)-1)
974                         return 0;
975                 }
976                 sbrk_good = -1; /* Disable optimization!
977                                    Continue with not-aligned... */
978             } else {
979                 cp += slack;
980                 require += sbrked_remains;
981             }
982         }
983
984         if (last_sbrk_top) {
985             sbrk_good -= SBRK_FAILURE_PRICE;
986         }
987
988         ovp = (union overhead *) cp;
989         /*
990          * Round up to minimum allocation size boundary
991          * and deduct from block count to reflect.
992          */
993
994 #ifndef I286    /* Again, this should always be ok on an 80286 */
995         if ((UV)ovp & 7) {
996             ovp = (union overhead *)(((UV)ovp + 8) & ~7);
997             DEBUG_m(PerlIO_printf(Perl_debug_log, 
998                                   "fixing sbrk(): %d bytes off machine alignement\n",
999                                   (int)((UV)ovp & 7)));
1000             (*nblksp)--;
1001 # if defined(DEBUGGING_MSTATS)
1002             /* This is only approx. if TWO_POT_OPTIMIZE: */
1003             sbrk_slack += (1 << bucket);
1004 # endif
1005         }
1006 #endif
1007         sbrked_remains = require - needed;
1008     }
1009     last_sbrk_top = cp + require;
1010     last_op = (char*) cp;
1011 #ifdef DEBUGGING_MSTATS
1012     goodsbrk += require;
1013 #endif  
1014     return ovp;
1015 }
1016
1017 static int
1018 getpages_adjacent(int require)
1019 {           
1020     if (require <= sbrked_remains) {
1021         sbrked_remains -= require;
1022     } else {
1023         char *cp;
1024
1025         require -= sbrked_remains;
1026         /* We do not try to optimize sbrks here, we go for place. */
1027         cp = (char*) sbrk(require);
1028 #ifdef DEBUGGING_MSTATS
1029         sbrks++;
1030         goodsbrk += require;
1031 #endif 
1032         if (cp == last_sbrk_top) {
1033             sbrked_remains = 0;
1034             last_sbrk_top = cp + require;
1035         } else {
1036             /* Report the failure: */
1037             if (sbrked_remains)
1038                 add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1039                              sbrked_remains, 0);
1040             add_to_chain((void*)cp, require, 0);
1041             sbrk_good -= SBRK_FAILURE_PRICE;
1042             sbrked_remains = 0;
1043             last_sbrk_top = 0;
1044             last_op = 0;
1045             return 0;
1046         }
1047     }
1048             
1049     return 1;
1050 }
1051
1052 /*
1053  * Allocate more memory to the indicated bucket.
1054  */
1055 static void
1056 morecore(register int bucket)
1057 {
1058         register union overhead *ovp;
1059         register int rnu;       /* 2^rnu bytes will be requested */
1060         int nblks;              /* become nblks blocks of the desired size */
1061         register MEM_SIZE siz, needed;
1062
1063         if (nextf[bucket])
1064                 return;
1065         if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
1066             MUTEX_UNLOCK(&malloc_mutex);
1067             croak("%s", "Out of memory during ridiculously large request");
1068         }
1069         if (bucket > max_bucket)
1070             max_bucket = bucket;
1071
1072         rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT)) 
1073                 ? LOG_OF_MIN_ARENA 
1074                 : (bucket >> BUCKET_POW2_SHIFT) );
1075         /* This may be overwritten later: */
1076         nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */
1077         needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket);
1078         if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */
1079             ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT;
1080             nextf[rnu << BUCKET_POW2_SHIFT]
1081                 = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next;
1082 #ifdef DEBUGGING_MSTATS
1083             nmalloc[rnu << BUCKET_POW2_SHIFT]--;
1084             start_slack -= M_OVERHEAD;
1085 #endif 
1086             DEBUG_m(PerlIO_printf(Perl_debug_log, 
1087                                   "stealing %ld bytes from %ld arena\n",
1088                                   (long) needed, (long) rnu << BUCKET_POW2_SHIFT));
1089         } else if (chunk_chain 
1090                    && (ovp = (union overhead*) get_from_chain(needed))) {
1091             DEBUG_m(PerlIO_printf(Perl_debug_log, 
1092                                   "stealing %ld bytes from chain\n",
1093                                   (long) needed));
1094         } else if ( (ovp = (union overhead*)
1095                      get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
1096                                              needed)) ) {
1097             DEBUG_m(PerlIO_printf(Perl_debug_log, 
1098                                   "stealing %ld bytes from bigger buckets\n",
1099                                   (long) needed));
1100         } else if (needed <= sbrked_remains) {
1101             ovp = (union overhead *)(last_sbrk_top - sbrked_remains);
1102             sbrked_remains -= needed;
1103             last_op = (char*)ovp;
1104         } else 
1105             ovp = getpages(needed, &nblks, bucket);
1106
1107         if (!ovp)
1108             return;
1109
1110         /*
1111          * Add new memory allocated to that on
1112          * free list for this hash bucket.
1113          */
1114         siz = BUCKET_SIZE(bucket);
1115 #ifdef PACK_MALLOC
1116         *(u_char*)ovp = bucket; /* Fill index. */
1117         if (bucket <= MAX_PACKED) {
1118             ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1119             nblks = N_BLKS(bucket);
1120 #  ifdef DEBUGGING_MSTATS
1121             start_slack += BLK_SHIFT(bucket);
1122 #  endif
1123         } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) {
1124             ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1125             siz -= sizeof(union overhead);
1126         } else ovp++;           /* One chunk per block. */
1127 #endif /* PACK_MALLOC */
1128         nextf[bucket] = ovp;
1129 #ifdef DEBUGGING_MSTATS
1130         nmalloc[bucket] += nblks;
1131         if (bucket > MAX_PACKED) {
1132             start_slack += M_OVERHEAD * nblks;
1133         }
1134 #endif 
1135         while (--nblks > 0) {
1136                 ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
1137                 ovp = (union overhead *)((caddr_t)ovp + siz);
1138         }
1139         /* Not all sbrks return zeroed memory.*/
1140         ovp->ov_next = (union overhead *)NULL;
1141 #ifdef PACK_MALLOC
1142         if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */
1143             union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next;
1144             nextf[7*BUCKETS_PER_POW2] = 
1145                 (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2] 
1146                                    - sizeof(union overhead));
1147             nextf[7*BUCKETS_PER_POW2]->ov_next = n_op;
1148         }
1149 #endif /* !PACK_MALLOC */
1150 }
1151
1152 Free_t
1153 free(void *mp)
1154 {   
1155         register MEM_SIZE size;
1156         register union overhead *ovp;
1157         char *cp = (char*)mp;
1158 #ifdef PACK_MALLOC
1159         u_char bucket;
1160 #endif 
1161
1162         DEBUG_m(PerlIO_printf(Perl_debug_log, 
1163                               "0x%lx: (%05lu) free\n",
1164                               (unsigned long)cp, (unsigned long)(an++)));
1165
1166         if (cp == NULL)
1167                 return;
1168         ovp = (union overhead *)((caddr_t)cp 
1169                                 - sizeof (union overhead) * CHUNK_SHIFT);
1170 #ifdef PACK_MALLOC
1171         bucket = OV_INDEX(ovp);
1172 #endif 
1173 #ifdef IGNORE_SMALL_BAD_FREE
1174         if ((bucket >= FIRST_BUCKET_WITH_CHECK) 
1175             && (OV_MAGIC(ovp, bucket) != MAGIC))
1176 #else
1177         if (OV_MAGIC(ovp, bucket) != MAGIC)
1178 #endif 
1179             {
1180                 static int bad_free_warn = -1;
1181                 if (bad_free_warn == -1) {
1182                     char *pbf = PerlEnv_getenv("PERL_BADFREE");
1183                     bad_free_warn = (pbf) ? atoi(pbf) : 1;
1184                 }
1185                 if (!bad_free_warn)
1186                     return;
1187 #ifdef RCHECK
1188                 warn("%s free() ignored",
1189                     ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
1190 #else
1191                 warn("%s", "Bad free() ignored");
1192 #endif
1193                 return;                         /* sanity */
1194             }
1195         MUTEX_LOCK(&malloc_mutex);
1196 #ifdef RCHECK
1197         ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
1198         if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
1199             int i;
1200             MEM_SIZE nbytes = ovp->ov_size + 1;
1201
1202             if ((i = nbytes & 3)) {
1203                 i = 4 - i;
1204                 while (i--) {
1205                     ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
1206                            == RMAGIC_C, "chunk's tail overwrite");
1207                 }
1208             }
1209             nbytes = (nbytes + 3) &~ 3; 
1210             ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite");          
1211         }
1212         ovp->ov_rmagic = RMAGIC - 1;
1213 #endif
1214         ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
1215         size = OV_INDEX(ovp);
1216         ovp->ov_next = nextf[size];
1217         nextf[size] = ovp;
1218         MUTEX_UNLOCK(&malloc_mutex);
1219 }
1220
1221 /*
1222  * When a program attempts "storage compaction" as mentioned in the
1223  * old malloc man page, it realloc's an already freed block.  Usually
1224  * this is the last block it freed; occasionally it might be farther
1225  * back.  We have to search all the free lists for the block in order
1226  * to determine its bucket: 1st we make one pass thru the lists
1227  * checking only the first block in each; if that fails we search
1228  * ``reall_srchlen'' blocks in each list for a match (the variable
1229  * is extern so the caller can modify it).  If that fails we just copy
1230  * however many bytes was given to realloc() and hope it's not huge.
1231  */
1232 int reall_srchlen = 4;  /* 4 should be plenty, -1 =>'s whole list */
1233
1234 Malloc_t
1235 realloc(void *mp, size_t nbytes)
1236 {   
1237         register MEM_SIZE onb;
1238         union overhead *ovp;
1239         char *res;
1240         int prev_bucket;
1241         register int bucket;
1242         int was_alloced = 0, incr;
1243         char *cp = (char*)mp;
1244
1245 #if defined(DEBUGGING) || !defined(PERL_CORE)
1246         MEM_SIZE size = nbytes;
1247
1248         if ((long)nbytes < 0)
1249                 croak("%s", "panic: realloc");
1250 #endif
1251
1252         BARK_64K_LIMIT("Reallocation",nbytes,size);
1253         if (!cp)
1254                 return malloc(nbytes);
1255
1256         MUTEX_LOCK(&malloc_mutex);
1257         ovp = (union overhead *)((caddr_t)cp 
1258                                 - sizeof (union overhead) * CHUNK_SHIFT);
1259         bucket = OV_INDEX(ovp);
1260 #ifdef IGNORE_SMALL_BAD_FREE
1261         if ((bucket < FIRST_BUCKET_WITH_CHECK) 
1262             || (OV_MAGIC(ovp, bucket) == MAGIC))
1263 #else
1264         if (OV_MAGIC(ovp, bucket) == MAGIC) 
1265 #endif 
1266         {
1267                 was_alloced = 1;
1268         } else {
1269                 /*
1270                  * Already free, doing "compaction".
1271                  *
1272                  * Search for the old block of memory on the
1273                  * free list.  First, check the most common
1274                  * case (last element free'd), then (this failing)
1275                  * the last ``reall_srchlen'' items free'd.
1276                  * If all lookups fail, then assume the size of
1277                  * the memory block being realloc'd is the
1278                  * smallest possible.
1279                  */
1280                 if ((bucket = findbucket(ovp, 1)) < 0 &&
1281                     (bucket = findbucket(ovp, reall_srchlen)) < 0)
1282                         bucket = 0;
1283         }
1284         onb = BUCKET_SIZE_REAL(bucket);
1285         /* 
1286          *  avoid the copy if same size block.
1287          *  We are not agressive with boundary cases. Note that it might
1288          *  (for a small number of cases) give false negative if
1289          *  both new size and old one are in the bucket for
1290          *  FIRST_BIG_POW2, but the new one is near the lower end.
1291          *
1292          *  We do not try to go to 1.5 times smaller bucket so far.
1293          */
1294         if (nbytes > onb) incr = 1;
1295         else {
1296 #ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING
1297             if ( /* This is a little bit pessimal if PACK_MALLOC: */
1298                 nbytes > ( (onb >> 1) - M_OVERHEAD )
1299 #  ifdef TWO_POT_OPTIMIZE
1300                 || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND )
1301 #  endif        
1302                 )
1303 #else  /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1304                 prev_bucket = ( (bucket > MAX_PACKED + 1) 
1305                                 ? bucket - BUCKETS_PER_POW2
1306                                 : bucket - 1);
1307              if (nbytes > BUCKET_SIZE_REAL(prev_bucket))
1308 #endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1309                  incr = 0;
1310              else incr = -1;
1311         }
1312         if (!was_alloced
1313 #ifdef STRESS_REALLOC
1314             || 1 /* always do it the hard way */
1315 #endif
1316             ) goto hard_way;
1317         else if (incr == 0) {
1318           inplace_label:
1319 #ifdef RCHECK
1320                 /*
1321                  * Record new allocated size of block and
1322                  * bound space with magic numbers.
1323                  */
1324                 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
1325                        int i, nb = ovp->ov_size + 1;
1326
1327                        if ((i = nb & 3)) {
1328                            i = 4 - i;
1329                            while (i--) {
1330                                ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite");
1331                            }
1332                        }
1333                        nb = (nb + 3) &~ 3; 
1334                        ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite");
1335                         /*
1336                          * Convert amount of memory requested into
1337                          * closest block size stored in hash buckets
1338                          * which satisfies request.  Account for
1339                          * space used per block for accounting.
1340                          */
1341                         nbytes += M_OVERHEAD;
1342                         ovp->ov_size = nbytes - 1;
1343                         if ((i = nbytes & 3)) {
1344                             i = 4 - i;
1345                             while (i--)
1346                                 *((char *)((caddr_t)ovp + nbytes - RSLOP + i))
1347                                     = RMAGIC_C;
1348                         }
1349                         nbytes = (nbytes + 3) &~ 3; 
1350                         *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
1351                 }
1352 #endif
1353                 res = cp;
1354                 MUTEX_UNLOCK(&malloc_mutex);
1355         } else if (incr == 1 && (cp - M_OVERHEAD == last_op) 
1356                    && (onb > (1 << LOG_OF_MIN_ARENA))) {
1357             MEM_SIZE require, newarena = nbytes, pow;
1358             int shiftr;
1359
1360             POW2_OPTIMIZE_ADJUST(newarena);
1361             newarena = newarena + M_OVERHEAD;
1362             /* newarena = (newarena + 3) &~ 3; */
1363             shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA;
1364             pow = LOG_OF_MIN_ARENA + 1;
1365             /* apart from this loop, this is O(1) */
1366             while (shiftr >>= 1)
1367                 pow++;
1368             newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2);
1369             require = newarena - onb - M_OVERHEAD;
1370             
1371             if (getpages_adjacent(require)) {
1372 #ifdef DEBUGGING_MSTATS
1373                 nmalloc[bucket]--;
1374                 nmalloc[pow * BUCKETS_PER_POW2]++;
1375 #endif      
1376                 *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
1377                 goto inplace_label;
1378             } else
1379                 goto hard_way;
1380         } else {
1381           hard_way:
1382             MUTEX_UNLOCK(&malloc_mutex);
1383             if ((res = (char*)malloc(nbytes)) == NULL)
1384                 return (NULL);
1385             if (cp != res)                      /* common optimization */
1386                 Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
1387             if (was_alloced)
1388                 free(cp);
1389         }
1390
1391         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lu: (%05lu) rfree\n",
1392                               (unsigned long)res,(unsigned long)(an++)));
1393         DEBUG_m(PerlIO_printf(Perl_debug_log, 
1394                               "0x%lx: (%05lu) realloc %ld bytes\n",
1395                               (unsigned long)res,(unsigned long)(an++),
1396                               (long)size));
1397         return ((Malloc_t)res);
1398 }
1399
1400 /*
1401  * Search ``srchlen'' elements of each free list for a block whose
1402  * header starts at ``freep''.  If srchlen is -1 search the whole list.
1403  * Return bucket number, or -1 if not found.
1404  */
1405 static int
1406 findbucket(union overhead *freep, int srchlen)
1407 {
1408         register union overhead *p;
1409         register int i, j;
1410
1411         for (i = 0; i < NBUCKETS; i++) {
1412                 j = 0;
1413                 for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
1414                         if (p == freep)
1415                                 return (i);
1416                         j++;
1417                 }
1418         }
1419         return (-1);
1420 }
1421
1422 Malloc_t
1423 calloc(register size_t elements, register size_t size)
1424 {
1425     long sz = elements * size;
1426     Malloc_t p = malloc(sz);
1427
1428     if (p) {
1429         memset((void*)p, 0, sz);
1430     }
1431     return p;
1432 }
1433
1434 MEM_SIZE
1435 malloced_size(void *p)
1436 {
1437     union overhead *ovp = (union overhead *)
1438         ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
1439     int bucket = OV_INDEX(ovp);
1440 #ifdef RCHECK
1441     /* The caller wants to have a complete control over the chunk,
1442        disable the memory checking inside the chunk.  */
1443     if (bucket <= MAX_SHORT_BUCKET) {
1444         MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
1445         ovp->ov_size = size + M_OVERHEAD - 1;
1446         *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC;
1447     }
1448 #endif
1449     return BUCKET_SIZE_REAL(bucket);
1450 }
1451
1452 #ifdef DEBUGGING_MSTATS
1453
1454 #  ifdef BUCKETS_ROOT2
1455 #    define MIN_EVEN_REPORT 6
1456 #  else
1457 #    define MIN_EVEN_REPORT MIN_BUCKET
1458 #  endif 
1459 /*
1460  * mstats - print out statistics about malloc
1461  * 
1462  * Prints two lines of numbers, one showing the length of the free list
1463  * for each size category, the second showing the number of mallocs -
1464  * frees for each size category.
1465  */
1466 void
1467 dump_mstats(char *s)
1468 {
1469         register int i, j;
1470         register union overhead *p;
1471         int topbucket=0, topbucket_ev=0, topbucket_odd=0, totfree=0, total=0;
1472         u_int nfree[NBUCKETS];
1473         int total_chain = 0;
1474         struct chunk_chain_s* nextchain = chunk_chain;
1475
1476         for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
1477                 for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
1478                         ;
1479                 nfree[i] = j;
1480                 totfree += nfree[i] * BUCKET_SIZE_REAL(i);
1481                 total += nmalloc[i] * BUCKET_SIZE_REAL(i);
1482                 if (nmalloc[i]) {
1483                     i % 2 ? (topbucket_odd = i) : (topbucket_ev = i);
1484                     topbucket = i;
1485                 }
1486         }
1487         if (s)
1488             PerlIO_printf(PerlIO_stderr(),
1489                           "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n",
1490                           s, 
1491                           (long)BUCKET_SIZE_REAL(MIN_BUCKET), 
1492                           (long)BUCKET_SIZE(MIN_BUCKET),
1493                           (long)BUCKET_SIZE_REAL(topbucket), (long)BUCKET_SIZE(topbucket));
1494         PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree);
1495         for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
1496                 PerlIO_printf(PerlIO_stderr(), 
1497                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1498                                ? " %5d" 
1499                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1500                               nfree[i]);
1501         }
1502 #ifdef BUCKETS_ROOT2
1503         PerlIO_printf(PerlIO_stderr(), "\n\t   ");
1504         for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
1505                 PerlIO_printf(PerlIO_stderr(), 
1506                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1507                                ? " %5d" 
1508                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1509                               nfree[i]);
1510         }
1511 #endif 
1512         PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree);
1513         for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
1514                 PerlIO_printf(PerlIO_stderr(), 
1515                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1516                                ? " %5d" 
1517                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), 
1518                               nmalloc[i] - nfree[i]);
1519         }
1520 #ifdef BUCKETS_ROOT2
1521         PerlIO_printf(PerlIO_stderr(), "\n\t   ");
1522         for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
1523                 PerlIO_printf(PerlIO_stderr(), 
1524                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1525                                ? " %5d" 
1526                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1527                               nmalloc[i] - nfree[i]);
1528         }
1529 #endif 
1530         while (nextchain) {
1531             total_chain += nextchain->size;
1532             nextchain = nextchain->next;
1533         }
1534         PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %d/%d:%d. Odd ends: pad+heads+chain+tail: %d+%d+%d+%d.\n",
1535                       goodsbrk + sbrk_slack, sbrks, sbrk_good, sbrk_slack,
1536                       start_slack, total_chain, sbrked_remains);
1537 }
1538 #else
1539 void
1540 dump_mstats(char *s)
1541 {
1542 }
1543 #endif
1544 #endif /* lint */
1545
1546
1547 #ifdef USE_PERL_SBRK
1548
1549 #   ifdef NeXT
1550 #      define PERL_SBRK_VIA_MALLOC
1551 #   endif
1552
1553 #   ifdef __MACHTEN_PPC__
1554 #      define PERL_SBRK_VIA_MALLOC
1555 /*
1556  * MachTen's malloc() returns a buffer aligned on a two-byte boundary.
1557  * While this is adequate, it may slow down access to longer data
1558  * types by forcing multiple memory accesses.  It also causes
1559  * complaints when RCHECK is in force.  So we allocate six bytes
1560  * more than we need to, and return an address rounded up to an
1561  * eight-byte boundary.
1562  *
1563  * 980701 Dominic Dunlop <domo@computer.org>
1564  */
1565 #      define SYSTEM_ALLOC(a) ((void *)(((unsigned)malloc((a)+6)+6)&~7))
1566 #   endif
1567
1568 #   ifdef PERL_SBRK_VIA_MALLOC
1569 #      if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
1570 #         undef malloc          /* Expose names that  */
1571 #         undef calloc          /* HIDEMYMALLOC hides */
1572 #         undef realloc
1573 #         undef free
1574 #      else
1575 #         include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC"
1576 #      endif
1577
1578 /* it may seem schizophrenic to use perl's malloc and let it call system */
1579 /* malloc, the reason for that is only the 3.2 version of the OS that had */
1580 /* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
1581 /* end to the cores */
1582
1583 #      ifndef SYSTEM_ALLOC
1584 #         define SYSTEM_ALLOC(a) malloc(a)
1585 #      endif
1586
1587 #   endif  /* PERL_SBRK_VIA_MALLOC */
1588
1589 static IV Perl_sbrk_oldchunk;
1590 static long Perl_sbrk_oldsize;
1591
1592 #   define PERLSBRK_32_K (1<<15)
1593 #   define PERLSBRK_64_K (1<<16)
1594
1595 Malloc_t
1596 Perl_sbrk(size)
1597 int size;
1598 {
1599     IV got;
1600     int small, reqsize;
1601
1602     if (!size) return 0;
1603 #ifdef PERL_CORE
1604     reqsize = size; /* just for the DEBUG_m statement */
1605 #endif
1606 #ifdef PACK_MALLOC
1607     size = (size + 0x7ff) & ~0x7ff;
1608 #endif
1609     if (size <= Perl_sbrk_oldsize) {
1610         got = Perl_sbrk_oldchunk;
1611         Perl_sbrk_oldchunk += size;
1612         Perl_sbrk_oldsize -= size;
1613     } else {
1614       if (size >= PERLSBRK_32_K) {
1615         small = 0;
1616       } else {
1617         size = PERLSBRK_64_K;
1618         small = 1;
1619       }
1620       got = (IV)SYSTEM_ALLOC(size);
1621 #ifdef PACK_MALLOC
1622       got = (got + 0x7ff) & ~0x7ff;
1623 #endif
1624       if (small) {
1625         /* Chunk is small, register the rest for future allocs. */
1626         Perl_sbrk_oldchunk = got + reqsize;
1627         Perl_sbrk_oldsize = size - reqsize;
1628       }
1629     }
1630
1631     DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
1632                     size, reqsize, Perl_sbrk_oldsize, got));
1633
1634     return (void *)got;
1635 }
1636
1637 #endif /* ! defined USE_PERL_SBRK */