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