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