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