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