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