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