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