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