malloc.c

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