malloc.c

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