malloc.c

   1 /*    malloc.c
   2  *
   3  */
   4
   5 /*
   6   Here are some notes on configuring Perl's malloc.  (For non-perl
   7   usage see below.)
   8
   9   There are two macros which serve as bulk disablers of advanced
  10   features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by
  11   default).  Look in the list of default values below to understand
  12   their exact effect.  Defining NO_FANCY_MALLOC returns malloc.c to the
  13   state of the malloc in Perl 5.004.  Additionally defining PLAIN_MALLOC
  14   returns it to the state as of Perl 5.000.
  15
  16   Note that some of the settings below may be ignored in the code based
  17   on values of other macros.  The PERL_CORE symbol is only defined when
  18   perl itself is being compiled (so malloc can make some assumptions
  19   about perl's facilities being available to it).
  20
  21   Each config option has a short description, followed by its name,
  22   default value, and a comment about the default (if applicable).  Some
  23   options take a precise value, while the others are just boolean.
  24   The boolean ones are listed first.
  25
  26     # Enable code for an emergency memory pool in $^M.  See perlvar.pod
  27     # for a description of $^M.
  28     PERL_EMERGENCY_SBRK         (!PLAIN_MALLOC && PERL_CORE)
  29
  30     # Enable code for printing memory statistics.
  31     DEBUGGING_MSTATS            (!PLAIN_MALLOC && PERL_CORE)
  32
  33     # Move allocation info for small buckets into separate areas.
  34     # Memory optimization (especially for small allocations, of the
  35     # less than 64 bytes).  Since perl usually makes a large number
  36     # of small allocations, this is usually a win.
  37     PACK_MALLOC                 (!PLAIN_MALLOC && !RCHECK)
  38
  39     # Add one page to big powers of two when calculating bucket size.
  40     # This is targeted at big allocations, as are common in image
  41     # processing.
  42     TWO_POT_OPTIMIZE            !PLAIN_MALLOC
  43
  44     # Use intermediate bucket sizes between powers-of-two.  This is
  45     # generally a memory optimization, and a (small) speed pessimization.
  46     BUCKETS_ROOT2               !NO_FANCY_MALLOC
  47
  48     # Do not check small deallocations for bad free().  Memory
  49     # and speed optimization, error reporting pessimization.
  50     IGNORE_SMALL_BAD_FREE       (!NO_FANCY_MALLOC && !RCHECK)
  51
  52     # Use table lookup to decide in which bucket a given allocation will go.
  53     SMALL_BUCKET_VIA_TABLE      !NO_FANCY_MALLOC
  54
  55     # Use a perl-defined sbrk() instead of the (presumably broken or
  56     # missing) system-supplied sbrk().
  57     USE_PERL_SBRK               undef
  58
  59     # Use system malloc() (or calloc() etc.) to emulate sbrk(). Normally
  60     # only used with broken sbrk()s.
  61     PERL_SBRK_VIA_MALLOC        undef
  62
  63     # Which allocator to use if PERL_SBRK_VIA_MALLOC
  64     SYSTEM_ALLOC(a)             malloc(a)
  65
  66     # Minimal alignment (in bytes, should be a power of 2) of SYSTEM_ALLOC
  67     SYSTEM_ALLOC_ALIGNMENT      MEM_ALIGNBYTES
  68
  69     # Disable memory overwrite checking with DEBUGGING.  Memory and speed
  70     # optimization, error reporting pessimization.
  71     NO_RCHECK                   undef
  72
  73     # Enable memory overwrite checking with DEBUGGING.  Memory and speed
  74     # pessimization, error reporting optimization
  75     RCHECK                      (DEBUGGING && !NO_RCHECK)
  76
  77     # Failed allocations bigger than this size croak (if
  78     # PERL_EMERGENCY_SBRK is enabled) without touching $^M.  See
  79     # perlvar.pod for a description of $^M.
  80     BIG_SIZE                     (1<<16)        # 64K
  81
  82     # Starting from this power of two, add an extra page to the
  83     # size of the bucket. This enables optimized allocations of sizes
  84     # close to powers of 2.  Note that the value is indexed at 0.
  85     FIRST_BIG_POW2              15              # 32K, 16K is used too often
  86
  87     # Estimate of minimal memory footprint.  malloc uses this value to
  88     # request the most reasonable largest blocks of memory from the system.
  89     FIRST_SBRK                  (48*1024)
  90
  91     # Round up sbrk()s to multiples of this.
  92     MIN_SBRK                    2048
  93
  94     # Round up sbrk()s to multiples of this percent of footprint.
  95     MIN_SBRK_FRAC               3
  96
  97     # Add this much memory to big powers of two to get the bucket size.
  98     PERL_PAGESIZE               4096
  99
 100     # This many sbrk() discontinuities should be tolerated even
 101     # from the start without deciding that sbrk() is usually
 102     # discontinuous.
 103     SBRK_ALLOW_FAILURES         3
 104
 105     # This many continuous sbrk()s compensate for one discontinuous one.
 106     SBRK_FAILURE_PRICE          50
 107
 108     # Some configurations may ask for 12-byte-or-so allocations which
 109     # require 8-byte alignment (?!).  In such situation one needs to
 110     # define this to disable 12-byte bucket (will increase memory footprint)
 111     STRICT_ALIGNMENT            undef
 112
 113   This implementation assumes that calling PerlIO_printf() does not
 114   result in any memory allocation calls (used during a panic).
 115
 116  */
 117
 118 /*
 119    If used outside of Perl environment, it may be useful to redefine
 120    the following macros (listed below with defaults):
 121
 122      # Type of address returned by allocation functions
 123      Malloc_t                           void *
 124
 125      # Type of size argument for allocation functions
 126      MEM_SIZE                           unsigned long
 127
 128      # size of void*
 129      PTRSIZE                            4
 130
 131      # Maximal value in LONG
 132      LONG_MAX                           0x7FFFFFFF
 133
 134      # Unsigned integer type big enough to keep a pointer
 135      UV                                 unsigned long
 136
 137      # Type of pointer with 1-byte granularity
 138      caddr_t                            char *
 139
 140      # Type returned by free()
 141      Free_t                             void
 142
 143      # Very fatal condition reporting function (cannot call any )
 144      fatalcroak(arg)                    write(2,arg,strlen(arg)) + exit(2)
 145
 146      # Fatal error reporting function
 147      croak(format, arg)                 warn(idem) + exit(1)
 148
 149      # Error reporting function
 150      warn(format, arg)                  fprintf(stderr, idem)
 151
 152      # Locking/unlocking for MT operation
 153      MALLOC_LOCK                        MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex)
 154      MALLOC_UNLOCK                      MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex)
 155
 156      # Locking/unlocking mutex for MT operation
 157      MUTEX_LOCK(l)                      void
 158      MUTEX_UNLOCK(l)                    void
 159  */
 160
 161 #ifndef NO_FANCY_MALLOC
 162 #  ifndef SMALL_BUCKET_VIA_TABLE
 163 #    define SMALL_BUCKET_VIA_TABLE
 164 #  endif
 165 #  ifndef BUCKETS_ROOT2
 166 #    define BUCKETS_ROOT2
 167 #  endif
 168 #  ifndef IGNORE_SMALL_BAD_FREE
 169 #    define IGNORE_SMALL_BAD_FREE
 170 #  endif
 171 #endif
 172
 173 #ifndef PLAIN_MALLOC                    /* Bulk enable features */
 174 #  ifndef PACK_MALLOC
 175 #      define PACK_MALLOC
 176 #  endif
 177 #  ifndef TWO_POT_OPTIMIZE
 178 #    define TWO_POT_OPTIMIZE
 179 #  endif
 180 #  if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK)
 181 #    define PERL_EMERGENCY_SBRK
 182 #  endif
 183 #  if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
 184 #    define DEBUGGING_MSTATS
 185 #  endif
 186 #endif
 187
 188 #define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
 189 #define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
 190
 191 #if !(defined(I286) || defined(atarist) || defined(__MINT__))
 192         /* take 2k unless the block is bigger than that */
 193 #  define LOG_OF_MIN_ARENA 11
 194 #else
 195         /* take 16k unless the block is bigger than that
 196            (80286s like large segments!), probably good on the atari too */
 197 #  define LOG_OF_MIN_ARENA 14
 198 #endif
 199
 200 #ifndef lint
 201 #  if defined(DEBUGGING) && !defined(NO_RCHECK)
 202 #    define RCHECK
 203 #  endif
 204 #  if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE)
 205 #    undef IGNORE_SMALL_BAD_FREE
 206 #  endif
 207 /*
 208  * malloc.c (Caltech) 2/21/82
 209  * Chris Kingsley, kingsley@cit-20.
 210  *
 211  * This is a very fast storage allocator.  It allocates blocks of a small
 212  * number of different sizes, and keeps free lists of each size.  Blocks that
 213  * don't exactly fit are passed up to the next larger size.  In this
 214  * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
 215  * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
 216  * This is designed for use in a program that uses vast quantities of memory,
 217  * but bombs when it runs out.
 218  *
 219  * Modifications Copyright Ilya Zakharevich 1996-99.
 220  *
 221  * Still very quick, but much more thrifty.  (Std config is 10% slower
 222  * than it was, and takes 67% of old heap size for typical usage.)
 223  *
 224  * Allocations of small blocks are now table-driven to many different
 225  * buckets.  Sizes of really big buckets are increased to accomodata
 226  * common size=power-of-2 blocks.  Running-out-of-memory is made into
 227  * an exception.  Deeply configurable and thread-safe.
 228  *
 229  */
 230
 231 #ifdef PERL_CORE
 232 #  include "EXTERN.h"
 233 #  define PERL_IN_MALLOC_C
 234 #  include "perl.h"
 235 #  if defined(PERL_IMPLICIT_CONTEXT)
 236 #    define croak       Perl_croak_nocontext
 237 #    define warn        Perl_warn_nocontext
 238 #  endif
 239 #else
 240 #  ifdef PERL_FOR_X2P
 241 #    include "../EXTERN.h"
 242 #    include "../perl.h"
 243 #  else
 244 #    include <stdlib.h>
 245 #    include <stdio.h>
 246 #    include <memory.h>
 247 #    define _(arg) arg
 248 #    ifndef Malloc_t
 249 #      define Malloc_t void *
 250 #    endif
 251 #    ifndef PTRSIZE
 252 #      define PTRSIZE 4
 253 #    endif
 254 #    ifndef MEM_SIZE
 255 #      define MEM_SIZE unsigned long
 256 #    endif
 257 #    ifndef LONG_MAX
 258 #      define LONG_MAX 0x7FFFFFFF
 259 #    endif
 260 #    ifndef UV
 261 #      define UV unsigned long
 262 #    endif
 263 #    ifndef caddr_t
 264 #      define caddr_t char *
 265 #    endif
 266 #    ifndef Free_t
 267 #      define Free_t void
 268 #    endif
 269 #    define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
 270 #    define PerlEnv_getenv getenv
 271 #    define PerlIO_printf fprintf
 272 #    define PerlIO_stderr() stderr
 273 #  endif
 274 #  ifndef croak                         /* make depend */
 275 #    define croak(mess, arg) (warn((mess), (arg)), exit(1))
 276 #  endif
 277 #  ifndef warn
 278 #    define warn(mess, arg) fprintf(stderr, (mess), (arg))
 279 #  endif
 280 #  ifdef DEBUG_m
 281 #    undef DEBUG_m
 282 #  endif
 283 #  define DEBUG_m(a)
 284 #  ifdef DEBUGGING
 285 #     undef DEBUGGING
 286 #  endif
 287 #  ifndef pTHX
 288 #     define pTHX               void
 289 #     define pTHX_
 290 #     define dTHX               extern int Perl___notused
 291 #     define WITH_THX(s)        s
 292 #  endif
 293 #  ifndef PERL_GET_INTERP
 294 #     define PERL_GET_INTERP    PL_curinterp
 295 #  endif
 296 #  ifndef Perl_malloc
 297 #     define Perl_malloc malloc
 298 #  endif
 299 #  ifndef Perl_mfree
 300 #     define Perl_mfree free
 301 #  endif
 302 #  ifndef Perl_realloc
 303 #     define Perl_realloc realloc
 304 #  endif
 305 #  ifndef Perl_calloc
 306 #     define Perl_calloc calloc
 307 #  endif
 308 #  ifndef Perl_strdup
 309 #     define Perl_strdup strdup
 310 #  endif
 311 #endif
 312
 313 #ifndef MUTEX_LOCK
 314 #  define MUTEX_LOCK(l)
 315 #endif
 316
 317 #ifndef MUTEX_UNLOCK
 318 #  define MUTEX_UNLOCK(l)
 319 #endif
 320
 321 #ifndef MALLOC_LOCK
 322 #  define MALLOC_LOCK           MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex)
 323 #endif
 324
 325 #ifndef MALLOC_UNLOCK
 326 #  define MALLOC_UNLOCK         MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex)
 327 #endif
 328
 329 #  ifndef fatalcroak                            /* make depend */
 330 #    define fatalcroak(mess)    (write(2, (mess), strlen(mess)), exit(2))
 331 #  endif
 332
 333 #ifdef DEBUGGING
 334 #  undef DEBUG_m
 335 #  define DEBUG_m(a)  \
 336     STMT_START {                                                        \
 337         if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } }       \
 338     } STMT_END
 339 #endif
 340
 341 #ifdef PERL_IMPLICIT_CONTEXT
 342 #  define PERL_IS_ALIVE         aTHX
 343 #else
 344 #  define PERL_IS_ALIVE         TRUE
 345 #endif
 346
 347
 348 /*
 349  * Layout of memory:
 350  * ~~~~~~~~~~~~~~~~
 351  * The memory is broken into "blocks" which occupy multiples of 2K (and
 352  * generally speaking, have size "close" to a power of 2).  The addresses
 353  * of such *unused* blocks are kept in nextf[i] with big enough i.  (nextf
 354  * is an array of linked lists.)  (Addresses of used blocks are not known.)
 355  *
 356  * Moreover, since the algorithm may try to "bite" smaller blocks out
 357  * of unused bigger ones, there are also regions of "irregular" size,
 358  * managed separately, by a linked list chunk_chain.
 359  *
 360  * The third type of storage is the sbrk()ed-but-not-yet-used space, its
 361  * end and size are kept in last_sbrk_top and sbrked_remains.
 362  *
 363  * Growing blocks "in place":
 364  * ~~~~~~~~~~~~~~~~~~~~~~~~~
 365  * The address of the block with the greatest address is kept in last_op
 366  * (if not known, last_op is 0).  If it is known that the memory above
 367  * last_op is not continuous, or contains a chunk from chunk_chain,
 368  * last_op is set to 0.
 369  *
 370  * The chunk with address last_op may be grown by expanding into
 371  * sbrk()ed-but-not-yet-used space, or trying to sbrk() more continuous
 372  * memory.
 373  *
 374  * Management of last_op:
 375  * ~~~~~~~~~~~~~~~~~~~~~
 376  *
 377  * free() never changes the boundaries of blocks, so is not relevant.
 378  *
 379  * The only way realloc() may change the boundaries of blocks is if it
 380  * grows a block "in place".  However, in the case of success such a
 381  * chunk is automatically last_op, and it remains last_op.  In the case
 382  * of failure getpages_adjacent() clears last_op.
 383  *
 384  * malloc() may change blocks by calling morecore() only.
 385  *
 386  * morecore() may create new blocks by:
 387  *   a) biting pieces from chunk_chain (cannot create one above last_op);
 388  *   b) biting a piece from an unused block (if block was last_op, this
 389  *      may create a chunk from chain above last_op, thus last_op is
 390  *      invalidated in such a case).
 391  *   c) biting of sbrk()ed-but-not-yet-used space.  This creates
 392  *      a block which is last_op.
 393  *   d) Allocating new pages by calling getpages();
 394  *
 395  * getpages() creates a new block.  It marks last_op at the bottom of
 396  * the chunk of memory it returns.
 397  *
 398  * Active pages footprint:
 399  * ~~~~~~~~~~~~~~~~~~~~~~
 400  * Note that we do not need to traverse the lists in nextf[i], just take
 401  * the first element of this list.  However, we *need* to traverse the
 402  * list in chunk_chain, but most the time it should be a very short one,
 403  * so we do not step on a lot of pages we are not going to use.
 404  *
 405  * Flaws:
 406  * ~~~~~
 407  * get_from_bigger_buckets(): forget to increment price => Quite
 408  * aggressive.
 409  */
 410
 411 /* I don't much care whether these are defined in sys/types.h--LAW */
 412
 413 #define u_char unsigned char
 414 #define u_int unsigned int
 415 /*
 416  * I removed the definition of u_bigint which appeared to be u_bigint = UV
 417  * u_bigint was only used in TWOK_MASKED and TWOK_SHIFT
 418  * where I have used PTR2UV.  RMB
 419  */
 420 #define u_short unsigned short
 421
 422 /* 286 and atarist like big chunks, which gives too much overhead. */
 423 #if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC)
 424 #  undef PACK_MALLOC
 425 #endif
 426
 427 /*
 428  * The description below is applicable if PACK_MALLOC is not defined.
 429  *
 430  * The overhead on a block is at least 4 bytes.  When free, this space
 431  * contains a pointer to the next free block, and the bottom two bits must
 432  * be zero.  When in use, the first byte is set to MAGIC, and the second
 433  * byte is the size index.  The remaining bytes are for alignment.
 434  * If range checking is enabled and the size of the block fits
 435  * in two bytes, then the top two bytes hold the size of the requested block
 436  * plus the range checking words, and the header word MINUS ONE.
 437  */
 438 union   overhead {
 439         union   overhead *ov_next;      /* when free */
 440 #if MEM_ALIGNBYTES > 4
 441         double  strut;                  /* alignment problems */
 442 #endif
 443         struct {
 444                 u_char  ovu_magic;      /* magic number */
 445                 u_char  ovu_index;      /* bucket # */
 446 #ifdef RCHECK
 447                 u_short ovu_size;       /* actual block size */
 448                 u_int   ovu_rmagic;     /* range magic number */
 449 #endif
 450         } ovu;
 451 #define ov_magic        ovu.ovu_magic
 452 #define ov_index        ovu.ovu_index
 453 #define ov_size         ovu.ovu_size
 454 #define ov_rmagic       ovu.ovu_rmagic
 455 };
 456
 457 #define MAGIC           0xff            /* magic # on accounting info */
 458 #define RMAGIC          0x55555555      /* magic # on range info */
 459 #define RMAGIC_C        0x55            /* magic # on range info */
 460
 461 #ifdef RCHECK
 462 #  define       RSLOP           sizeof (u_int)
 463 #  ifdef TWO_POT_OPTIMIZE
 464 #    define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2)
 465 #  else
 466 #    define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
 467 #  endif
 468 #else
 469 #  define       RSLOP           0
 470 #endif
 471
 472 #if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
 473 #  undef BUCKETS_ROOT2
 474 #endif
 475
 476 #ifdef BUCKETS_ROOT2
 477 #  define BUCKET_TABLE_SHIFT 2
 478 #  define BUCKET_POW2_SHIFT 1
 479 #  define BUCKETS_PER_POW2 2
 480 #else
 481 #  define BUCKET_TABLE_SHIFT MIN_BUC_POW2
 482 #  define BUCKET_POW2_SHIFT 0
 483 #  define BUCKETS_PER_POW2 1
 484 #endif
 485
 486 #if !defined(MEM_ALIGNBYTES) || ((MEM_ALIGNBYTES > 4) && !defined(STRICT_ALIGNMENT))
 487 /* Figure out the alignment of void*. */
 488 struct aligner {
 489   char c;
 490   void *p;
 491 };
 492 #  define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
 493 #else
 494 #  define ALIGN_SMALL MEM_ALIGNBYTES
 495 #endif
 496
 497 #define IF_ALIGN_8(yes,no)      ((ALIGN_SMALL>4) ? (yes) : (no))
 498
 499 #ifdef BUCKETS_ROOT2
 500 #  define MAX_BUCKET_BY_TABLE 13
 501 static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
 502   {
 503       0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
 504   };
 505 #  define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
 506 #  define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE               \
 507                                ? buck_size[i]                           \
 508                                : ((1 << ((i) >> BUCKET_POW2_SHIFT))     \
 509                                   - MEM_OVERHEAD(i)                     \
 510                                   + POW2_OPTIMIZE_SURPLUS(i)))
 511 #else
 512 #  define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
 513 #  define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) + POW2_OPTIMIZE_SURPLUS(i))
 514 #endif
 515
 516
 517 #ifdef PACK_MALLOC
 518 /* In this case there are several possible layout of arenas depending
 519  * on the size.  Arenas are of sizes multiple to 2K, 2K-aligned, and
 520  * have a size close to a power of 2.
 521  *
 522  * Arenas of the size >= 4K keep one chunk only.  Arenas of size 2K
 523  * may keep one chunk or multiple chunks.  Here are the possible
 524  * layouts of arenas:
 525  *
 526  *      # One chunk only, chunksize 2^k + SOMETHING - ALIGN, k >= 11
 527  *
 528  * INDEX MAGIC1 UNUSED CHUNK1
 529  *
 530  *      # Multichunk with sanity checking and chunksize 2^k-ALIGN, k>7
 531  *
 532  * INDEX MAGIC1 MAGIC2 MAGIC3 UNUSED CHUNK1 CHUNK2 CHUNK3 ...
 533  *
 534  *      # Multichunk with sanity checking and size 2^k-ALIGN, k=7
 535  *
 536  * INDEX MAGIC1 MAGIC2 MAGIC3 UNUSED CHUNK1 UNUSED CHUNK2 CHUNK3 ...
 537  *
 538  *      # Multichunk with sanity checking and size up to 80
 539  *
 540  * INDEX UNUSED MAGIC1 UNUSED MAGIC2 UNUSED ... CHUNK1 CHUNK2 CHUNK3 ...
 541  *
 542  *      # No sanity check (usually up to 48=byte-long buckets)
 543  * INDEX UNUSED CHUNK1 CHUNK2 ...
 544  *
 545  * Above INDEX and MAGIC are one-byte-long.  Sizes of UNUSED are
 546  * appropriate to keep algorithms simple and memory aligned.  INDEX
 547  * encodes the size of the chunk, while MAGICn encodes state (used,
 548  * free or non-managed-by-us-so-it-indicates-a-bug) of CHUNKn.  MAGIC
 549  * is used for sanity checking purposes only.  SOMETHING is 0 or 4K
 550  * (to make size of big CHUNK accomodate allocations for powers of two
 551  * better).
 552  *
 553  * [There is no need to alignment between chunks, since C rules ensure
 554  *  that structs which need 2^k alignment have sizeof which is
 555  *  divisible by 2^k.  Thus as far as the last chunk is aligned at the
 556  *  end of the arena, and 2K-alignment does not contradict things,
 557  *  everything is going to be OK for sizes of chunks 2^n and 2^n +
 558  *  2^k.  Say, 80-bit buckets will be 16-bit aligned, and as far as we
 559  *  put allocations for requests in 65..80 range, all is fine.
 560  *
 561  *  Note, however, that standard malloc() puts more strict
 562  *  requirements than the above C rules.  Moreover, our algorithms of
 563  *  realloc() may break this idyll, but we suppose that realloc() does
 564  *  need not change alignment.]
 565  *
 566  * Is very important to make calculation of the offset of MAGICm as
 567  * quick as possible, since it is done on each malloc()/free().  In
 568  * fact it is so quick that it has quite little effect on the speed of
 569  * doing malloc()/free().  [By default] We forego such calculations
 570  * for small chunks, but only to save extra 3% of memory, not because
 571  * of speed considerations.
 572  *
 573  * Here is the algorithm [which is the same for all the allocations
 574  * schemes above], see OV_MAGIC(block,bucket).  Let OFFSETm be the
 575  * offset of the CHUNKm from the start of ARENA.  Then offset of
 576  * MAGICm is (OFFSET1 >> SHIFT) + ADDOFFSET.  Here SHIFT and ADDOFFSET
 577  * are numbers which depend on the size of the chunks only.
 578  *
 579  * Let as check some sanity conditions.  Numbers OFFSETm>>SHIFT are
 580  * different for all the chunks in the arena if 2^SHIFT is not greater
 581  * than size of the chunks in the arena.  MAGIC1 will not overwrite
 582  * INDEX provided ADDOFFSET is >0 if OFFSET1 < 2^SHIFT.  MAGIClast
 583  * will not overwrite CHUNK1 if OFFSET1 > (OFFSETlast >> SHIFT) +
 584  * ADDOFFSET.
 585  *
 586  * Make SHIFT the maximal possible (there is no point in making it
 587  * smaller).  Since OFFSETlast is 2K - CHUNKSIZE, above restrictions
 588  * give restrictions on OFFSET1 and on ADDOFFSET.
 589  *
 590  * In particular, for chunks of size 2^k with k>=6 we can put
 591  * ADDOFFSET to be from 0 to 2^k - 2^(11-k), and have
 592  * OFFSET1==chunksize.  For chunks of size 80 OFFSET1 of 2K%80=48 is
 593  * large enough to have ADDOFFSET between 1 and 16 (similarly for 96,
 594  * when ADDOFFSET should be 1).  In particular, keeping MAGICs for
 595  * these sizes gives no additional size penalty.
 596  *
 597  * However, for chunks of size 2^k with k<=5 this gives OFFSET1 >=
 598  * ADDOFSET + 2^(11-k).  Keeping ADDOFFSET 0 allows for 2^(11-k)-2^(11-2k)
 599  * chunks per arena.  This is smaller than 2^(11-k) - 1 which are
 600  * needed if no MAGIC is kept.  [In fact, having a negative ADDOFFSET
 601  * would allow for slightly more buckets per arena for k=2,3.]
 602  *
 603  * Similarly, for chunks of size 3/2*2^k with k<=5 MAGICs would span
 604  * the area up to 2^(11-k)+ADDOFFSET.  For k=4 this give optimal
 605  * ADDOFFSET as -7..0.  For k=3 ADDOFFSET can go up to 4 (with tiny
 606  * savings for negative ADDOFFSET).  For k=5 ADDOFFSET can go -1..16
 607  * (with no savings for negative values).
 608  *
 609  * In particular, keeping ADDOFFSET 0 for sizes of chunks up to 2^6
 610  * leads to tiny pessimizations in case of sizes 4, 8, 12, 24, and
 611  * leads to no contradictions except for size=80 (or 96.)
 612  *
 613  * However, it also makes sense to keep no magic for sizes 48 or less.
 614  * This is what we do.  In this case one needs ADDOFFSET>=1 also for
 615  * chunksizes 12, 24, and 48, unless one gets one less chunk per
 616  * arena.
 617  *
 618  * The algo of OV_MAGIC(block,bucket) keeps ADDOFFSET 0 until
 619  * chunksize of 64, then makes it 1.
 620  *
 621  * This allows for an additional optimization: the above scheme leads
 622  * to giant overheads for sizes 128 or more (one whole chunk needs to
 623  * be sacrifised to keep INDEX).  Instead we use chunks not of size
 624  * 2^k, but of size 2^k-ALIGN.  If we pack these chunks at the end of
 625  * the arena, then the beginnings are still in different 2^k-long
 626  * sections of the arena if k>=7 for ALIGN==4, and k>=8 if ALIGN=8.
 627  * Thus for k>7 the above algo of calculating the offset of the magic
 628  * will still give different answers for different chunks.  And to
 629  * avoid the overrun of MAGIC1 into INDEX, one needs ADDOFFSET of >=1.
 630  * In the case k=7 we just move the first chunk an extra ALIGN
 631  * backward inside the ARENA (this is done once per arena lifetime,
 632  * thus is not a big overhead).  */
 633 #  define MAX_PACKED_POW2 6
 634 #  define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
 635 #  define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
 636 #  define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
 637 #  define TWOK_MASKED(x) (PTR2UV(x) & ~TWOK_MASK)
 638 #  define TWOK_SHIFT(x) (PTR2UV(x) & TWOK_MASK)
 639 #  define OV_INDEXp(block) (INT2PTR(u_char*,TWOK_MASKED(block)))
 640 #  define OV_INDEX(block) (*OV_INDEXp(block))
 641 #  define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) +                  \
 642                                     (TWOK_SHIFT(block)>>                \
 643                                      (bucket>>BUCKET_POW2_SHIFT)) +     \
 644                                     (bucket >= MIN_NEEDS_SHIFT ? 1 : 0)))
 645     /* A bucket can have a shift smaller than it size, we need to
 646        shift its magic number so it will not overwrite index: */
 647 #  ifdef BUCKETS_ROOT2
 648 #    define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2 - 1) /* Shift 80 greater than chunk 64. */
 649 #  else
 650 #    define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2) /* Shift 128 greater than chunk 32. */
 651 #  endif
 652 #  define CHUNK_SHIFT 0
 653
 654 /* Number of active buckets of given ordinal. */
 655 #ifdef IGNORE_SMALL_BAD_FREE
 656 #define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
 657 #  define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK           \
 658                          ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE(bucket) \
 659                          : n_blks[bucket] )
 660 #else
 661 #  define N_BLKS(bucket) n_blks[bucket]
 662 #endif
 663
 664 static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
 665   {
 666 #  if BUCKETS_PER_POW2==1
 667       0, 0,
 668       (MIN_BUC_POW2==2 ? 384 : 0),
 669       224, 120, 62, 31, 16, 8, 4, 2
 670 #  else
 671       0, 0, 0, 0,
 672       (MIN_BUC_POW2==2 ? 384 : 0), (MIN_BUC_POW2==2 ? 384 : 0), /* 4, 4 */
 673       224, 149, 120, 80, 62, 41, 31, 25, 16, 16, 8, 8, 4, 4, 2, 2
 674 #  endif
 675   };
 676
 677 /* Shift of the first bucket with the given ordinal inside 2K chunk. */
 678 #ifdef IGNORE_SMALL_BAD_FREE
 679 #  define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK        \
 680                               ? ((1<<LOG_OF_MIN_ARENA)                  \
 681                                  - BUCKET_SIZE(bucket) * N_BLKS(bucket)) \
 682                               : blk_shift[bucket])
 683 #else
 684 #  define BLK_SHIFT(bucket) blk_shift[bucket]
 685 #endif
 686
 687 static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
 688   {
 689 #  if BUCKETS_PER_POW2==1
 690       0, 0,
 691       (MIN_BUC_POW2==2 ? 512 : 0),
 692       256, 128, 64, 64,                 /* 8 to 64 */
 693       16*sizeof(union overhead),
 694       8*sizeof(union overhead),
 695       4*sizeof(union overhead),
 696       2*sizeof(union overhead),
 697 #  else
 698       0, 0, 0, 0,
 699       (MIN_BUC_POW2==2 ? 512 : 0), (MIN_BUC_POW2==2 ? 512 : 0),
 700       256, 260, 128, 128, 64, 80, 64, 48, /* 8 to 96 */
 701       16*sizeof(union overhead), 16*sizeof(union overhead),
 702       8*sizeof(union overhead), 8*sizeof(union overhead),
 703       4*sizeof(union overhead), 4*sizeof(union overhead),
 704       2*sizeof(union overhead), 2*sizeof(union overhead),
 705 #  endif
 706   };
 707
 708 #  define NEEDED_ALIGNMENT 0x800        /* 2k boundaries */
 709 #  define WANTED_ALIGNMENT 0x800        /* 2k boundaries */
 710
 711 #else  /* !PACK_MALLOC */
 712
 713 #  define OV_MAGIC(block,bucket) (block)->ov_magic
 714 #  define OV_INDEX(block) (block)->ov_index
 715 #  define CHUNK_SHIFT 1
 716 #  define MAX_PACKED -1
 717 #  define NEEDED_ALIGNMENT MEM_ALIGNBYTES
 718 #  define WANTED_ALIGNMENT 0x400        /* 1k boundaries */
 719
 720 #endif /* !PACK_MALLOC */
 721
 722 #define M_OVERHEAD (sizeof(union overhead) + RSLOP)
 723
 724 #ifdef PACK_MALLOC
 725 #  define MEM_OVERHEAD(bucket) \
 726   (bucket <= MAX_PACKED ? 0 : M_OVERHEAD)
 727 #  ifdef SMALL_BUCKET_VIA_TABLE
 728 #    define START_SHIFTS_BUCKET ((MAX_PACKED_POW2 + 1) * BUCKETS_PER_POW2)
 729 #    define START_SHIFT MAX_PACKED_POW2
 730 #    ifdef BUCKETS_ROOT2                /* Chunks of size 3*2^n. */
 731 #      define SIZE_TABLE_MAX 80
 732 #    else
 733 #      define SIZE_TABLE_MAX 64
 734 #    endif
 735 static char bucket_of[] =
 736   {
 737 #    ifdef BUCKETS_ROOT2                /* Chunks of size 3*2^n. */
 738       /* 0 to 15 in 4-byte increments. */
 739       (sizeof(void*) > 4 ? 6 : 5),      /* 4/8, 5-th bucket for better reports */
 740       6,                                /* 8 */
 741       IF_ALIGN_8(8,7), 8,               /* 16/12, 16 */
 742       9, 9, 10, 10,                     /* 24, 32 */
 743       11, 11, 11, 11,                   /* 48 */
 744       12, 12, 12, 12,                   /* 64 */
 745       13, 13, 13, 13,                   /* 80 */
 746       13, 13, 13, 13                    /* 80 */
 747 #    else /* !BUCKETS_ROOT2 */
 748       /* 0 to 15 in 4-byte increments. */
 749       (sizeof(void*) > 4 ? 3 : 2),
 750       3,
 751       4, 4,
 752       5, 5, 5, 5,
 753       6, 6, 6, 6,
 754       6, 6, 6, 6
 755 #    endif /* !BUCKETS_ROOT2 */
 756   };
 757 #  else  /* !SMALL_BUCKET_VIA_TABLE */
 758 #    define START_SHIFTS_BUCKET MIN_BUCKET
 759 #    define START_SHIFT (MIN_BUC_POW2 - 1)
 760 #  endif /* !SMALL_BUCKET_VIA_TABLE */
 761 #else  /* !PACK_MALLOC */
 762 #  define MEM_OVERHEAD(bucket) M_OVERHEAD
 763 #  ifdef SMALL_BUCKET_VIA_TABLE
 764 #    undef SMALL_BUCKET_VIA_TABLE
 765 #  endif
 766 #  define START_SHIFTS_BUCKET MIN_BUCKET
 767 #  define START_SHIFT (MIN_BUC_POW2 - 1)
 768 #endif /* !PACK_MALLOC */
 769
 770 /*
 771  * Big allocations are often of the size 2^n bytes. To make them a
 772  * little bit better, make blocks of size 2^n+pagesize for big n.
 773  */
 774
 775 #ifdef TWO_POT_OPTIMIZE
 776
 777 #  ifndef PERL_PAGESIZE
 778 #    define PERL_PAGESIZE 4096
 779 #  endif
 780 #  ifndef FIRST_BIG_POW2
 781 #    define FIRST_BIG_POW2 15   /* 32K, 16K is used too often. */
 782 #  endif
 783 #  define FIRST_BIG_BLOCK (1<<FIRST_BIG_POW2)
 784 /* If this value or more, check against bigger blocks. */
 785 #  define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD)
 786 /* If less than this value, goes into 2^n-overhead-block. */
 787 #  define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD)
 788
 789 #  define POW2_OPTIMIZE_ADJUST(nbytes)                          \
 790    ((nbytes >= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0)
 791 #  define POW2_OPTIMIZE_SURPLUS(bucket)                         \
 792    ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)
 793
 794 #else  /* !TWO_POT_OPTIMIZE */
 795 #  define POW2_OPTIMIZE_ADJUST(nbytes)
 796 #  define POW2_OPTIMIZE_SURPLUS(bucket) 0
 797 #endif /* !TWO_POT_OPTIMIZE */
 798
 799 #if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
 800 #  define BARK_64K_LIMIT(what,nbytes,size)                              \
 801         if (nbytes > 0xffff) {                                          \
 802                 PerlIO_printf(PerlIO_stderr(),                          \
 803                               "%s too large: %lx\n", what, size);       \
 804                 my_exit(1);                                             \
 805         }
 806 #else /* !HAS_64K_LIMIT || !PERL_CORE */
 807 #  define BARK_64K_LIMIT(what,nbytes,size)
 808 #endif /* !HAS_64K_LIMIT || !PERL_CORE */
 809
 810 #ifndef MIN_SBRK
 811 #  define MIN_SBRK 2048
 812 #endif
 813
 814 #ifndef FIRST_SBRK
 815 #  define FIRST_SBRK (48*1024)
 816 #endif
 817
 818 /* Minimal sbrk in percents of what is already alloced. */
 819 #ifndef MIN_SBRK_FRAC
 820 #  define MIN_SBRK_FRAC 3
 821 #endif
 822
 823 #ifndef SBRK_ALLOW_FAILURES
 824 #  define SBRK_ALLOW_FAILURES 3
 825 #endif
 826
 827 #ifndef SBRK_FAILURE_PRICE
 828 #  define SBRK_FAILURE_PRICE 50
 829 #endif
 830
 831 #if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
 832
 833 #  ifndef BIG_SIZE
 834 #    define BIG_SIZE (1<<16)            /* 64K */
 835 #  endif
 836
 837 #ifdef I_MACH_CTHREADS
 838 #  undef  MUTEX_LOCK
 839 #  define MUTEX_LOCK(m)   STMT_START { if (*m) mutex_lock(*m);   } STMT_END
 840 #  undef  MUTEX_UNLOCK
 841 #  define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
 842 #endif
 843
 844 static char *emergency_buffer;
 845 static MEM_SIZE emergency_buffer_size;
 846
 847 static void     morecore        (register int bucket);
 848 #  if defined(DEBUGGING)
 849 static void     botch           (char *diag, char *s);
 850 #  endif
 851 static void     add_to_chain    (void *p, MEM_SIZE size, MEM_SIZE chip);
 852 static Malloc_t emergency_sbrk  (MEM_SIZE size);
 853 static void*    get_from_chain  (MEM_SIZE size);
 854 static void*    get_from_bigger_buckets(int bucket, MEM_SIZE size);
 855 static union overhead *getpages (MEM_SIZE needed, int *nblksp, int bucket);
 856 static int      getpages_adjacent(MEM_SIZE require);
 857
 858 static Malloc_t
 859 emergency_sbrk(MEM_SIZE size)
 860 {
 861     MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
 862
 863     if (size >= BIG_SIZE) {
 864         /* Give the possibility to recover: */
 865         MALLOC_UNLOCK;
 866         croak("Out of memory during \"large\" request for %i bytes", size);
 867     }
 868
 869     if (emergency_buffer_size >= rsize) {
 870         char *old = emergency_buffer;
 871
 872         emergency_buffer_size -= rsize;
 873         emergency_buffer += rsize;
 874         return old;
 875     } else {
 876         dTHX;
 877         /* First offense, give a possibility to recover by dieing. */
 878         /* No malloc involved here: */
 879         GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0);
 880         SV *sv;
 881         char *pv;
 882         int have = 0;
 883         STRLEN n_a;
 884
 885         if (emergency_buffer_size) {
 886             add_to_chain(emergency_buffer, emergency_buffer_size, 0);
 887             emergency_buffer_size = 0;
 888             emergency_buffer = Nullch;
 889             have = 1;
 890         }
 891         if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
 892         if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
 893             || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
 894             if (have)
 895                 goto do_croak;
 896             return (char *)-1;          /* Now die die die... */
 897         }
 898         /* Got it, now detach SvPV: */
 899         pv = SvPV(sv, n_a);
 900         /* Check alignment: */
 901         if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
 902             PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
 903             return (char *)-1;          /* die die die */
 904         }
 905
 906         emergency_buffer = pv - sizeof(union overhead);
 907         emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
 908         SvPOK_off(sv);
 909         SvPVX(sv) = Nullch;
 910         SvCUR(sv) = SvLEN(sv) = 0;
 911     }
 912   do_croak:
 913     MALLOC_UNLOCK;
 914     croak("Out of memory during request for %i bytes", size);
 915     /* NOTREACHED */
 916     return Nullch;
 917 }
 918
 919 #else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
 920 #  define emergency_sbrk(size)  -1
 921 #endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
 922
 923 #ifndef BITS_IN_PTR
 924 #  define BITS_IN_PTR (8*PTRSIZE)
 925 #endif
 926
 927 /*
 928  * nextf[i] is the pointer to the next free block of size 2^i.  The
 929  * smallest allocatable block is 8 bytes.  The overhead information
 930  * precedes the data area returned to the user.
 931  */
 932 #define NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
 933 static  union overhead *nextf[NBUCKETS];
 934
 935 #if defined(PURIFY) && !defined(USE_PERL_SBRK)
 936 #  define USE_PERL_SBRK
 937 #endif
 938
 939 #ifdef USE_PERL_SBRK
 940 #define sbrk(a) Perl_sbrk(a)
 941 Malloc_t Perl_sbrk (int size);
 942 #else
 943 #ifdef DONT_DECLARE_STD
 944 #ifdef I_UNISTD
 945 #include <unistd.h>
 946 #endif
 947 #else
 948 extern  Malloc_t sbrk(int);
 949 #endif
 950 #endif
 951
 952 #ifdef DEBUGGING_MSTATS
 953 /*
 954  * nmalloc[i] is the difference between the number of mallocs and frees
 955  * for a given block size.
 956  */
 957 static  u_int nmalloc[NBUCKETS];
 958 static  u_int sbrk_slack;
 959 static  u_int start_slack;
 960 #endif
 961
 962 static  u_int goodsbrk;
 963
 964 #ifdef DEBUGGING
 965 #undef ASSERT
 966 #define ASSERT(p,diag)   if (!(p)) botch(diag,STRINGIFY(p));  else
 967 static void
 968 botch(char *diag, char *s)
 969 {
 970         dTHX;
 971         PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
 972         PerlProc_abort();
 973 }
 974 #else
 975 #define ASSERT(p, diag)
 976 #endif
 977
 978 Malloc_t
 979 Perl_malloc(register size_t nbytes)
 980 {
 981         register union overhead *p;
 982         register int bucket;
 983         register MEM_SIZE shiftr;
 984         static void morecore(int bucket);
 985
 986 #if defined(DEBUGGING) || defined(RCHECK)
 987         MEM_SIZE size = nbytes;
 988 #endif
 989
 990         BARK_64K_LIMIT("Allocation",nbytes,nbytes);
 991 #ifdef DEBUGGING
 992         if ((long)nbytes < 0)
 993             croak("%s", "panic: malloc");
 994 #endif
 995
 996         /*
 997          * Convert amount of memory requested into
 998          * closest block size stored in hash buckets
 999          * which satisfies request.  Account for
1000          * space used per block for accounting.
1001          */
1002 #ifdef PACK_MALLOC
1003 #  ifdef SMALL_BUCKET_VIA_TABLE
1004         if (nbytes == 0)
1005             bucket = MIN_BUCKET;
1006         else if (nbytes <= SIZE_TABLE_MAX) {
1007             bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT];
1008         } else
1009 #  else
1010         if (nbytes == 0)
1011             nbytes = 1;
1012         if (nbytes <= MAX_POW2_ALGO) goto do_shifts;
1013         else
1014 #  endif
1015 #endif
1016         {
1017             POW2_OPTIMIZE_ADJUST(nbytes);
1018             nbytes += M_OVERHEAD;
1019             nbytes = (nbytes + 3) &~ 3;
1020           do_shifts:
1021             shiftr = (nbytes - 1) >> START_SHIFT;
1022             bucket = START_SHIFTS_BUCKET;
1023             /* apart from this loop, this is O(1) */
1024             while (shiftr >>= 1)
1025                 bucket += BUCKETS_PER_POW2;
1026         }
1027         MALLOC_LOCK;
1028         /*
1029          * If nothing in hash bucket right now,
1030          * request more memory from the system.
1031          */
1032         if (nextf[bucket] == NULL)
1033                 morecore(bucket);
1034         if ((p = nextf[bucket]) == NULL) {
1035                 MALLOC_UNLOCK;
1036 #ifdef PERL_CORE
1037                 {
1038                     dTHX;
1039                     if (!PL_nomemok) {
1040                         PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
1041                         my_exit(1);
1042                     }
1043                 }
1044 #endif
1045                 return (NULL);
1046         }
1047
1048         DEBUG_m(PerlIO_printf(Perl_debug_log,
1049                               "0x%"UVxf": (%05lu) malloc %ld bytes\n",
1050                               PTR2UV(p+1), (unsigned long)(PL_an++),
1051                               (long)size));
1052
1053         /* remove from linked list */
1054 #if defined(RCHECK)
1055         if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1)) {
1056             dTHX;
1057             PerlIO_printf(PerlIO_stderr(),
1058                           "Unaligned pointer in the free chain 0x%"UVxf"\n",
1059                           PTR2UV(p));
1060         }
1061         if ((PTR2UV(p->ov_next)) & (MEM_ALIGNBYTES - 1)) {
1062             dTHX;
1063             PerlIO_printf(PerlIO_stderr(),
1064                           "Unaligned `next' pointer in the free "
1065                           "chain 0x"UVxf" at 0x%"UVxf"\n",
1066                           PTR2UV(p->ov_next), PTR2UV(p));
1067         }
1068 #endif
1069         nextf[bucket] = p->ov_next;
1070
1071         MALLOC_UNLOCK;
1072
1073 #ifdef IGNORE_SMALL_BAD_FREE
1074         if (bucket >= FIRST_BUCKET_WITH_CHECK)
1075 #endif
1076             OV_MAGIC(p, bucket) = MAGIC;
1077 #ifndef PACK_MALLOC
1078         OV_INDEX(p) = bucket;
1079 #endif
1080 #ifdef RCHECK
1081         /*
1082          * Record allocated size of block and
1083          * bound space with magic numbers.
1084          */
1085         p->ov_rmagic = RMAGIC;
1086         if (bucket <= MAX_SHORT_BUCKET) {
1087             int i;
1088
1089             nbytes = size + M_OVERHEAD;
1090             p->ov_size = nbytes - 1;
1091             if ((i = nbytes & 3)) {
1092                 i = 4 - i;
1093                 while (i--)
1094                     *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C;
1095             }
1096             nbytes = (nbytes + 3) &~ 3;
1097             *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
1098         }
1099 #endif
1100         return ((Malloc_t)(p + CHUNK_SHIFT));
1101 }
1102
1103 static char *last_sbrk_top;
1104 static char *last_op;                   /* This arena can be easily extended. */
1105 static int sbrked_remains;
1106 static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
1107
1108 #ifdef DEBUGGING_MSTATS
1109 static int sbrks;
1110 #endif
1111
1112 struct chunk_chain_s {
1113     struct chunk_chain_s *next;
1114     MEM_SIZE size;
1115 };
1116 static struct chunk_chain_s *chunk_chain;
1117 static int n_chunks;
1118 static char max_bucket;
1119
1120 /* Cutoff a piece of one of the chunks in the chain.  Prefer smaller chunk. */
1121 static void *
1122 get_from_chain(MEM_SIZE size)
1123 {
1124     struct chunk_chain_s *elt = chunk_chain, **oldp = &chunk_chain;
1125     struct chunk_chain_s **oldgoodp = NULL;
1126     long min_remain = LONG_MAX;
1127
1128     while (elt) {
1129         if (elt->size >= size) {
1130             long remains = elt->size - size;
1131             if (remains >= 0 && remains < min_remain) {
1132                 oldgoodp = oldp;
1133                 min_remain = remains;
1134             }
1135             if (remains == 0) {
1136                 break;
1137             }
1138         }
1139         oldp = &( elt->next );
1140         elt = elt->next;
1141     }
1142     if (!oldgoodp) return NULL;
1143     if (min_remain) {
1144         void *ret = *oldgoodp;
1145         struct chunk_chain_s *next = (*oldgoodp)->next;
1146
1147         *oldgoodp = (struct chunk_chain_s *)((char*)ret + size);
1148         (*oldgoodp)->size = min_remain;
1149         (*oldgoodp)->next = next;
1150         return ret;
1151     } else {
1152         void *ret = *oldgoodp;
1153         *oldgoodp = (*oldgoodp)->next;
1154         n_chunks--;
1155         return ret;
1156     }
1157 }
1158
1159 static void
1160 add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip)
1161 {
1162     struct chunk_chain_s *next = chunk_chain;
1163     char *cp = (char*)p;
1164
1165     cp += chip;
1166     chunk_chain = (struct chunk_chain_s *)cp;
1167     chunk_chain->size = size - chip;
1168     chunk_chain->next = next;
1169     n_chunks++;
1170 }
1171
1172 static void *
1173 get_from_bigger_buckets(int bucket, MEM_SIZE size)
1174 {
1175     int price = 1;
1176     static int bucketprice[NBUCKETS];
1177     while (bucket <= max_bucket) {
1178         /* We postpone stealing from bigger buckets until we want it
1179            often enough. */
1180         if (nextf[bucket] && bucketprice[bucket]++ >= price) {
1181             /* Steal it! */
1182             void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT);
1183             bucketprice[bucket] = 0;
1184             if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) {
1185                 last_op = NULL;         /* Disable optimization */
1186             }
1187             nextf[bucket] = nextf[bucket]->ov_next;
1188 #ifdef DEBUGGING_MSTATS
1189             nmalloc[bucket]--;
1190             start_slack -= M_OVERHEAD;
1191 #endif
1192             add_to_chain(ret, (BUCKET_SIZE(bucket) +
1193                                POW2_OPTIMIZE_SURPLUS(bucket)),
1194                          size);
1195             return ret;
1196         }
1197         bucket++;
1198     }
1199     return NULL;
1200 }
1201
1202 static union overhead *
1203 getpages(MEM_SIZE needed, int *nblksp, int bucket)
1204 {
1205     /* Need to do (possibly expensive) system call. Try to
1206        optimize it for rare calling. */
1207     MEM_SIZE require = needed - sbrked_remains;
1208     char *cp;
1209     union overhead *ovp;
1210     MEM_SIZE slack = 0;
1211
1212     if (sbrk_good > 0) {
1213         if (!last_sbrk_top && require < FIRST_SBRK)
1214             require = FIRST_SBRK;
1215         else if (require < MIN_SBRK) require = MIN_SBRK;
1216
1217         if (require < goodsbrk * MIN_SBRK_FRAC / 100)
1218             require = goodsbrk * MIN_SBRK_FRAC / 100;
1219         require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
1220     } else {
1221         require = needed;
1222         last_sbrk_top = 0;
1223         sbrked_remains = 0;
1224     }
1225
1226     DEBUG_m(PerlIO_printf(Perl_debug_log,
1227                           "sbrk(%ld) for %ld-byte-long arena\n",
1228                           (long)require, (long) needed));
1229     cp = (char *)sbrk(require);
1230 #ifdef DEBUGGING_MSTATS
1231     sbrks++;
1232 #endif
1233     if (cp == last_sbrk_top) {
1234         /* Common case, anything is fine. */
1235         sbrk_good++;
1236         ovp = (union overhead *) (cp - sbrked_remains);
1237         last_op = cp - sbrked_remains;
1238         sbrked_remains = require - (needed - sbrked_remains);
1239     } else if (cp == (char *)-1) { /* no more room! */
1240         ovp = (union overhead *)emergency_sbrk(needed);
1241         if (ovp == (union overhead *)-1)
1242             return 0;
1243         if (((char*)ovp) > last_op) {   /* Cannot happen with current emergency_sbrk() */
1244             last_op = 0;
1245         }
1246         return ovp;
1247     } else {                    /* Non-continuous or first sbrk(). */
1248         long add = sbrked_remains;
1249         char *newcp;
1250
1251         if (sbrked_remains) {   /* Put rest into chain, we
1252                                    cannot use it right now. */
1253             add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1254                          sbrked_remains, 0);
1255         }
1256
1257         /* Second, check alignment. */
1258         slack = 0;
1259
1260 #if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */
1261 #  ifndef I286  /* The sbrk(0) call on the I286 always returns the next segment */
1262         /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may
1263            improve performance of memory access. */
1264         if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */
1265             slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1));
1266             add += slack;
1267         }
1268 #  endif
1269 #endif /* !atarist && !MINT */
1270
1271         if (add) {
1272             DEBUG_m(PerlIO_printf(Perl_debug_log,
1273                                   "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",
1274                                   (long)add, (long) slack,
1275                                   (long) sbrked_remains));
1276             newcp = (char *)sbrk(add);
1277 #if defined(DEBUGGING_MSTATS)
1278             sbrks++;
1279             sbrk_slack += add;
1280 #endif
1281             if (newcp != cp + require) {
1282                 /* Too bad: even rounding sbrk() is not continuous.*/
1283                 DEBUG_m(PerlIO_printf(Perl_debug_log,
1284                                       "failed to fix bad sbrk()\n"));
1285 #ifdef PACK_MALLOC
1286                 if (slack) {
1287                     MALLOC_UNLOCK;
1288                     fatalcroak("panic: Off-page sbrk\n");
1289                 }
1290 #endif
1291                 if (sbrked_remains) {
1292                     /* Try again. */
1293 #if defined(DEBUGGING_MSTATS)
1294                     sbrk_slack += require;
1295 #endif
1296                     require = needed;
1297                     DEBUG_m(PerlIO_printf(Perl_debug_log,
1298                                           "straight sbrk(%ld)\n",
1299                                           (long)require));
1300                     cp = (char *)sbrk(require);
1301 #ifdef DEBUGGING_MSTATS
1302                     sbrks++;
1303 #endif
1304                     if (cp == (char *)-1)
1305                         return 0;
1306                 }
1307                 sbrk_good = -1; /* Disable optimization!
1308                                    Continue with not-aligned... */
1309             } else {
1310                 cp += slack;
1311                 require += sbrked_remains;
1312             }
1313         }
1314
1315         if (last_sbrk_top) {
1316             sbrk_good -= SBRK_FAILURE_PRICE;
1317         }
1318
1319         ovp = (union overhead *) cp;
1320         /*
1321          * Round up to minimum allocation size boundary
1322          * and deduct from block count to reflect.
1323          */
1324
1325 #  if NEEDED_ALIGNMENT > MEM_ALIGNBYTES
1326         if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1))
1327             fatalcroak("Misalignment of sbrk()\n");
1328         else
1329 #  endif
1330 #ifndef I286    /* Again, this should always be ok on an 80286 */
1331         if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) {
1332             DEBUG_m(PerlIO_printf(Perl_debug_log,
1333                                   "fixing sbrk(): %d bytes off machine alignement\n",
1334                                   (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1))));
1335             ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) &
1336                                      (MEM_ALIGNBYTES - 1));
1337             (*nblksp)--;
1338 # if defined(DEBUGGING_MSTATS)
1339             /* This is only approx. if TWO_POT_OPTIMIZE: */
1340             sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
1341 # endif
1342         }
1343 #endif
1344         ;                               /* Finish `else' */
1345         sbrked_remains = require - needed;
1346         last_op = cp;
1347     }
1348     last_sbrk_top = cp + require;
1349 #ifdef DEBUGGING_MSTATS
1350     goodsbrk += require;
1351 #endif
1352     return ovp;
1353 }
1354
1355 static int
1356 getpages_adjacent(MEM_SIZE require)
1357 {
1358     if (require <= sbrked_remains) {
1359         sbrked_remains -= require;
1360     } else {
1361         char *cp;
1362
1363         require -= sbrked_remains;
1364         /* We do not try to optimize sbrks here, we go for place. */
1365         cp = (char*) sbrk(require);
1366 #ifdef DEBUGGING_MSTATS
1367         sbrks++;
1368         goodsbrk += require;
1369 #endif
1370         if (cp == last_sbrk_top) {
1371             sbrked_remains = 0;
1372             last_sbrk_top = cp + require;
1373         } else {
1374             if (cp == (char*)-1) {      /* Out of memory */
1375 #ifdef DEBUGGING_MSTATS
1376                 goodsbrk -= require;
1377 #endif
1378                 return 0;
1379             }
1380             /* Report the failure: */
1381             if (sbrked_remains)
1382                 add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1383                              sbrked_remains, 0);
1384             add_to_chain((void*)cp, require, 0);
1385             sbrk_good -= SBRK_FAILURE_PRICE;
1386             sbrked_remains = 0;
1387             last_sbrk_top = 0;
1388             last_op = 0;
1389             return 0;
1390         }
1391     }
1392
1393     return 1;
1394 }
1395
1396 /*
1397  * Allocate more memory to the indicated bucket.
1398  */
1399 static void
1400 morecore(register int bucket)
1401 {
1402         register union overhead *ovp;
1403         register int rnu;       /* 2^rnu bytes will be requested */
1404         int nblks;              /* become nblks blocks of the desired size */
1405         register MEM_SIZE siz, needed;
1406
1407         if (nextf[bucket])
1408                 return;
1409         if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
1410             MALLOC_UNLOCK;
1411             croak("%s", "Out of memory during ridiculously large request");
1412         }
1413         if (bucket > max_bucket)
1414             max_bucket = bucket;
1415
1416         rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT))
1417                 ? LOG_OF_MIN_ARENA
1418                 : (bucket >> BUCKET_POW2_SHIFT) );
1419         /* This may be overwritten later: */
1420         nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */
1421         needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket);
1422         if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */
1423             ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT;
1424             nextf[rnu << BUCKET_POW2_SHIFT]
1425                 = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next;
1426 #ifdef DEBUGGING_MSTATS
1427             nmalloc[rnu << BUCKET_POW2_SHIFT]--;
1428             start_slack -= M_OVERHEAD;
1429 #endif
1430             DEBUG_m(PerlIO_printf(Perl_debug_log,
1431                                   "stealing %ld bytes from %ld arena\n",
1432                                   (long) needed, (long) rnu << BUCKET_POW2_SHIFT));
1433         } else if (chunk_chain
1434                    && (ovp = (union overhead*) get_from_chain(needed))) {
1435             DEBUG_m(PerlIO_printf(Perl_debug_log,
1436                                   "stealing %ld bytes from chain\n",
1437                                   (long) needed));
1438         } else if ( (ovp = (union overhead*)
1439                      get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
1440                                              needed)) ) {
1441             DEBUG_m(PerlIO_printf(Perl_debug_log,
1442                                   "stealing %ld bytes from bigger buckets\n",
1443                                   (long) needed));
1444         } else if (needed <= sbrked_remains) {
1445             ovp = (union overhead *)(last_sbrk_top - sbrked_remains);
1446             sbrked_remains -= needed;
1447             last_op = (char*)ovp;
1448         } else
1449             ovp = getpages(needed, &nblks, bucket);
1450
1451         if (!ovp)
1452             return;
1453
1454         /*
1455          * Add new memory allocated to that on
1456          * free list for this hash bucket.
1457          */
1458         siz = BUCKET_SIZE(bucket);
1459 #ifdef PACK_MALLOC
1460         *(u_char*)ovp = bucket; /* Fill index. */
1461         if (bucket <= MAX_PACKED) {
1462             ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1463             nblks = N_BLKS(bucket);
1464 #  ifdef DEBUGGING_MSTATS
1465             start_slack += BLK_SHIFT(bucket);
1466 #  endif
1467         } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) {
1468             ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1469             siz -= sizeof(union overhead);
1470         } else ovp++;           /* One chunk per block. */
1471 #endif /* PACK_MALLOC */
1472         nextf[bucket] = ovp;
1473 #ifdef DEBUGGING_MSTATS
1474         nmalloc[bucket] += nblks;
1475         if (bucket > MAX_PACKED) {
1476             start_slack += M_OVERHEAD * nblks;
1477         }
1478 #endif
1479         while (--nblks > 0) {
1480                 ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
1481                 ovp = (union overhead *)((caddr_t)ovp + siz);
1482         }
1483         /* Not all sbrks return zeroed memory.*/
1484         ovp->ov_next = (union overhead *)NULL;
1485 #ifdef PACK_MALLOC
1486         if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */
1487             union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next;
1488             nextf[7*BUCKETS_PER_POW2] =
1489                 (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2]
1490                                    - sizeof(union overhead));
1491             nextf[7*BUCKETS_PER_POW2]->ov_next = n_op;
1492         }
1493 #endif /* !PACK_MALLOC */
1494 }
1495
1496 Free_t
1497 Perl_mfree(void *mp)
1498 {
1499         register MEM_SIZE size;
1500         register union overhead *ovp;
1501         char *cp = (char*)mp;
1502 #ifdef PACK_MALLOC
1503         u_char bucket;
1504 #endif
1505
1506         DEBUG_m(PerlIO_printf(Perl_debug_log,
1507                               "0x%"UVxf": (%05lu) free\n",
1508                               PTR2UV(cp), (unsigned long)(PL_an++)));
1509
1510         if (cp == NULL)
1511                 return;
1512         ovp = (union overhead *)((caddr_t)cp
1513                                 - sizeof (union overhead) * CHUNK_SHIFT);
1514 #ifdef PACK_MALLOC
1515         bucket = OV_INDEX(ovp);
1516 #endif
1517 #ifdef IGNORE_SMALL_BAD_FREE
1518         if ((bucket >= FIRST_BUCKET_WITH_CHECK)
1519             && (OV_MAGIC(ovp, bucket) != MAGIC))
1520 #else
1521         if (OV_MAGIC(ovp, bucket) != MAGIC)
1522 #endif
1523             {
1524                 static int bad_free_warn = -1;
1525                 if (bad_free_warn == -1) {
1526                     dTHX;
1527                     char *pbf = PerlEnv_getenv("PERL_BADFREE");
1528                     bad_free_warn = (pbf) ? atoi(pbf) : 1;
1529                 }
1530                 if (!bad_free_warn)
1531                     return;
1532 #ifdef RCHECK
1533 #ifdef PERL_CORE
1534                 {
1535                     dTHX;
1536                     if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
1537                         Perl_warner(aTHX_ WARN_MALLOC, "%s free() ignored",
1538                                     ovp->ov_rmagic == RMAGIC - 1 ?
1539                                     "Duplicate" : "Bad");
1540                 }
1541 #else
1542                 warn("%s free() ignored",
1543                     ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
1544 #endif
1545 #else
1546 #ifdef PERL_CORE
1547                 {
1548                     dTHX;
1549                     if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
1550                         Perl_warner(aTHX_ WARN_MALLOC, "%s", "Bad free() ignored");
1551                 }
1552 #else
1553                 warn("%s", "Bad free() ignored");
1554 #endif
1555 #endif
1556                 return;                         /* sanity */
1557             }
1558 #ifdef RCHECK
1559         ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
1560         if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
1561             int i;
1562             MEM_SIZE nbytes = ovp->ov_size + 1;
1563
1564             if ((i = nbytes & 3)) {
1565                 i = 4 - i;
1566                 while (i--) {
1567                     ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
1568                            == RMAGIC_C, "chunk's tail overwrite");
1569                 }
1570             }
1571             nbytes = (nbytes + 3) &~ 3;
1572             ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite");
1573         }
1574         ovp->ov_rmagic = RMAGIC - 1;
1575 #endif
1576         ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
1577         size = OV_INDEX(ovp);
1578
1579         MALLOC_LOCK;
1580         ovp->ov_next = nextf[size];
1581         nextf[size] = ovp;
1582         MALLOC_UNLOCK;
1583 }
1584
1585 /* There is no need to do any locking in realloc (with an exception of
1586    trying to grow in place if we are at the end of the chain).
1587    If somebody calls us from a different thread with the same address,
1588    we are sole anyway.  */
1589
1590 Malloc_t
1591 Perl_realloc(void *mp, size_t nbytes)
1592 {
1593         register MEM_SIZE onb;
1594         union overhead *ovp;
1595         char *res;
1596         int prev_bucket;
1597         register int bucket;
1598         int incr;               /* 1 if does not fit, -1 if "easily" fits in a
1599                                    smaller bucket, otherwise 0.  */
1600         char *cp = (char*)mp;
1601
1602 #if defined(DEBUGGING) || !defined(PERL_CORE)
1603         MEM_SIZE size = nbytes;
1604
1605         if ((long)nbytes < 0)
1606             croak("%s", "panic: realloc");
1607 #endif
1608
1609         BARK_64K_LIMIT("Reallocation",nbytes,size);
1610         if (!cp)
1611                 return Perl_malloc(nbytes);
1612
1613         ovp = (union overhead *)((caddr_t)cp
1614                                 - sizeof (union overhead) * CHUNK_SHIFT);
1615         bucket = OV_INDEX(ovp);
1616
1617 #ifdef IGNORE_SMALL_BAD_FREE
1618         if ((bucket >= FIRST_BUCKET_WITH_CHECK)
1619             && (OV_MAGIC(ovp, bucket) != MAGIC))
1620 #else
1621         if (OV_MAGIC(ovp, bucket) != MAGIC)
1622 #endif
1623             {
1624                 static int bad_free_warn = -1;
1625                 if (bad_free_warn == -1) {
1626                     dTHX;
1627                     char *pbf = PerlEnv_getenv("PERL_BADFREE");
1628                     bad_free_warn = (pbf) ? atoi(pbf) : 1;
1629                 }
1630                 if (!bad_free_warn)
1631                     return Nullch;
1632 #ifdef RCHECK
1633 #ifdef PERL_CORE
1634                 {
1635                     dTHX;
1636                     if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
1637                         Perl_warner(aTHX_ WARN_MALLOC, "%srealloc() %signored",
1638                                     (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
1639                                     ovp->ov_rmagic == RMAGIC - 1
1640                                     ? "of freed memory " : "");
1641                 }
1642 #else
1643                 warn("%srealloc() %signored",
1644                     (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
1645                      ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
1646 #endif
1647 #else
1648 #ifdef PERL_CORE
1649                 {
1650                     dTHX;
1651                     if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
1652                         Perl_warner(aTHX_ WARN_MALLOC, "%s",
1653                                     "Bad realloc() ignored");
1654                 }
1655 #else
1656                 warn("%s", "Bad realloc() ignored");
1657 #endif
1658 #endif
1659                 return Nullch;                  /* sanity */
1660             }
1661
1662         onb = BUCKET_SIZE_REAL(bucket);
1663         /*
1664          *  avoid the copy if same size block.
1665          *  We are not agressive with boundary cases. Note that it might
1666          *  (for a small number of cases) give false negative if
1667          *  both new size and old one are in the bucket for
1668          *  FIRST_BIG_POW2, but the new one is near the lower end.
1669          *
1670          *  We do not try to go to 1.5 times smaller bucket so far.
1671          */
1672         if (nbytes > onb) incr = 1;
1673         else {
1674 #ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING
1675             if ( /* This is a little bit pessimal if PACK_MALLOC: */
1676                 nbytes > ( (onb >> 1) - M_OVERHEAD )
1677 #  ifdef TWO_POT_OPTIMIZE
1678                 || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND )
1679 #  endif
1680                 )
1681 #else  /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1682                 prev_bucket = ( (bucket > MAX_PACKED + 1)
1683                                 ? bucket - BUCKETS_PER_POW2
1684                                 : bucket - 1);
1685              if (nbytes > BUCKET_SIZE_REAL(prev_bucket))
1686 #endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1687                  incr = 0;
1688              else incr = -1;
1689         }
1690 #ifdef STRESS_REALLOC
1691         goto hard_way;
1692 #endif
1693         if (incr == 0) {
1694           inplace_label:
1695 #ifdef RCHECK
1696                 /*
1697                  * Record new allocated size of block and
1698                  * bound space with magic numbers.
1699                  */
1700                 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
1701                        int i, nb = ovp->ov_size + 1;
1702
1703                        if ((i = nb & 3)) {
1704                            i = 4 - i;
1705                            while (i--) {
1706                                ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite");
1707                            }
1708                        }
1709                        nb = (nb + 3) &~ 3;
1710                        ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite");
1711                         /*
1712                          * Convert amount of memory requested into
1713                          * closest block size stored in hash buckets
1714                          * which satisfies request.  Account for
1715                          * space used per block for accounting.
1716                          */
1717                         nbytes += M_OVERHEAD;
1718                         ovp->ov_size = nbytes - 1;
1719                         if ((i = nbytes & 3)) {
1720                             i = 4 - i;
1721                             while (i--)
1722                                 *((char *)((caddr_t)ovp + nbytes - RSLOP + i))
1723                                     = RMAGIC_C;
1724                         }
1725                         nbytes = (nbytes + 3) &~ 3;
1726                         *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
1727                 }
1728 #endif
1729                 res = cp;
1730                 DEBUG_m(PerlIO_printf(Perl_debug_log,
1731                               "0x%"UVxf": (%05lu) realloc %ld bytes inplace\n",
1732                               PTR2UV(res),(unsigned long)(PL_an++),
1733                               (long)size));
1734         } else if (incr == 1 && (cp - M_OVERHEAD == last_op)
1735                    && (onb > (1 << LOG_OF_MIN_ARENA))) {
1736             MEM_SIZE require, newarena = nbytes, pow;
1737             int shiftr;
1738
1739             POW2_OPTIMIZE_ADJUST(newarena);
1740             newarena = newarena + M_OVERHEAD;
1741             /* newarena = (newarena + 3) &~ 3; */
1742             shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA;
1743             pow = LOG_OF_MIN_ARENA + 1;
1744             /* apart from this loop, this is O(1) */
1745             while (shiftr >>= 1)
1746                 pow++;
1747             newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2);
1748             require = newarena - onb - M_OVERHEAD;
1749
1750             MALLOC_LOCK;
1751             if (cp - M_OVERHEAD == last_op /* We *still* are the last chunk */
1752                 && getpages_adjacent(require)) {
1753 #ifdef DEBUGGING_MSTATS
1754                 nmalloc[bucket]--;
1755                 nmalloc[pow * BUCKETS_PER_POW2]++;
1756 #endif
1757                 *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
1758                 MALLOC_UNLOCK;
1759                 goto inplace_label;
1760             } else {
1761                 MALLOC_UNLOCK;
1762                 goto hard_way;
1763             }
1764         } else {
1765           hard_way:
1766             DEBUG_m(PerlIO_printf(Perl_debug_log,
1767                               "0x%"UVxf": (%05lu) realloc %ld bytes the hard way\n",
1768                               PTR2UV(cp),(unsigned long)(PL_an++),
1769                               (long)size));
1770             if ((res = (char*)Perl_malloc(nbytes)) == NULL)
1771                 return (NULL);
1772             if (cp != res)                      /* common optimization */
1773                 Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
1774             Perl_mfree(cp);
1775         }
1776         return ((Malloc_t)res);
1777 }
1778
1779 Malloc_t
1780 Perl_calloc(register size_t elements, register size_t size)
1781 {
1782     long sz = elements * size;
1783     Malloc_t p = Perl_malloc(sz);
1784
1785     if (p) {
1786         memset((void*)p, 0, sz);
1787     }
1788     return p;
1789 }
1790
1791 char *
1792 Perl_strdup(const char *s)
1793 {
1794     MEM_SIZE l = strlen(s);
1795     char *s1 = (char *)Perl_malloc(l+1);
1796
1797     Copy(s, s1, (MEM_SIZE)(l+1), char);
1798     return s1;
1799 }
1800
1801 #ifdef PERL_CORE
1802 int
1803 Perl_putenv(char *a)
1804 {
1805     /* Sometimes system's putenv conflicts with my_setenv() - this is system
1806        malloc vs Perl's free(). */
1807   dTHX;
1808   char *var;
1809   char *val = a;
1810   MEM_SIZE l;
1811   char buf[80];
1812
1813   while (*val && *val != '=')
1814       val++;
1815   if (!*val)
1816       return -1;
1817   l = val - a;
1818   if (l < sizeof(buf))
1819       var = buf;
1820   else
1821       var = Perl_malloc(l + 1);
1822   Copy(a, var, l, char);
1823   var[l + 1] = 0;
1824   my_setenv(var, val+1);
1825   if (var != buf)
1826       Perl_mfree(var);
1827   return 0;
1828 }
1829 #  endif
1830
1831 MEM_SIZE
1832 Perl_malloced_size(void *p)
1833 {
1834     union overhead *ovp = (union overhead *)
1835         ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
1836     int bucket = OV_INDEX(ovp);
1837 #ifdef RCHECK
1838     /* The caller wants to have a complete control over the chunk,
1839        disable the memory checking inside the chunk.  */
1840     if (bucket <= MAX_SHORT_BUCKET) {
1841         MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
1842         ovp->ov_size = size + M_OVERHEAD - 1;
1843         *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC;
1844     }
1845 #endif
1846     return BUCKET_SIZE_REAL(bucket);
1847 }
1848
1849 #  ifdef BUCKETS_ROOT2
1850 #    define MIN_EVEN_REPORT 6
1851 #  else
1852 #    define MIN_EVEN_REPORT MIN_BUCKET
1853 #  endif
1854
1855 int
1856 Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
1857 {
1858 #ifdef DEBUGGING_MSTATS
1859         register int i, j;
1860         register union overhead *p;
1861         struct chunk_chain_s* nextchain;
1862
1863         buf->topbucket = buf->topbucket_ev = buf->topbucket_odd
1864             = buf->totfree = buf->total = buf->total_chain = 0;
1865
1866         buf->minbucket = MIN_BUCKET;
1867         MALLOC_LOCK;
1868         for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
1869                 for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
1870                         ;
1871                 if (i < buflen) {
1872                     buf->nfree[i] = j;
1873                     buf->ntotal[i] = nmalloc[i];
1874                 }
1875                 buf->totfree += j * BUCKET_SIZE_REAL(i);
1876                 buf->total += nmalloc[i] * BUCKET_SIZE_REAL(i);
1877                 if (nmalloc[i]) {
1878                     i % 2 ? (buf->topbucket_odd = i) : (buf->topbucket_ev = i);
1879                     buf->topbucket = i;
1880                 }
1881         }
1882         nextchain = chunk_chain;
1883         while (nextchain) {
1884             buf->total_chain += nextchain->size;
1885             nextchain = nextchain->next;
1886         }
1887         buf->total_sbrk = goodsbrk + sbrk_slack;
1888         buf->sbrks = sbrks;
1889         buf->sbrk_good = sbrk_good;
1890         buf->sbrk_slack = sbrk_slack;
1891         buf->start_slack = start_slack;
1892         buf->sbrked_remains = sbrked_remains;
1893         MALLOC_UNLOCK;
1894         if (level) {
1895             for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
1896                 if (i >= buflen)
1897                     break;
1898                 buf->bucket_mem_size[i] = BUCKET_SIZE(i);
1899                 buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i);
1900             }
1901         }
1902 #endif  /* defined DEBUGGING_MSTATS */
1903         return 0;               /* XXX unused */
1904 }
1905 /*
1906  * mstats - print out statistics about malloc
1907  *
1908  * Prints two lines of numbers, one showing the length of the free list
1909  * for each size category, the second showing the number of mallocs -
1910  * frees for each size category.
1911  */
1912 void
1913 Perl_dump_mstats(pTHX_ char *s)
1914 {
1915 #ifdef DEBUGGING_MSTATS
1916         register int i, j;
1917         register union overhead *p;
1918         perl_mstats_t buffer;
1919         unsigned long nf[NBUCKETS];
1920         unsigned long nt[NBUCKETS];
1921         struct chunk_chain_s* nextchain;
1922
1923         buffer.nfree  = nf;
1924         buffer.ntotal = nt;
1925         get_mstats(&buffer, NBUCKETS, 0);
1926
1927         if (s)
1928             PerlIO_printf(Perl_error_log,
1929                           "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n",
1930                           s,
1931                           (long)BUCKET_SIZE_REAL(MIN_BUCKET),
1932                           (long)BUCKET_SIZE(MIN_BUCKET),
1933                           (long)BUCKET_SIZE_REAL(buffer.topbucket),
1934                           (long)BUCKET_SIZE(buffer.topbucket));
1935         PerlIO_printf(Perl_error_log, "%8ld free:", buffer.totfree);
1936         for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
1937                 PerlIO_printf(Perl_error_log,
1938                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1939                                ? " %5d"
1940                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1941                               buffer.nfree[i]);
1942         }
1943 #ifdef BUCKETS_ROOT2
1944         PerlIO_printf(Perl_error_log, "\n\t   ");
1945         for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) {
1946                 PerlIO_printf(Perl_error_log,
1947                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1948                                ? " %5d"
1949                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1950                               buffer.nfree[i]);
1951         }
1952 #endif
1953         PerlIO_printf(Perl_error_log, "\n%8ld used:", buffer.total - buffer.totfree);
1954         for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
1955                 PerlIO_printf(Perl_error_log,
1956                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1957                                ? " %5d"
1958                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1959                               buffer.ntotal[i] - buffer.nfree[i]);
1960         }
1961 #ifdef BUCKETS_ROOT2
1962         PerlIO_printf(Perl_error_log, "\n\t   ");
1963         for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) {
1964                 PerlIO_printf(Perl_error_log,
1965                               ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1966                                ? " %5d"
1967                                : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1968                               buffer.ntotal[i] - buffer.nfree[i]);
1969         }
1970 #endif
1971         PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %ld/%ld:%ld. Odd ends: pad+heads+chain+tail: %ld+%ld+%ld+%ld.\n",
1972                       buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good,
1973                       buffer.sbrk_slack, buffer.start_slack,
1974                       buffer.total_chain, buffer.sbrked_remains);
1975 #endif /* DEBUGGING_MSTATS */
1976 }
1977 #endif /* lint */
1978
1979 #ifdef USE_PERL_SBRK
1980
1981 #   if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__) || defined(PURIFY)
1982 #      define PERL_SBRK_VIA_MALLOC
1983 /*
1984  * MachTen's malloc() returns a buffer aligned on a two-byte boundary.
1985  * While this is adequate, it may slow down access to longer data
1986  * types by forcing multiple memory accesses.  It also causes
1987  * complaints when RCHECK is in force.  So we allocate six bytes
1988  * more than we need to, and return an address rounded up to an
1989  * eight-byte boundary.
1990  *
1991  * 980701 Dominic Dunlop <domo@computer.org>
1992  */
1993 #      define SYSTEM_ALLOC_ALIGNMENT 2
1994 #   endif
1995
1996 #   ifdef PERL_SBRK_VIA_MALLOC
1997
1998 /* it may seem schizophrenic to use perl's malloc and let it call system */
1999 /* malloc, the reason for that is only the 3.2 version of the OS that had */
2000 /* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
2001 /* end to the cores */
2002
2003 #      ifndef SYSTEM_ALLOC
2004 #         define SYSTEM_ALLOC(a) malloc(a)
2005 #      endif
2006 #      ifndef SYSTEM_ALLOC_ALIGNMENT
2007 #         define SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES
2008 #      endif
2009
2010 #   endif  /* PERL_SBRK_VIA_MALLOC */
2011
2012 static IV Perl_sbrk_oldchunk;
2013 static long Perl_sbrk_oldsize;
2014
2015 #   define PERLSBRK_32_K (1<<15)
2016 #   define PERLSBRK_64_K (1<<16)
2017
2018 Malloc_t
2019 Perl_sbrk(int size)
2020 {
2021     IV got;
2022     int small, reqsize;
2023
2024     if (!size) return 0;
2025 #ifdef PERL_CORE
2026     reqsize = size; /* just for the DEBUG_m statement */
2027 #endif
2028 #ifdef PACK_MALLOC
2029     size = (size + 0x7ff) & ~0x7ff;
2030 #endif
2031     if (size <= Perl_sbrk_oldsize) {
2032         got = Perl_sbrk_oldchunk;
2033         Perl_sbrk_oldchunk += size;
2034         Perl_sbrk_oldsize -= size;
2035     } else {
2036       if (size >= PERLSBRK_32_K) {
2037         small = 0;
2038       } else {
2039         size = PERLSBRK_64_K;
2040         small = 1;
2041       }
2042 #  if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
2043       size += NEEDED_ALIGNMENT - SYSTEM_ALLOC_ALIGNMENT;
2044 #  endif
2045       got = (IV)SYSTEM_ALLOC(size);
2046 #  if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
2047       got = (got + NEEDED_ALIGNMENT - 1) & ~(NEEDED_ALIGNMENT - 1);
2048 #  endif
2049       if (small) {
2050         /* Chunk is small, register the rest for future allocs. */
2051         Perl_sbrk_oldchunk = got + reqsize;
2052         Perl_sbrk_oldsize = size - reqsize;
2053       }
2054     }
2055
2056     DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%"UVxf"\n",
2057                     size, reqsize, Perl_sbrk_oldsize, PTR2UV(got)));
2058
2059     return (void *)got;
2060 }
2061
2062 #endif /* ! defined USE_PERL_SBRK */