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