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