6 * "'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'"
10 Here are some notes on configuring Perl's malloc. (For non-perl
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.
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).
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.
30 # Read configuration settings from malloc_cfg.h
31 HAVE_MALLOC_CFG_H undef
33 # Enable code for an emergency memory pool in $^M. See perlvar.pod
34 # for a description of $^M.
35 PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && (PERL_CORE || !NO_MALLOC_DYNAMIC_CFG))
37 # Enable code for printing memory statistics.
38 DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE)
40 # Move allocation info for small buckets into separate areas.
41 # Memory optimization (especially for small allocations, of the
42 # less than 64 bytes). Since perl usually makes a large number
43 # of small allocations, this is usually a win.
44 PACK_MALLOC (!PLAIN_MALLOC && !RCHECK)
46 # Add one page to big powers of two when calculating bucket size.
47 # This is targeted at big allocations, as are common in image
49 TWO_POT_OPTIMIZE !PLAIN_MALLOC
51 # Use intermediate bucket sizes between powers-of-two. This is
52 # generally a memory optimization, and a (small) speed pessimization.
53 BUCKETS_ROOT2 !NO_FANCY_MALLOC
55 # Do not check small deallocations for bad free(). Memory
56 # and speed optimization, error reporting pessimization.
57 IGNORE_SMALL_BAD_FREE (!NO_FANCY_MALLOC && !RCHECK)
59 # Use table lookup to decide in which bucket a given allocation will go.
60 SMALL_BUCKET_VIA_TABLE !NO_FANCY_MALLOC
62 # Use a perl-defined sbrk() instead of the (presumably broken or
63 # missing) system-supplied sbrk().
66 # Use system malloc() (or calloc() etc.) to emulate sbrk(). Normally
67 # only used with broken sbrk()s.
68 PERL_SBRK_VIA_MALLOC undef
70 # Which allocator to use if PERL_SBRK_VIA_MALLOC
71 SYSTEM_ALLOC(a) malloc(a)
73 # Minimal alignment (in bytes, should be a power of 2) of SYSTEM_ALLOC
74 SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES
76 # Disable memory overwrite checking with DEBUGGING. Memory and speed
77 # optimization, error reporting pessimization.
80 # Enable memory overwrite checking with DEBUGGING. Memory and speed
81 # pessimization, error reporting optimization
82 RCHECK (DEBUGGING && !NO_RCHECK)
84 # Do not overwrite uninit areas with DEBUGGING. Speed
85 # optimization, error reporting pessimization
88 # Overwrite uninit areas with DEBUGGING. Speed
89 # pessimization, error reporting optimization
90 MALLOC_FILL (DEBUGGING && !NO_RCHECK && !NO_MFILL)
92 # Do not check overwritten uninit areas with DEBUGGING. Speed
93 # optimization, error reporting pessimization
96 # Check overwritten uninit areas with DEBUGGING. Speed
97 # pessimization, error reporting optimization
98 MALLOC_FILL_CHECK (DEBUGGING && !NO_RCHECK && !NO_FILL_CHECK)
100 # Failed allocations bigger than this size croak (if
101 # PERL_EMERGENCY_SBRK is enabled) without touching $^M. See
102 # perlvar.pod for a description of $^M.
103 BIG_SIZE (1<<16) # 64K
105 # Starting from this power of two, add an extra page to the
106 # size of the bucket. This enables optimized allocations of sizes
107 # close to powers of 2. Note that the value is indexed at 0.
108 FIRST_BIG_POW2 15 # 32K, 16K is used too often
110 # Estimate of minimal memory footprint. malloc uses this value to
111 # request the most reasonable largest blocks of memory from the system.
114 # Round up sbrk()s to multiples of this.
117 # Round up sbrk()s to multiples of this percent of footprint.
120 # Round up sbrk()s to multiples of this multiple of 1/1000 of footprint.
121 MIN_SBRK_FRAC1000 (10 * MIN_SBRK_FRAC)
123 # Add this much memory to big powers of two to get the bucket size.
126 # This many sbrk() discontinuities should be tolerated even
127 # from the start without deciding that sbrk() is usually
129 SBRK_ALLOW_FAILURES 3
131 # This many continuous sbrk()s compensate for one discontinuous one.
132 SBRK_FAILURE_PRICE 50
134 # Some configurations may ask for 12-byte-or-so allocations which
135 # require 8-byte alignment (?!). In such situation one needs to
136 # define this to disable 12-byte bucket (will increase memory footprint)
137 STRICT_ALIGNMENT undef
139 # Do not allow configuration of runtime options at runtime
140 NO_MALLOC_DYNAMIC_CFG undef
142 # Do not allow configuration of runtime options via $ENV{PERL_MALLOC_OPT}
143 NO_PERL_MALLOC_ENV undef
145 [The variable consists of ;-separated parts of the form CODE=VALUE
146 with 1-character codes F, M, f, A, P, G, d, a, c for runtime
147 configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000,
148 SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness,
149 filldead, fillalive, fillcheck. The last 3 are for DEBUGGING
150 build, and allow switching the tests for free()ed memory read,
151 uninit memory reads, and free()ed memory write.]
153 This implementation assumes that calling PerlIO_printf() does not
154 result in any memory allocation calls (used during a panic).
159 If used outside of Perl environment, it may be useful to redefine
160 the following macros (listed below with defaults):
162 # Type of address returned by allocation functions
165 # Type of size argument for allocation functions
166 MEM_SIZE unsigned long
171 # Maximal value in LONG
174 # Unsigned integer type big enough to keep a pointer
177 # Signed integer of the same sizeof() as UV
180 # Type of pointer with 1-byte granularity
183 # Type returned by free()
186 # Conversion of pointer to integer
187 PTR2UV(ptr) ((UV)(ptr))
189 # Conversion of integer to pointer
190 INT2PTR(type, i) ((type)(i))
192 # printf()-%-Conversion of UV to pointer
195 # printf()-%-Conversion of UV to hex pointer
201 # Very fatal condition reporting function (cannot call any )
202 fatalcroak(arg) write(2,arg,strlen(arg)) + exit(2)
204 # Fatal error reporting function
205 croak(format, arg) warn(idem) + exit(1)
207 # Fatal error reporting function
208 croak2(format, arg1, arg2) warn2(idem) + exit(1)
210 # Error reporting function
211 warn(format, arg) fprintf(stderr, idem)
213 # Error reporting function
214 warn2(format, arg1, arg2) fprintf(stderr, idem)
216 # Locking/unlocking for MT operation
217 MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex)
218 MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex)
220 # Locking/unlocking mutex for MT operation
225 #ifdef HAVE_MALLOC_CFG_H
226 # include "malloc_cfg.h"
229 #ifndef NO_FANCY_MALLOC
230 # ifndef SMALL_BUCKET_VIA_TABLE
231 # define SMALL_BUCKET_VIA_TABLE
233 # ifndef BUCKETS_ROOT2
234 # define BUCKETS_ROOT2
236 # ifndef IGNORE_SMALL_BAD_FREE
237 # define IGNORE_SMALL_BAD_FREE
241 #ifndef PLAIN_MALLOC /* Bulk enable features */
245 # ifndef TWO_POT_OPTIMIZE
246 # define TWO_POT_OPTIMIZE
248 # if (defined(PERL_CORE) || !defined(NO_MALLOC_DYNAMIC_CFG)) && !defined(PERL_EMERGENCY_SBRK)
249 # define PERL_EMERGENCY_SBRK
251 # if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
252 # define DEBUGGING_MSTATS
256 #define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
257 #define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
259 #if !(defined(I286) || defined(atarist) || defined(__MINT__))
260 /* take 2k unless the block is bigger than that */
261 # define LOG_OF_MIN_ARENA 11
263 /* take 16k unless the block is bigger than that
264 (80286s like large segments!), probably good on the atari too */
265 # define LOG_OF_MIN_ARENA 14
269 # if defined(DEBUGGING) && !defined(NO_RCHECK)
272 # if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_MFILL) && !defined(MALLOC_FILL)
275 # if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_FILL_CHECK) && !defined(MALLOC_FILL_CHECK)
276 # define MALLOC_FILL_CHECK
278 # if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE)
279 # undef IGNORE_SMALL_BAD_FREE
282 * malloc.c (Caltech) 2/21/82
283 * Chris Kingsley, kingsley@cit-20.
285 * This is a very fast storage allocator. It allocates blocks of a small
286 * number of different sizes, and keeps free lists of each size. Blocks that
287 * don't exactly fit are passed up to the next larger size. In this
288 * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
289 * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
290 * This is designed for use in a program that uses vast quantities of memory,
291 * but bombs when it runs out.
293 * Modifications Copyright Ilya Zakharevich 1996-99.
295 * Still very quick, but much more thrifty. (Std config is 10% slower
296 * than it was, and takes 67% of old heap size for typical usage.)
298 * Allocations of small blocks are now table-driven to many different
299 * buckets. Sizes of really big buckets are increased to accomodata
300 * common size=power-of-2 blocks. Running-out-of-memory is made into
301 * an exception. Deeply configurable and thread-safe.
307 # define PERL_IN_MALLOC_C
309 # if defined(PERL_IMPLICIT_CONTEXT)
310 # define croak Perl_croak_nocontext
311 # define croak2 Perl_croak_nocontext
312 # define warn Perl_warn_nocontext
313 # define warn2 Perl_warn_nocontext
315 # define croak2 croak
318 # if defined(USE_5005THREADS) || defined(USE_ITHREADS)
319 # define PERL_MAYBE_ALIVE PL_thr_key
321 # define PERL_MAYBE_ALIVE 1
325 # include "../EXTERN.h"
326 # include "../perl.h"
336 # define Malloc_t void *
342 # define MEM_SIZE unsigned long
345 # define LONG_MAX 0x7FFFFFFF
348 # define UV unsigned long
354 # define caddr_t char *
359 # define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
360 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
361 # define PerlEnv_getenv getenv
362 # define PerlIO_printf fprintf
363 # define PerlIO_stderr() stderr
364 # define PerlIO_puts(f,s) fputs(s,f)
366 # define INT2PTR(t,i) ((t)(i))
369 # define PTR2UV(p) ((UV)(p))
380 # ifndef MEM_ALIGNBYTES
381 # define MEM_ALIGNBYTES 4
384 # ifndef croak /* make depend */
385 # define croak(mess, arg) (warn((mess), (arg)), exit(1))
387 # ifndef croak2 /* make depend */
388 # define croak2(mess, arg1, arg2) (warn2((mess), (arg1), (arg2)), exit(1))
391 # define warn(mess, arg) fprintf(stderr, (mess), (arg))
394 # define warn2(mess, arg1, arg2) fprintf(stderr, (mess), (arg1), (arg2))
407 # define dTHX extern int Perl___notused PERL_UNUSED_DECL
409 # define dTHX extern int Perl___notused
411 # define WITH_THX(s) s
413 # ifndef PERL_GET_INTERP
414 # define PERL_GET_INTERP PL_curinterp
416 # define PERL_MAYBE_ALIVE 1
418 # define Perl_malloc malloc
421 # define Perl_mfree free
423 # ifndef Perl_realloc
424 # define Perl_realloc realloc
427 # define Perl_calloc calloc
430 # define Perl_strdup strdup
432 #endif /* defined PERL_CORE */
435 # define MUTEX_LOCK(l)
439 # define MUTEX_UNLOCK(l)
443 # define MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex)
446 #ifndef MALLOC_UNLOCK
447 # define MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex)
450 # ifndef fatalcroak /* make depend */
451 # define fatalcroak(mess) (write(2, (mess), strlen(mess)), exit(2))
456 # define DEBUG_m(a) \
458 if (PERL_MAYBE_ALIVE && PERL_GET_THX) { \
460 if (DEBUG_m_TEST) { \
461 PL_debug &= ~DEBUG_m_FLAG; \
463 PL_debug |= DEBUG_m_FLAG; \
469 #ifdef PERL_IMPLICIT_CONTEXT
470 # define PERL_IS_ALIVE aTHX
472 # define PERL_IS_ALIVE TRUE
479 * The memory is broken into "blocks" which occupy multiples of 2K (and
480 * generally speaking, have size "close" to a power of 2). The addresses
481 * of such *unused* blocks are kept in nextf[i] with big enough i. (nextf
482 * is an array of linked lists.) (Addresses of used blocks are not known.)
484 * Moreover, since the algorithm may try to "bite" smaller blocks out
485 * of unused bigger ones, there are also regions of "irregular" size,
486 * managed separately, by a linked list chunk_chain.
488 * The third type of storage is the sbrk()ed-but-not-yet-used space, its
489 * end and size are kept in last_sbrk_top and sbrked_remains.
491 * Growing blocks "in place":
492 * ~~~~~~~~~~~~~~~~~~~~~~~~~
493 * The address of the block with the greatest address is kept in last_op
494 * (if not known, last_op is 0). If it is known that the memory above
495 * last_op is not continuous, or contains a chunk from chunk_chain,
496 * last_op is set to 0.
498 * The chunk with address last_op may be grown by expanding into
499 * sbrk()ed-but-not-yet-used space, or trying to sbrk() more continuous
502 * Management of last_op:
503 * ~~~~~~~~~~~~~~~~~~~~~
505 * free() never changes the boundaries of blocks, so is not relevant.
507 * The only way realloc() may change the boundaries of blocks is if it
508 * grows a block "in place". However, in the case of success such a
509 * chunk is automatically last_op, and it remains last_op. In the case
510 * of failure getpages_adjacent() clears last_op.
512 * malloc() may change blocks by calling morecore() only.
514 * morecore() may create new blocks by:
515 * a) biting pieces from chunk_chain (cannot create one above last_op);
516 * b) biting a piece from an unused block (if block was last_op, this
517 * may create a chunk from chain above last_op, thus last_op is
518 * invalidated in such a case).
519 * c) biting of sbrk()ed-but-not-yet-used space. This creates
520 * a block which is last_op.
521 * d) Allocating new pages by calling getpages();
523 * getpages() creates a new block. It marks last_op at the bottom of
524 * the chunk of memory it returns.
526 * Active pages footprint:
527 * ~~~~~~~~~~~~~~~~~~~~~~
528 * Note that we do not need to traverse the lists in nextf[i], just take
529 * the first element of this list. However, we *need* to traverse the
530 * list in chunk_chain, but most the time it should be a very short one,
531 * so we do not step on a lot of pages we are not going to use.
535 * get_from_bigger_buckets(): forget to increment price => Quite
539 /* I don't much care whether these are defined in sys/types.h--LAW */
541 #define u_char unsigned char
542 #define u_int unsigned int
544 * I removed the definition of u_bigint which appeared to be u_bigint = UV
545 * u_bigint was only used in TWOK_MASKED and TWOK_SHIFT
546 * where I have used PTR2UV. RMB
548 #define u_short unsigned short
550 /* 286 and atarist like big chunks, which gives too much overhead. */
551 #if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC)
556 * The description below is applicable if PACK_MALLOC is not defined.
558 * The overhead on a block is at least 4 bytes. When free, this space
559 * contains a pointer to the next free block, and the bottom two bits must
560 * be zero. When in use, the first byte is set to MAGIC, and the second
561 * byte is the size index. The remaining bytes are for alignment.
562 * If range checking is enabled and the size of the block fits
563 * in two bytes, then the top two bytes hold the size of the requested block
564 * plus the range checking words, and the header word MINUS ONE.
567 union overhead *ov_next; /* when free */
568 #if MEM_ALIGNBYTES > 4
569 double strut; /* alignment problems */
570 # if MEM_ALIGNBYTES > 8
571 char sstrut[MEM_ALIGNBYTES]; /* for the sizing */
576 * Keep the ovu_index and ovu_magic in this order, having a char
577 * field first gives alignment indigestion in some systems, such as
580 u_char ovu_index; /* bucket # */
581 u_char ovu_magic; /* magic number */
583 /* Subtract one to fit into u_short for an extra bucket */
584 u_short ovu_size; /* block size (requested + overhead - 1) */
585 u_int ovu_rmagic; /* range magic number */
588 #define ov_magic ovu.ovu_magic
589 #define ov_index ovu.ovu_index
590 #define ov_size ovu.ovu_size
591 #define ov_rmagic ovu.ovu_rmagic
594 #define MAGIC 0xff /* magic # on accounting info */
595 #define RMAGIC 0x55555555 /* magic # on range info */
596 #define RMAGIC_C 0x55 /* magic # on range info */
599 # define RMAGIC_SZ sizeof (u_int) /* Overhead at end of bucket */
600 # ifdef TWO_POT_OPTIMIZE
601 # define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) /* size-1 fits in short */
603 # define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
609 #if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
610 # undef BUCKETS_ROOT2
614 # define BUCKET_TABLE_SHIFT 2
615 # define BUCKET_POW2_SHIFT 1
616 # define BUCKETS_PER_POW2 2
618 # define BUCKET_TABLE_SHIFT MIN_BUC_POW2
619 # define BUCKET_POW2_SHIFT 0
620 # define BUCKETS_PER_POW2 1
623 #if !defined(MEM_ALIGNBYTES) || ((MEM_ALIGNBYTES > 4) && !defined(STRICT_ALIGNMENT))
624 /* Figure out the alignment of void*. */
629 # define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
631 # define ALIGN_SMALL MEM_ALIGNBYTES
634 #define IF_ALIGN_8(yes,no) ((ALIGN_SMALL>4) ? (yes) : (no))
637 # define MAX_BUCKET_BY_TABLE 13
638 static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
640 0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
642 # define BUCKET_SIZE_NO_SURPLUS(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
643 # define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \
645 : ((1 << ((i) >> BUCKET_POW2_SHIFT)) \
647 + POW2_OPTIMIZE_SURPLUS(i)))
649 # define BUCKET_SIZE_NO_SURPLUS(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
650 # define BUCKET_SIZE(i) (BUCKET_SIZE_NO_SURPLUS(i) + POW2_OPTIMIZE_SURPLUS(i))
651 # define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i))
656 /* In this case there are several possible layout of arenas depending
657 * on the size. Arenas are of sizes multiple to 2K, 2K-aligned, and
658 * have a size close to a power of 2.
660 * Arenas of the size >= 4K keep one chunk only. Arenas of size 2K
661 * may keep one chunk or multiple chunks. Here are the possible
664 * # One chunk only, chunksize 2^k + SOMETHING - ALIGN, k >= 11
666 * INDEX MAGIC1 UNUSED CHUNK1
668 * # Multichunk with sanity checking and chunksize 2^k-ALIGN, k>7
670 * INDEX MAGIC1 MAGIC2 MAGIC3 UNUSED CHUNK1 CHUNK2 CHUNK3 ...
672 * # Multichunk with sanity checking and size 2^k-ALIGN, k=7
674 * INDEX MAGIC1 MAGIC2 MAGIC3 UNUSED CHUNK1 UNUSED CHUNK2 CHUNK3 ...
676 * # Multichunk with sanity checking and size up to 80
678 * INDEX UNUSED MAGIC1 UNUSED MAGIC2 UNUSED ... CHUNK1 CHUNK2 CHUNK3 ...
680 * # No sanity check (usually up to 48=byte-long buckets)
681 * INDEX UNUSED CHUNK1 CHUNK2 ...
683 * Above INDEX and MAGIC are one-byte-long. Sizes of UNUSED are
684 * appropriate to keep algorithms simple and memory aligned. INDEX
685 * encodes the size of the chunk, while MAGICn encodes state (used,
686 * free or non-managed-by-us-so-it-indicates-a-bug) of CHUNKn. MAGIC
687 * is used for sanity checking purposes only. SOMETHING is 0 or 4K
688 * (to make size of big CHUNK accomodate allocations for powers of two
691 * [There is no need to alignment between chunks, since C rules ensure
692 * that structs which need 2^k alignment have sizeof which is
693 * divisible by 2^k. Thus as far as the last chunk is aligned at the
694 * end of the arena, and 2K-alignment does not contradict things,
695 * everything is going to be OK for sizes of chunks 2^n and 2^n +
696 * 2^k. Say, 80-bit buckets will be 16-bit aligned, and as far as we
697 * put allocations for requests in 65..80 range, all is fine.
699 * Note, however, that standard malloc() puts more strict
700 * requirements than the above C rules. Moreover, our algorithms of
701 * realloc() may break this idyll, but we suppose that realloc() does
702 * need not change alignment.]
704 * Is very important to make calculation of the offset of MAGICm as
705 * quick as possible, since it is done on each malloc()/free(). In
706 * fact it is so quick that it has quite little effect on the speed of
707 * doing malloc()/free(). [By default] We forego such calculations
708 * for small chunks, but only to save extra 3% of memory, not because
709 * of speed considerations.
711 * Here is the algorithm [which is the same for all the allocations
712 * schemes above], see OV_MAGIC(block,bucket). Let OFFSETm be the
713 * offset of the CHUNKm from the start of ARENA. Then offset of
714 * MAGICm is (OFFSET1 >> SHIFT) + ADDOFFSET. Here SHIFT and ADDOFFSET
715 * are numbers which depend on the size of the chunks only.
717 * Let as check some sanity conditions. Numbers OFFSETm>>SHIFT are
718 * different for all the chunks in the arena if 2^SHIFT is not greater
719 * than size of the chunks in the arena. MAGIC1 will not overwrite
720 * INDEX provided ADDOFFSET is >0 if OFFSET1 < 2^SHIFT. MAGIClast
721 * will not overwrite CHUNK1 if OFFSET1 > (OFFSETlast >> SHIFT) +
724 * Make SHIFT the maximal possible (there is no point in making it
725 * smaller). Since OFFSETlast is 2K - CHUNKSIZE, above restrictions
726 * give restrictions on OFFSET1 and on ADDOFFSET.
728 * In particular, for chunks of size 2^k with k>=6 we can put
729 * ADDOFFSET to be from 0 to 2^k - 2^(11-k), and have
730 * OFFSET1==chunksize. For chunks of size 80 OFFSET1 of 2K%80=48 is
731 * large enough to have ADDOFFSET between 1 and 16 (similarly for 96,
732 * when ADDOFFSET should be 1). In particular, keeping MAGICs for
733 * these sizes gives no additional size penalty.
735 * However, for chunks of size 2^k with k<=5 this gives OFFSET1 >=
736 * ADDOFSET + 2^(11-k). Keeping ADDOFFSET 0 allows for 2^(11-k)-2^(11-2k)
737 * chunks per arena. This is smaller than 2^(11-k) - 1 which are
738 * needed if no MAGIC is kept. [In fact, having a negative ADDOFFSET
739 * would allow for slightly more buckets per arena for k=2,3.]
741 * Similarly, for chunks of size 3/2*2^k with k<=5 MAGICs would span
742 * the area up to 2^(11-k)+ADDOFFSET. For k=4 this give optimal
743 * ADDOFFSET as -7..0. For k=3 ADDOFFSET can go up to 4 (with tiny
744 * savings for negative ADDOFFSET). For k=5 ADDOFFSET can go -1..16
745 * (with no savings for negative values).
747 * In particular, keeping ADDOFFSET 0 for sizes of chunks up to 2^6
748 * leads to tiny pessimizations in case of sizes 4, 8, 12, 24, and
749 * leads to no contradictions except for size=80 (or 96.)
751 * However, it also makes sense to keep no magic for sizes 48 or less.
752 * This is what we do. In this case one needs ADDOFFSET>=1 also for
753 * chunksizes 12, 24, and 48, unless one gets one less chunk per
756 * The algo of OV_MAGIC(block,bucket) keeps ADDOFFSET 0 until
757 * chunksize of 64, then makes it 1.
759 * This allows for an additional optimization: the above scheme leads
760 * to giant overheads for sizes 128 or more (one whole chunk needs to
761 * be sacrifised to keep INDEX). Instead we use chunks not of size
762 * 2^k, but of size 2^k-ALIGN. If we pack these chunks at the end of
763 * the arena, then the beginnings are still in different 2^k-long
764 * sections of the arena if k>=7 for ALIGN==4, and k>=8 if ALIGN=8.
765 * Thus for k>7 the above algo of calculating the offset of the magic
766 * will still give different answers for different chunks. And to
767 * avoid the overrun of MAGIC1 into INDEX, one needs ADDOFFSET of >=1.
768 * In the case k=7 we just move the first chunk an extra ALIGN
769 * backward inside the ARENA (this is done once per arena lifetime,
770 * thus is not a big overhead). */
771 # define MAX_PACKED_POW2 6
772 # define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
773 # define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
774 # define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
775 # define TWOK_MASKED(x) (PTR2UV(x) & ~TWOK_MASK)
776 # define TWOK_SHIFT(x) (PTR2UV(x) & TWOK_MASK)
777 # define OV_INDEXp(block) (INT2PTR(u_char*,TWOK_MASKED(block)))
778 # define OV_INDEX(block) (*OV_INDEXp(block))
779 # define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \
780 (TWOK_SHIFT(block)>> \
781 (bucket>>BUCKET_POW2_SHIFT)) + \
782 (bucket >= MIN_NEEDS_SHIFT ? 1 : 0)))
783 /* A bucket can have a shift smaller than it size, we need to
784 shift its magic number so it will not overwrite index: */
785 # ifdef BUCKETS_ROOT2
786 # define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2 - 1) /* Shift 80 greater than chunk 64. */
788 # define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2) /* Shift 128 greater than chunk 32. */
790 # define CHUNK_SHIFT 0
792 /* Number of active buckets of given ordinal. */
793 #ifdef IGNORE_SMALL_BAD_FREE
794 #define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
795 # define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
796 ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE_NO_SURPLUS(bucket) \
799 # define N_BLKS(bucket) n_blks[bucket]
802 static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
804 # if BUCKETS_PER_POW2==1
806 (MIN_BUC_POW2==2 ? 384 : 0),
807 224, 120, 62, 31, 16, 8, 4, 2
810 (MIN_BUC_POW2==2 ? 384 : 0), (MIN_BUC_POW2==2 ? 384 : 0), /* 4, 4 */
811 224, 149, 120, 80, 62, 41, 31, 25, 16, 16, 8, 8, 4, 4, 2, 2
815 /* Shift of the first bucket with the given ordinal inside 2K chunk. */
816 #ifdef IGNORE_SMALL_BAD_FREE
817 # define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
818 ? ((1<<LOG_OF_MIN_ARENA) \
819 - BUCKET_SIZE_NO_SURPLUS(bucket) * N_BLKS(bucket)) \
822 # define BLK_SHIFT(bucket) blk_shift[bucket]
825 static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
827 # if BUCKETS_PER_POW2==1
829 (MIN_BUC_POW2==2 ? 512 : 0),
830 256, 128, 64, 64, /* 8 to 64 */
831 16*sizeof(union overhead),
832 8*sizeof(union overhead),
833 4*sizeof(union overhead),
834 2*sizeof(union overhead),
837 (MIN_BUC_POW2==2 ? 512 : 0), (MIN_BUC_POW2==2 ? 512 : 0),
838 256, 260, 128, 128, 64, 80, 64, 48, /* 8 to 96 */
839 16*sizeof(union overhead), 16*sizeof(union overhead),
840 8*sizeof(union overhead), 8*sizeof(union overhead),
841 4*sizeof(union overhead), 4*sizeof(union overhead),
842 2*sizeof(union overhead), 2*sizeof(union overhead),
846 # define NEEDED_ALIGNMENT 0x800 /* 2k boundaries */
847 # define WANTED_ALIGNMENT 0x800 /* 2k boundaries */
849 #else /* !PACK_MALLOC */
851 # define OV_MAGIC(block,bucket) (block)->ov_magic
852 # define OV_INDEX(block) (block)->ov_index
853 # define CHUNK_SHIFT 1
854 # define MAX_PACKED -1
855 # define NEEDED_ALIGNMENT MEM_ALIGNBYTES
856 # define WANTED_ALIGNMENT 0x400 /* 1k boundaries */
858 #endif /* !PACK_MALLOC */
860 #define M_OVERHEAD (sizeof(union overhead) + RMAGIC_SZ) /* overhead at start+end */
863 # define MEM_OVERHEAD(bucket) \
864 (bucket <= MAX_PACKED ? 0 : M_OVERHEAD)
865 # ifdef SMALL_BUCKET_VIA_TABLE
866 # define START_SHIFTS_BUCKET ((MAX_PACKED_POW2 + 1) * BUCKETS_PER_POW2)
867 # define START_SHIFT MAX_PACKED_POW2
868 # ifdef BUCKETS_ROOT2 /* Chunks of size 3*2^n. */
869 # define SIZE_TABLE_MAX 80
871 # define SIZE_TABLE_MAX 64
873 static char bucket_of[] =
875 # ifdef BUCKETS_ROOT2 /* Chunks of size 3*2^n. */
876 /* 0 to 15 in 4-byte increments. */
877 (sizeof(void*) > 4 ? 6 : 5), /* 4/8, 5-th bucket for better reports */
879 IF_ALIGN_8(8,7), 8, /* 16/12, 16 */
880 9, 9, 10, 10, /* 24, 32 */
881 11, 11, 11, 11, /* 48 */
882 12, 12, 12, 12, /* 64 */
883 13, 13, 13, 13, /* 80 */
884 13, 13, 13, 13 /* 80 */
885 # else /* !BUCKETS_ROOT2 */
886 /* 0 to 15 in 4-byte increments. */
887 (sizeof(void*) > 4 ? 3 : 2),
893 # endif /* !BUCKETS_ROOT2 */
895 # else /* !SMALL_BUCKET_VIA_TABLE */
896 # define START_SHIFTS_BUCKET MIN_BUCKET
897 # define START_SHIFT (MIN_BUC_POW2 - 1)
898 # endif /* !SMALL_BUCKET_VIA_TABLE */
899 #else /* !PACK_MALLOC */
900 # define MEM_OVERHEAD(bucket) M_OVERHEAD
901 # ifdef SMALL_BUCKET_VIA_TABLE
902 # undef SMALL_BUCKET_VIA_TABLE
904 # define START_SHIFTS_BUCKET MIN_BUCKET
905 # define START_SHIFT (MIN_BUC_POW2 - 1)
906 #endif /* !PACK_MALLOC */
909 * Big allocations are often of the size 2^n bytes. To make them a
910 * little bit better, make blocks of size 2^n+pagesize for big n.
913 #ifdef TWO_POT_OPTIMIZE
915 # ifndef PERL_PAGESIZE
916 # define PERL_PAGESIZE 4096
918 # ifndef FIRST_BIG_POW2
919 # define FIRST_BIG_POW2 15 /* 32K, 16K is used too often. */
921 # define FIRST_BIG_BLOCK (1<<FIRST_BIG_POW2)
922 /* If this value or more, check against bigger blocks. */
923 # define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD)
924 /* If less than this value, goes into 2^n-overhead-block. */
925 # define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD)
927 # define POW2_OPTIMIZE_ADJUST(nbytes) \
928 ((nbytes >= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0)
929 # define POW2_OPTIMIZE_SURPLUS(bucket) \
930 ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)
932 #else /* !TWO_POT_OPTIMIZE */
933 # define POW2_OPTIMIZE_ADJUST(nbytes)
934 # define POW2_OPTIMIZE_SURPLUS(bucket) 0
935 #endif /* !TWO_POT_OPTIMIZE */
937 #if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
938 # define BARK_64K_LIMIT(what,nbytes,size) \
939 if (nbytes > 0xffff) { \
940 PerlIO_printf(PerlIO_stderr(), \
941 "%s too large: %lx\n", what, size); \
944 #else /* !HAS_64K_LIMIT || !PERL_CORE */
945 # define BARK_64K_LIMIT(what,nbytes,size)
946 #endif /* !HAS_64K_LIMIT || !PERL_CORE */
949 # define MIN_SBRK 2048
953 # define FIRST_SBRK (48*1024)
956 /* Minimal sbrk in percents of what is already alloced. */
957 #ifndef MIN_SBRK_FRAC
958 # define MIN_SBRK_FRAC 3
961 #ifndef SBRK_ALLOW_FAILURES
962 # define SBRK_ALLOW_FAILURES 3
965 #ifndef SBRK_FAILURE_PRICE
966 # define SBRK_FAILURE_PRICE 50
969 static void morecore (register int bucket);
970 # if defined(DEBUGGING)
971 static void botch (char *diag, char *s, char *file, int line);
973 static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip);
974 static void* get_from_chain (MEM_SIZE size);
975 static void* get_from_bigger_buckets(int bucket, MEM_SIZE size);
976 static union overhead *getpages (MEM_SIZE needed, int *nblksp, int bucket);
977 static int getpages_adjacent(MEM_SIZE require);
981 #ifdef I_MACH_CTHREADS
983 # define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END
985 # define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
988 #endif /* defined PERL_CORE */
991 # define PTRSIZE sizeof(void*)
995 # define BITS_IN_PTR (8*PTRSIZE)
999 * nextf[i] is the pointer to the next free block of size 2^i. The
1000 * smallest allocatable block is 8 bytes. The overhead information
1001 * precedes the data area returned to the user.
1003 #define NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
1004 static union overhead *nextf[NBUCKETS];
1006 #if defined(PURIFY) && !defined(USE_PERL_SBRK)
1007 # define USE_PERL_SBRK
1010 #ifdef USE_PERL_SBRK
1011 # define sbrk(a) Perl_sbrk(a)
1012 Malloc_t Perl_sbrk (int size);
1014 # ifndef HAS_SBRK_PROTO /* <unistd.h> usually takes care of this */
1015 extern Malloc_t sbrk(int);
1019 #ifndef MIN_SBRK_FRAC1000 /* Backward compatibility */
1020 # define MIN_SBRK_FRAC1000 (MIN_SBRK_FRAC * 10)
1023 #ifndef START_EXTERN_C
1025 # define START_EXTERN_C extern "C" {
1027 # define START_EXTERN_C
1031 #ifndef END_EXTERN_C
1033 # define END_EXTERN_C };
1035 # define END_EXTERN_C
1039 #include "malloc_ctl.h"
1041 #ifndef NO_MALLOC_DYNAMIC_CFG
1042 # define PERL_MALLOC_OPT_CHARS "FMfAPGdac"
1044 # ifndef FILL_DEAD_DEFAULT
1045 # define FILL_DEAD_DEFAULT 1
1047 # ifndef FILL_ALIVE_DEFAULT
1048 # define FILL_ALIVE_DEFAULT 1
1050 # ifndef FILL_CHECK_DEFAULT
1051 # define FILL_CHECK_DEFAULT 1
1054 static IV MallocCfg[MallocCfg_last] = {
1058 SBRK_ALLOW_FAILURES,
1060 SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE, /* sbrk_goodness */
1061 FILL_DEAD_DEFAULT, /* FILL_DEAD */
1062 FILL_ALIVE_DEFAULT, /* FILL_ALIVE */
1063 FILL_CHECK_DEFAULT, /* FILL_CHECK */
1064 0, /* MallocCfg_skip_cfg_env */
1065 0, /* MallocCfg_cfg_env_read */
1066 0, /* MallocCfg_emergency_buffer_size */
1067 0, /* MallocCfg_emergency_buffer_prepared_size */
1068 0 /* MallocCfg_emergency_buffer_last_req */
1070 IV *MallocCfg_ptr = MallocCfg;
1072 static char* MallocCfgP[MallocCfg_last] = {
1073 0, /* MallocCfgP_emergency_buffer */
1074 0, /* MallocCfgP_emergency_buffer_prepared */
1076 char **MallocCfgP_ptr = MallocCfgP;
1080 # undef MIN_SBRK_FRAC1000
1081 # undef SBRK_ALLOW_FAILURES
1082 # undef SBRK_FAILURE_PRICE
1084 # define MIN_SBRK MallocCfg[MallocCfg_MIN_SBRK]
1085 # define FIRST_SBRK MallocCfg[MallocCfg_FIRST_SBRK]
1086 # define MIN_SBRK_FRAC1000 MallocCfg[MallocCfg_MIN_SBRK_FRAC1000]
1087 # define SBRK_ALLOW_FAILURES MallocCfg[MallocCfg_SBRK_ALLOW_FAILURES]
1088 # define SBRK_FAILURE_PRICE MallocCfg[MallocCfg_SBRK_FAILURE_PRICE]
1090 # define sbrk_goodness MallocCfg[MallocCfg_sbrk_goodness]
1092 # define emergency_buffer_size MallocCfg[MallocCfg_emergency_buffer_size]
1093 # define emergency_buffer_last_req MallocCfg[MallocCfg_emergency_buffer_last_req]
1095 # define FILL_DEAD MallocCfg[MallocCfg_filldead]
1096 # define FILL_ALIVE MallocCfg[MallocCfg_fillalive]
1097 # define FILL_CHECK_CFG MallocCfg[MallocCfg_fillcheck]
1098 # define FILL_CHECK (FILL_DEAD && FILL_CHECK_CFG)
1100 # define emergency_buffer MallocCfgP[MallocCfgP_emergency_buffer]
1101 # define emergency_buffer_prepared MallocCfgP[MallocCfgP_emergency_buffer_prepared]
1103 #else /* defined(NO_MALLOC_DYNAMIC_CFG) */
1105 # define FILL_DEAD 1
1106 # define FILL_ALIVE 1
1107 # define FILL_CHECK 1
1108 static int sbrk_goodness = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
1110 # define NO_PERL_MALLOC_ENV
1114 #ifdef DEBUGGING_MSTATS
1116 * nmalloc[i] is the difference between the number of mallocs and frees
1117 * for a given block size.
1119 static u_int nmalloc[NBUCKETS];
1120 static u_int sbrk_slack;
1121 static u_int start_slack;
1122 #else /* !( defined DEBUGGING_MSTATS ) */
1123 # define sbrk_slack 0
1126 static u_int goodsbrk;
1128 #ifdef PERL_EMERGENCY_SBRK
1131 # define BIG_SIZE (1<<16) /* 64K */
1134 # ifdef NO_MALLOC_DYNAMIC_CFG
1135 static MEM_SIZE emergency_buffer_size;
1136 /* 0 if the last request for more memory succeeded.
1137 Otherwise the size of the failing request. */
1138 static MEM_SIZE emergency_buffer_last_req;
1139 static char *emergency_buffer;
1140 static char *emergency_buffer_prepared;
1143 # ifndef emergency_sbrk_croak
1144 # define emergency_sbrk_croak croak2
1149 perl_get_emergency_buffer(IV *size)
1152 /* First offense, give a possibility to recover by dieing. */
1153 /* No malloc involved here: */
1154 GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0);
1159 if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
1160 if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
1161 || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD))
1162 return NULL; /* Now die die die... */
1163 /* Got it, now detach SvPV: */
1165 /* Check alignment: */
1166 if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
1167 PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
1168 return NULL; /* die die die */
1173 SvCUR(sv) = SvLEN(sv) = 0;
1174 *size = malloced_size(pv) + M_OVERHEAD;
1175 return pv - sizeof(union overhead);
1177 # define PERL_GET_EMERGENCY_BUFFER(p) perl_get_emergency_buffer(p)
1179 # define PERL_GET_EMERGENCY_BUFFER(p) NULL
1180 # endif /* defined PERL_CORE */
1182 # ifndef NO_MALLOC_DYNAMIC_CFG
1184 get_emergency_buffer(IV *size)
1186 char *pv = emergency_buffer_prepared;
1188 *size = MallocCfg[MallocCfg_emergency_buffer_prepared_size];
1189 emergency_buffer_prepared = 0;
1190 MallocCfg[MallocCfg_emergency_buffer_prepared_size] = 0;
1194 /* Returns 0 on success, -1 on bad alignment, -2 if not implemented */
1196 set_emergency_buffer(char *b, IV size)
1198 if (PTR2UV(b) & (NEEDED_ALIGNMENT - 1))
1200 if (MallocCfg[MallocCfg_emergency_buffer_prepared_size])
1201 add_to_chain((void*)emergency_buffer_prepared,
1202 MallocCfg[MallocCfg_emergency_buffer_prepared_size], 0);
1203 emergency_buffer_prepared = b;
1204 MallocCfg[MallocCfg_emergency_buffer_prepared_size] = size;
1207 # define GET_EMERGENCY_BUFFER(p) get_emergency_buffer(p)
1208 # else /* NO_MALLOC_DYNAMIC_CFG */
1209 # define GET_EMERGENCY_BUFFER(p) NULL
1211 set_emergency_buffer(char *b, IV size)
1218 emergency_sbrk(MEM_SIZE size)
1220 MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
1222 if (size >= BIG_SIZE
1223 && (!emergency_buffer_last_req || (size < emergency_buffer_last_req))) {
1224 /* Give the possibility to recover, but avoid an infinite cycle. */
1226 emergency_buffer_last_req = size;
1227 emergency_sbrk_croak("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
1230 if (emergency_buffer_size >= rsize) {
1231 char *old = emergency_buffer;
1233 emergency_buffer_size -= rsize;
1234 emergency_buffer += rsize;
1237 /* First offense, give a possibility to recover by dieing. */
1238 /* No malloc involved here: */
1240 char *pv = GET_EMERGENCY_BUFFER(&Size);
1243 if (emergency_buffer_size) {
1244 add_to_chain(emergency_buffer, emergency_buffer_size, 0);
1245 emergency_buffer_size = 0;
1246 emergency_buffer = Nullch;
1251 pv = PERL_GET_EMERGENCY_BUFFER(&Size);
1255 return (char *)-1; /* Now die die die... */
1258 /* Check alignment: */
1259 if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) {
1262 PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
1263 return (char *)-1; /* die die die */
1266 emergency_buffer = pv;
1267 emergency_buffer_size = Size;
1271 emergency_sbrk_croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
1276 #else /* !defined(PERL_EMERGENCY_SBRK) */
1277 # define emergency_sbrk(size) -1
1278 #endif /* defined PERL_EMERGENCY_SBRK */
1283 write(2, mess, strlen(mess));
1288 #define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__); else
1290 botch(char *diag, char *s, char *file, int line)
1292 if (!(PERL_MAYBE_ALIVE && PERL_GET_THX))
1296 if (PerlIO_printf(PerlIO_stderr(),
1297 "assertion botched (%s?): %s %s:%d\n",
1298 diag, s, file, line) != 0) {
1299 do_write: /* Can be initializing interpreter */
1300 write2("assertion botched (");
1309 char *s = linebuf + sizeof(linebuf) - 1;
1313 *--s = '0' + (n % 10);
1323 #define ASSERT(p, diag)
1327 /* Fill should be long enough to cover long */
1329 fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
1331 unsigned char *e = s + nbytes;
1333 long lfill = *(long*)fill;
1335 if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */
1336 int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
1337 unsigned const char *f = fill + sizeof(long) - shift;
1338 unsigned char *e1 = s + shift;
1344 while ((unsigned char*)(lp + 1) <= e)
1346 s = (unsigned char*)lp;
1350 /* Just malloc()ed */
1351 static const unsigned char fill_feedadad[] =
1352 {0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD,
1353 0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD};
1355 static const unsigned char fill_deadbeef[] =
1356 {0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF,
1357 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF};
1358 # define FILL_DEADBEEF(s, n) \
1359 (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0)
1360 # define FILL_FEEDADAD(s, n) \
1361 (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0)
1363 # define FILL_DEADBEEF(s, n) ((void)0)
1364 # define FILL_FEEDADAD(s, n) ((void)0)
1365 # undef MALLOC_FILL_CHECK
1368 #ifdef MALLOC_FILL_CHECK
1370 cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
1372 unsigned char *e = s + nbytes;
1374 long lfill = *(long*)fill;
1376 if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */
1377 int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
1378 unsigned const char *f = fill + sizeof(long) - shift;
1379 unsigned char *e1 = s + shift;
1386 while ((unsigned char*)(lp + 1) <= e)
1389 s = (unsigned char*)lp;
1391 if (*s++ != *fill++)
1395 # define FILLCHECK_DEADBEEF(s, n) \
1396 ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \
1397 "free()ed/realloc()ed-away memory was overwritten")
1399 # define FILLCHECK_DEADBEEF(s, n) ((void)0)
1403 Perl_malloc(register size_t nbytes)
1405 register union overhead *p;
1406 register int bucket;
1407 register MEM_SIZE shiftr;
1409 #if defined(DEBUGGING) || defined(RCHECK)
1410 MEM_SIZE size = nbytes;
1413 BARK_64K_LIMIT("Allocation",nbytes,nbytes);
1415 if ((long)nbytes < 0)
1416 croak("%s", "panic: malloc");
1420 * Convert amount of memory requested into
1421 * closest block size stored in hash buckets
1422 * which satisfies request. Account for
1423 * space used per block for accounting.
1426 # ifdef SMALL_BUCKET_VIA_TABLE
1428 bucket = MIN_BUCKET;
1429 else if (nbytes <= SIZE_TABLE_MAX) {
1430 bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT];
1435 if (nbytes <= MAX_POW2_ALGO) goto do_shifts;
1440 POW2_OPTIMIZE_ADJUST(nbytes);
1441 nbytes += M_OVERHEAD;
1442 nbytes = (nbytes + 3) &~ 3;
1443 #if defined(PACK_MALLOC) && !defined(SMALL_BUCKET_VIA_TABLE)
1446 shiftr = (nbytes - 1) >> START_SHIFT;
1447 bucket = START_SHIFTS_BUCKET;
1448 /* apart from this loop, this is O(1) */
1449 while (shiftr >>= 1)
1450 bucket += BUCKETS_PER_POW2;
1454 * If nothing in hash bucket right now,
1455 * request more memory from the system.
1457 if (nextf[bucket] == NULL)
1459 if ((p = nextf[bucket]) == NULL) {
1465 #if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC)
1466 PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
1469 char *eb = buff + sizeof(buff) - 1;
1473 PerlIO_puts(PerlIO_stderr(),"Out of memory during request for ");
1474 #if defined(DEBUGGING) || defined(RCHECK)
1479 *--s = '0' + (n % 10);
1481 PerlIO_puts(PerlIO_stderr(),s);
1482 PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is ");
1484 n = goodsbrk + sbrk_slack;
1486 *--s = '0' + (n % 10);
1488 PerlIO_puts(PerlIO_stderr(),s);
1489 PerlIO_puts(PerlIO_stderr()," bytes!\n");
1490 #endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */
1498 /* remove from linked list */
1500 if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1))
1501 /* Can't get this low */
1502 || (p && PTR2UV(p) < (1<<LOG_OF_MIN_ARENA)) ) {
1504 PerlIO_printf(PerlIO_stderr(),
1505 "Unaligned pointer in the free chain 0x%"UVxf"\n",
1508 if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1))
1509 || (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) {
1511 PerlIO_printf(PerlIO_stderr(),
1512 "Unaligned `next' pointer in the free "
1513 "chain 0x%"UVxf" at 0x%"UVxf"\n",
1514 PTR2UV(p->ov_next), PTR2UV(p));
1517 nextf[bucket] = p->ov_next;
1521 DEBUG_m(PerlIO_printf(Perl_debug_log,
1522 "0x%"UVxf": (%05lu) malloc %ld bytes\n",
1523 PTR2UV((Malloc_t)(p + CHUNK_SHIFT)), (unsigned long)(PL_an++),
1526 FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT),
1527 BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ);
1529 #ifdef IGNORE_SMALL_BAD_FREE
1530 if (bucket >= FIRST_BUCKET_WITH_CHECK)
1532 OV_MAGIC(p, bucket) = MAGIC;
1534 OV_INDEX(p) = bucket;
1538 * Record allocated size of block and
1539 * bound space with magic numbers.
1541 p->ov_rmagic = RMAGIC;
1542 if (bucket <= MAX_SHORT_BUCKET) {
1545 nbytes = size + M_OVERHEAD;
1546 p->ov_size = nbytes - 1;
1547 if ((i = nbytes & (RMAGIC_SZ-1))) {
1549 while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */
1550 ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C;
1552 /* Same at RMAGIC_SZ-aligned RMAGIC */
1553 nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1);
1554 ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC;
1556 FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size);
1558 return ((Malloc_t)(p + CHUNK_SHIFT));
1561 static char *last_sbrk_top;
1562 static char *last_op; /* This arena can be easily extended. */
1563 static MEM_SIZE sbrked_remains;
1565 #ifdef DEBUGGING_MSTATS
1569 struct chunk_chain_s {
1570 struct chunk_chain_s *next;
1573 static struct chunk_chain_s *chunk_chain;
1574 static int n_chunks;
1575 static char max_bucket;
1577 /* Cutoff a piece of one of the chunks in the chain. Prefer smaller chunk. */
1579 get_from_chain(MEM_SIZE size)
1581 struct chunk_chain_s *elt = chunk_chain, **oldp = &chunk_chain;
1582 struct chunk_chain_s **oldgoodp = NULL;
1583 long min_remain = LONG_MAX;
1586 if (elt->size >= size) {
1587 long remains = elt->size - size;
1588 if (remains >= 0 && remains < min_remain) {
1590 min_remain = remains;
1596 oldp = &( elt->next );
1599 if (!oldgoodp) return NULL;
1601 void *ret = *oldgoodp;
1602 struct chunk_chain_s *next = (*oldgoodp)->next;
1604 *oldgoodp = (struct chunk_chain_s *)((char*)ret + size);
1605 (*oldgoodp)->size = min_remain;
1606 (*oldgoodp)->next = next;
1609 void *ret = *oldgoodp;
1610 *oldgoodp = (*oldgoodp)->next;
1617 add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip)
1619 struct chunk_chain_s *next = chunk_chain;
1620 char *cp = (char*)p;
1623 chunk_chain = (struct chunk_chain_s *)cp;
1624 chunk_chain->size = size - chip;
1625 chunk_chain->next = next;
1630 get_from_bigger_buckets(int bucket, MEM_SIZE size)
1633 static int bucketprice[NBUCKETS];
1634 while (bucket <= max_bucket) {
1635 /* We postpone stealing from bigger buckets until we want it
1637 if (nextf[bucket] && bucketprice[bucket]++ >= price) {
1639 void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT);
1640 bucketprice[bucket] = 0;
1641 if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) {
1642 last_op = NULL; /* Disable optimization */
1644 nextf[bucket] = nextf[bucket]->ov_next;
1645 #ifdef DEBUGGING_MSTATS
1647 start_slack -= M_OVERHEAD;
1649 add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) +
1650 POW2_OPTIMIZE_SURPLUS(bucket)),
1659 static union overhead *
1660 getpages(MEM_SIZE needed, int *nblksp, int bucket)
1662 /* Need to do (possibly expensive) system call. Try to
1663 optimize it for rare calling. */
1664 MEM_SIZE require = needed - sbrked_remains;
1666 union overhead *ovp;
1669 if (sbrk_goodness > 0) {
1670 if (!last_sbrk_top && require < FIRST_SBRK)
1671 require = FIRST_SBRK;
1672 else if (require < MIN_SBRK) require = MIN_SBRK;
1674 if (require < goodsbrk * MIN_SBRK_FRAC1000 / 1000)
1675 require = goodsbrk * MIN_SBRK_FRAC1000 / 1000;
1676 require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
1683 DEBUG_m(PerlIO_printf(Perl_debug_log,
1684 "sbrk(%ld) for %ld-byte-long arena\n",
1685 (long)require, (long) needed));
1686 cp = (char *)sbrk(require);
1687 #ifdef DEBUGGING_MSTATS
1690 if (cp == last_sbrk_top) {
1691 /* Common case, anything is fine. */
1693 ovp = (union overhead *) (cp - sbrked_remains);
1694 last_op = cp - sbrked_remains;
1695 sbrked_remains = require - (needed - sbrked_remains);
1696 } else if (cp == (char *)-1) { /* no more room! */
1697 ovp = (union overhead *)emergency_sbrk(needed);
1698 if (ovp == (union overhead *)-1)
1700 if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */
1704 } else { /* Non-continuous or first sbrk(). */
1705 long add = sbrked_remains;
1708 if (sbrked_remains) { /* Put rest into chain, we
1709 cannot use it right now. */
1710 add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1714 /* Second, check alignment. */
1717 #if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */
1718 # ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */
1719 /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may
1720 improve performance of memory access. */
1721 if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */
1722 slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1));
1726 #endif /* !atarist && !MINT */
1729 DEBUG_m(PerlIO_printf(Perl_debug_log,
1730 "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",
1731 (long)add, (long) slack,
1732 (long) sbrked_remains));
1733 newcp = (char *)sbrk(add);
1734 #if defined(DEBUGGING_MSTATS)
1738 if (newcp != cp + require) {
1739 /* Too bad: even rounding sbrk() is not continuous.*/
1740 DEBUG_m(PerlIO_printf(Perl_debug_log,
1741 "failed to fix bad sbrk()\n"));
1745 fatalcroak("panic: Off-page sbrk\n");
1748 if (sbrked_remains) {
1750 #if defined(DEBUGGING_MSTATS)
1751 sbrk_slack += require;
1754 DEBUG_m(PerlIO_printf(Perl_debug_log,
1755 "straight sbrk(%ld)\n",
1757 cp = (char *)sbrk(require);
1758 #ifdef DEBUGGING_MSTATS
1761 if (cp == (char *)-1)
1764 sbrk_goodness = -1; /* Disable optimization!
1765 Continue with not-aligned... */
1768 require += sbrked_remains;
1772 if (last_sbrk_top) {
1773 sbrk_goodness -= SBRK_FAILURE_PRICE;
1776 ovp = (union overhead *) cp;
1778 * Round up to minimum allocation size boundary
1779 * and deduct from block count to reflect.
1782 # if NEEDED_ALIGNMENT > MEM_ALIGNBYTES
1783 if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1))
1784 fatalcroak("Misalignment of sbrk()\n");
1787 #ifndef I286 /* Again, this should always be ok on an 80286 */
1788 if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) {
1789 DEBUG_m(PerlIO_printf(Perl_debug_log,
1790 "fixing sbrk(): %d bytes off machine alignement\n",
1791 (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1))));
1792 ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) &
1793 (MEM_ALIGNBYTES - 1));
1795 # if defined(DEBUGGING_MSTATS)
1796 /* This is only approx. if TWO_POT_OPTIMIZE: */
1797 sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
1801 ; /* Finish `else' */
1802 sbrked_remains = require - needed;
1805 #if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC)
1806 emergency_buffer_last_req = 0;
1808 last_sbrk_top = cp + require;
1809 #ifdef DEBUGGING_MSTATS
1810 goodsbrk += require;
1816 getpages_adjacent(MEM_SIZE require)
1818 if (require <= sbrked_remains) {
1819 sbrked_remains -= require;
1823 require -= sbrked_remains;
1824 /* We do not try to optimize sbrks here, we go for place. */
1825 cp = (char*) sbrk(require);
1826 #ifdef DEBUGGING_MSTATS
1828 goodsbrk += require;
1830 if (cp == last_sbrk_top) {
1832 last_sbrk_top = cp + require;
1834 if (cp == (char*)-1) { /* Out of memory */
1835 #ifdef DEBUGGING_MSTATS
1836 goodsbrk -= require;
1840 /* Report the failure: */
1842 add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1844 add_to_chain((void*)cp, require, 0);
1845 sbrk_goodness -= SBRK_FAILURE_PRICE;
1857 * Allocate more memory to the indicated bucket.
1860 morecore(register int bucket)
1862 register union overhead *ovp;
1863 register int rnu; /* 2^rnu bytes will be requested */
1864 int nblks; /* become nblks blocks of the desired size */
1865 register MEM_SIZE siz, needed;
1866 static int were_called = 0;
1870 #ifndef NO_PERL_MALLOC_ENV
1872 /* It's the our first time. Initialize ourselves */
1873 were_called = 1; /* Avoid a loop */
1874 if (!MallocCfg[MallocCfg_skip_cfg_env]) {
1875 char *s = getenv("PERL_MALLOC_OPT"), *t = s, *off;
1876 const char *opts = PERL_MALLOC_OPT_CHARS;
1879 while ( t && t[0] && t[1] == '='
1880 && ((off = strchr(opts, *t))) ) {
1884 while (*t <= '9' && *t >= '0')
1885 val = 10*val + *t++ - '0';
1886 if (!*t || *t == ';') {
1887 if (MallocCfg[off - opts] != val)
1889 MallocCfg[off - opts] = val;
1895 write2("Unrecognized part of PERL_MALLOC_OPT: `");
1900 MallocCfg[MallocCfg_cfg_env_read] = 1;
1904 if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
1906 croak("%s", "Out of memory during ridiculously large request");
1908 if (bucket > max_bucket)
1909 max_bucket = bucket;
1911 rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT))
1913 : (bucket >> BUCKET_POW2_SHIFT) );
1914 /* This may be overwritten later: */
1915 nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */
1916 needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket);
1917 if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */
1918 ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT;
1919 nextf[rnu << BUCKET_POW2_SHIFT]
1920 = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next;
1921 #ifdef DEBUGGING_MSTATS
1922 nmalloc[rnu << BUCKET_POW2_SHIFT]--;
1923 start_slack -= M_OVERHEAD;
1925 DEBUG_m(PerlIO_printf(Perl_debug_log,
1926 "stealing %ld bytes from %ld arena\n",
1927 (long) needed, (long) rnu << BUCKET_POW2_SHIFT));
1928 } else if (chunk_chain
1929 && (ovp = (union overhead*) get_from_chain(needed))) {
1930 DEBUG_m(PerlIO_printf(Perl_debug_log,
1931 "stealing %ld bytes from chain\n",
1933 } else if ( (ovp = (union overhead*)
1934 get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
1936 DEBUG_m(PerlIO_printf(Perl_debug_log,
1937 "stealing %ld bytes from bigger buckets\n",
1939 } else if (needed <= sbrked_remains) {
1940 ovp = (union overhead *)(last_sbrk_top - sbrked_remains);
1941 sbrked_remains -= needed;
1942 last_op = (char*)ovp;
1944 ovp = getpages(needed, &nblks, bucket);
1948 FILL_DEADBEEF((unsigned char*)ovp, needed);
1951 * Add new memory allocated to that on
1952 * free list for this hash bucket.
1954 siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */
1956 *(u_char*)ovp = bucket; /* Fill index. */
1957 if (bucket <= MAX_PACKED) {
1958 ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1959 nblks = N_BLKS(bucket);
1960 # ifdef DEBUGGING_MSTATS
1961 start_slack += BLK_SHIFT(bucket);
1963 } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) {
1964 ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1965 siz -= sizeof(union overhead);
1966 } else ovp++; /* One chunk per block. */
1967 #endif /* PACK_MALLOC */
1968 nextf[bucket] = ovp;
1969 #ifdef DEBUGGING_MSTATS
1970 nmalloc[bucket] += nblks;
1971 if (bucket > MAX_PACKED) {
1972 start_slack += M_OVERHEAD * nblks;
1976 while (--nblks > 0) {
1977 ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
1978 ovp = (union overhead *)((caddr_t)ovp + siz);
1980 /* Not all sbrks return zeroed memory.*/
1981 ovp->ov_next = (union overhead *)NULL;
1983 if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */
1984 union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next;
1985 nextf[7*BUCKETS_PER_POW2] =
1986 (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2]
1987 - sizeof(union overhead));
1988 nextf[7*BUCKETS_PER_POW2]->ov_next = n_op;
1990 #endif /* !PACK_MALLOC */
1994 Perl_mfree(void *mp)
1996 register MEM_SIZE size;
1997 register union overhead *ovp;
1998 char *cp = (char*)mp;
2003 DEBUG_m(PerlIO_printf(Perl_debug_log,
2004 "0x%"UVxf": (%05lu) free\n",
2005 PTR2UV(cp), (unsigned long)(PL_an++)));
2010 if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1))
2011 croak("%s", "wrong alignment in free()");
2013 ovp = (union overhead *)((caddr_t)cp
2014 - sizeof (union overhead) * CHUNK_SHIFT);
2016 bucket = OV_INDEX(ovp);
2018 #ifdef IGNORE_SMALL_BAD_FREE
2019 if ((bucket >= FIRST_BUCKET_WITH_CHECK)
2020 && (OV_MAGIC(ovp, bucket) != MAGIC))
2022 if (OV_MAGIC(ovp, bucket) != MAGIC)
2025 static int bad_free_warn = -1;
2026 if (bad_free_warn == -1) {
2028 char *pbf = PerlEnv_getenv("PERL_BADFREE");
2029 bad_free_warn = (pbf) ? atoi(pbf) : 1;
2037 if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
2038 Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
2039 ovp->ov_rmagic == RMAGIC - 1 ?
2040 "Duplicate" : "Bad");
2043 warn("%s free() ignored (RMAGIC)",
2044 ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
2050 if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
2051 Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
2054 warn("%s", "Bad free() ignored");
2057 return; /* sanity */
2060 ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
2061 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
2063 MEM_SIZE nbytes = ovp->ov_size + 1;
2065 if ((i = nbytes & (RMAGIC_SZ-1))) {
2067 while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */
2068 ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C,
2069 "chunk's tail overwrite");
2072 /* Same at RMAGIC_SZ-aligned RMAGIC */
2073 nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1);
2074 ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC,
2075 "chunk's tail overwrite");
2076 FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes),
2077 BUCKET_SIZE(OV_INDEX(ovp)) - nbytes);
2079 FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT),
2080 BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ);
2081 ovp->ov_rmagic = RMAGIC - 1;
2083 ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
2084 size = OV_INDEX(ovp);
2087 ovp->ov_next = nextf[size];
2092 /* There is no need to do any locking in realloc (with an exception of
2093 trying to grow in place if we are at the end of the chain).
2094 If somebody calls us from a different thread with the same address,
2095 we are sole anyway. */
2098 Perl_realloc(void *mp, size_t nbytes)
2100 register MEM_SIZE onb;
2101 union overhead *ovp;
2104 register int bucket;
2105 int incr; /* 1 if does not fit, -1 if "easily" fits in a
2106 smaller bucket, otherwise 0. */
2107 char *cp = (char*)mp;
2109 #if defined(DEBUGGING) || !defined(PERL_CORE)
2110 MEM_SIZE size = nbytes;
2112 if ((long)nbytes < 0)
2113 croak("%s", "panic: realloc");
2116 BARK_64K_LIMIT("Reallocation",nbytes,size);
2118 return Perl_malloc(nbytes);
2120 ovp = (union overhead *)((caddr_t)cp
2121 - sizeof (union overhead) * CHUNK_SHIFT);
2122 bucket = OV_INDEX(ovp);
2124 #ifdef IGNORE_SMALL_BAD_FREE
2125 if ((bucket >= FIRST_BUCKET_WITH_CHECK)
2126 && (OV_MAGIC(ovp, bucket) != MAGIC))
2128 if (OV_MAGIC(ovp, bucket) != MAGIC)
2131 static int bad_free_warn = -1;
2132 if (bad_free_warn == -1) {
2134 char *pbf = PerlEnv_getenv("PERL_BADFREE");
2135 bad_free_warn = (pbf) ? atoi(pbf) : 1;
2143 if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
2144 Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
2145 (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
2146 ovp->ov_rmagic == RMAGIC - 1
2147 ? "of freed memory " : "");
2150 warn2("%srealloc() %signored",
2151 (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
2152 ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
2158 if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
2159 Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s",
2160 "Bad realloc() ignored");
2163 warn("%s", "Bad realloc() ignored");
2166 return Nullch; /* sanity */
2169 onb = BUCKET_SIZE_REAL(bucket);
2171 * avoid the copy if same size block.
2172 * We are not agressive with boundary cases. Note that it might
2173 * (for a small number of cases) give false negative if
2174 * both new size and old one are in the bucket for
2175 * FIRST_BIG_POW2, but the new one is near the lower end.
2177 * We do not try to go to 1.5 times smaller bucket so far.
2179 if (nbytes > onb) incr = 1;
2181 #ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING
2182 if ( /* This is a little bit pessimal if PACK_MALLOC: */
2183 nbytes > ( (onb >> 1) - M_OVERHEAD )
2184 # ifdef TWO_POT_OPTIMIZE
2185 || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND )
2188 #else /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
2189 prev_bucket = ( (bucket > MAX_PACKED + 1)
2190 ? bucket - BUCKETS_PER_POW2
2192 if (nbytes > BUCKET_SIZE_REAL(prev_bucket))
2193 #endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
2197 #ifdef STRESS_REALLOC
2204 * Record new allocated size of block and
2205 * bound space with magic numbers.
2207 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
2208 int i, nb = ovp->ov_size + 1;
2210 if ((i = nb & (RMAGIC_SZ-1))) {
2212 while (i--) { /* nb - RMAGIC_SZ is end of alloced area */
2213 ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C, "chunk's tail overwrite");
2216 /* Same at RMAGIC_SZ-aligned RMAGIC */
2217 nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1);
2218 ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC,
2219 "chunk's tail overwrite");
2220 FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb),
2221 BUCKET_SIZE(OV_INDEX(ovp)) - nb);
2222 if (nbytes > ovp->ov_size + 1 - M_OVERHEAD)
2223 FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD,
2224 nbytes - (ovp->ov_size + 1 - M_OVERHEAD));
2226 FILL_DEADBEEF((unsigned char*)cp + nbytes,
2227 nb - M_OVERHEAD + RMAGIC_SZ - nbytes);
2229 * Convert amount of memory requested into
2230 * closest block size stored in hash buckets
2231 * which satisfies request. Account for
2232 * space used per block for accounting.
2234 nbytes += M_OVERHEAD;
2235 ovp->ov_size = nbytes - 1;
2236 if ((i = nbytes & (RMAGIC_SZ-1))) {
2238 while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */
2239 ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i]
2242 /* Same at RMAGIC_SZ-aligned RMAGIC */
2243 nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1);
2244 ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC;
2248 DEBUG_m(PerlIO_printf(Perl_debug_log,
2249 "0x%"UVxf": (%05lu) realloc %ld bytes inplace\n",
2250 PTR2UV(res),(unsigned long)(PL_an++),
2252 } else if (incr == 1 && (cp - M_OVERHEAD == last_op)
2253 && (onb > (1 << LOG_OF_MIN_ARENA))) {
2254 MEM_SIZE require, newarena = nbytes, pow;
2257 POW2_OPTIMIZE_ADJUST(newarena);
2258 newarena = newarena + M_OVERHEAD;
2259 /* newarena = (newarena + 3) &~ 3; */
2260 shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA;
2261 pow = LOG_OF_MIN_ARENA + 1;
2262 /* apart from this loop, this is O(1) */
2263 while (shiftr >>= 1)
2265 newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2);
2266 require = newarena - onb - M_OVERHEAD;
2269 if (cp - M_OVERHEAD == last_op /* We *still* are the last chunk */
2270 && getpages_adjacent(require)) {
2271 #ifdef DEBUGGING_MSTATS
2273 nmalloc[pow * BUCKETS_PER_POW2]++;
2275 *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
2284 DEBUG_m(PerlIO_printf(Perl_debug_log,
2285 "0x%"UVxf": (%05lu) realloc %ld bytes the hard way\n",
2286 PTR2UV(cp),(unsigned long)(PL_an++),
2288 if ((res = (char*)Perl_malloc(nbytes)) == NULL)
2290 if (cp != res) /* common optimization */
2291 Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
2294 return ((Malloc_t)res);
2298 Perl_calloc(register size_t elements, register size_t size)
2300 long sz = elements * size;
2301 Malloc_t p = Perl_malloc(sz);
2304 memset((void*)p, 0, sz);
2310 Perl_strdup(const char *s)
2312 MEM_SIZE l = strlen(s);
2313 char *s1 = (char *)Perl_malloc(l+1);
2315 return CopyD(s, s1, (MEM_SIZE)(l+1), char);
2320 Perl_putenv(char *a)
2322 /* Sometimes system's putenv conflicts with my_setenv() - this is system
2323 malloc vs Perl's free(). */
2330 while (*val && *val != '=')
2335 if (l < sizeof(buf))
2338 var = Perl_malloc(l + 1);
2339 Copy(a, var, l, char);
2341 my_setenv(var, val+1);
2349 Perl_malloced_size(void *p)
2351 union overhead *ovp = (union overhead *)
2352 ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
2353 int bucket = OV_INDEX(ovp);
2355 /* The caller wants to have a complete control over the chunk,
2356 disable the memory checking inside the chunk. */
2357 if (bucket <= MAX_SHORT_BUCKET) {
2358 MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
2359 ovp->ov_size = size + M_OVERHEAD - 1;
2360 *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC;
2363 return BUCKET_SIZE_REAL(bucket);
2366 # ifdef BUCKETS_ROOT2
2367 # define MIN_EVEN_REPORT 6
2369 # define MIN_EVEN_REPORT MIN_BUCKET
2373 Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
2375 #ifdef DEBUGGING_MSTATS
2377 register union overhead *p;
2378 struct chunk_chain_s* nextchain;
2380 buf->topbucket = buf->topbucket_ev = buf->topbucket_odd
2381 = buf->totfree = buf->total = buf->total_chain = 0;
2383 buf->minbucket = MIN_BUCKET;
2385 for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
2386 for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
2390 buf->ntotal[i] = nmalloc[i];
2392 buf->totfree += j * BUCKET_SIZE_REAL(i);
2393 buf->total += nmalloc[i] * BUCKET_SIZE_REAL(i);
2395 i % 2 ? (buf->topbucket_odd = i) : (buf->topbucket_ev = i);
2399 nextchain = chunk_chain;
2401 buf->total_chain += nextchain->size;
2402 nextchain = nextchain->next;
2404 buf->total_sbrk = goodsbrk + sbrk_slack;
2406 buf->sbrk_good = sbrk_goodness;
2407 buf->sbrk_slack = sbrk_slack;
2408 buf->start_slack = start_slack;
2409 buf->sbrked_remains = sbrked_remains;
2411 buf->nbuckets = NBUCKETS;
2413 for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
2416 buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i);
2417 buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i);
2420 #endif /* defined DEBUGGING_MSTATS */
2421 return 0; /* XXX unused */
2424 * mstats - print out statistics about malloc
2426 * Prints two lines of numbers, one showing the length of the free list
2427 * for each size category, the second showing the number of mallocs -
2428 * frees for each size category.
2431 Perl_dump_mstats(pTHX_ char *s)
2433 #ifdef DEBUGGING_MSTATS
2435 perl_mstats_t buffer;
2441 get_mstats(&buffer, NBUCKETS, 0);
2444 PerlIO_printf(Perl_error_log,
2445 "Memory allocation statistics %s (buckets %"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n",
2447 (IV)BUCKET_SIZE_REAL(MIN_BUCKET),
2448 (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET),
2449 (IV)BUCKET_SIZE_REAL(buffer.topbucket),
2450 (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket));
2451 PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree);
2452 for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
2453 PerlIO_printf(Perl_error_log,
2454 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
2456 : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)),
2459 #ifdef BUCKETS_ROOT2
2460 PerlIO_printf(Perl_error_log, "\n\t ");
2461 for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) {
2462 PerlIO_printf(Perl_error_log,
2463 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
2465 : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)),
2469 PerlIO_printf(Perl_error_log, "\n%8"IVdf" used:", buffer.total - buffer.totfree);
2470 for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
2471 PerlIO_printf(Perl_error_log,
2472 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
2474 : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)),
2475 buffer.ntotal[i] - buffer.nfree[i]);
2477 #ifdef BUCKETS_ROOT2
2478 PerlIO_printf(Perl_error_log, "\n\t ");
2479 for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) {
2480 PerlIO_printf(Perl_error_log,
2481 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
2483 : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)),
2484 buffer.ntotal[i] - buffer.nfree[i]);
2487 PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %"IVdf"/%"IVdf":%"IVdf". Odd ends: pad+heads+chain+tail: %"IVdf"+%"IVdf"+%"IVdf"+%"IVdf".\n",
2488 buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good,
2489 buffer.sbrk_slack, buffer.start_slack,
2490 buffer.total_chain, buffer.sbrked_remains);
2491 #endif /* DEBUGGING_MSTATS */
2495 #ifdef USE_PERL_SBRK
2497 # if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__) || defined(PURIFY)
2498 # define PERL_SBRK_VIA_MALLOC
2501 # ifdef PERL_SBRK_VIA_MALLOC
2503 /* it may seem schizophrenic to use perl's malloc and let it call system */
2504 /* malloc, the reason for that is only the 3.2 version of the OS that had */
2505 /* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
2506 /* end to the cores */
2508 # ifndef SYSTEM_ALLOC
2509 # define SYSTEM_ALLOC(a) malloc(a)
2511 # ifndef SYSTEM_ALLOC_ALIGNMENT
2512 # define SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES
2515 # endif /* PERL_SBRK_VIA_MALLOC */
2517 static IV Perl_sbrk_oldchunk;
2518 static long Perl_sbrk_oldsize;
2520 # define PERLSBRK_32_K (1<<15)
2521 # define PERLSBRK_64_K (1<<16)
2529 if (!size) return 0;
2531 reqsize = size; /* just for the DEBUG_m statement */
2534 size = (size + 0x7ff) & ~0x7ff;
2536 if (size <= Perl_sbrk_oldsize) {
2537 got = Perl_sbrk_oldchunk;
2538 Perl_sbrk_oldchunk += size;
2539 Perl_sbrk_oldsize -= size;
2541 if (size >= PERLSBRK_32_K) {
2544 size = PERLSBRK_64_K;
2547 # if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
2548 size += NEEDED_ALIGNMENT - SYSTEM_ALLOC_ALIGNMENT;
2550 got = (IV)SYSTEM_ALLOC(size);
2551 # if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
2552 got = (got + NEEDED_ALIGNMENT - 1) & ~(NEEDED_ALIGNMENT - 1);
2555 /* Chunk is small, register the rest for future allocs. */
2556 Perl_sbrk_oldchunk = got + reqsize;
2557 Perl_sbrk_oldsize = size - reqsize;
2561 DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%"UVxf"\n",
2562 size, reqsize, Perl_sbrk_oldsize, PTR2UV(got)));
2567 #endif /* ! defined USE_PERL_SBRK */