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 */