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