This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid .exe in $Config{cc} (spotted by Vadim Konovalov
[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"
864dbfa3 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
e8bc2b5c
GS
290#endif
291
292#ifndef MUTEX_LOCK
293# define MUTEX_LOCK(l)
294#endif
295
296#ifndef MUTEX_UNLOCK
297# define MUTEX_UNLOCK(l)
298#endif
299
741df71a 300#ifndef MALLOC_LOCK
cea2e8a9 301# define MALLOC_LOCK MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex)
741df71a
IZ
302#endif
303
304#ifndef MALLOC_UNLOCK
cea2e8a9 305# define MALLOC_UNLOCK MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex)
741df71a
IZ
306#endif
307
5bbd1ef5
IZ
308# ifndef fatalcroak /* make depend */
309# define fatalcroak(mess) (write(2, (mess), strlen(mess)), exit(2))
310# endif
311
760ac839 312#ifdef DEBUGGING
e8bc2b5c 313# undef DEBUG_m
0b250b9e
GS
314# define DEBUG_m(a) \
315 STMT_START { \
316 if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \
317 } STMT_END
760ac839
LW
318#endif
319
e9397286
GS
320/*
321 * Layout of memory:
322 * ~~~~~~~~~~~~~~~~
323 * The memory is broken into "blocks" which occupy multiples of 2K (and
324 * generally speaking, have size "close" to a power of 2). The addresses
325 * of such *unused* blocks are kept in nextf[i] with big enough i. (nextf
326 * is an array of linked lists.) (Addresses of used blocks are not known.)
327 *
328 * Moreover, since the algorithm may try to "bite" smaller blocks of out
329 * of unused bigger ones, there are also regions of "irregular" size,
330 * managed separately, by a linked list chunk_chain.
331 *
332 * The third type of storage is the sbrk()ed-but-not-yet-used space, its
333 * end and size are kept in last_sbrk_top and sbrked_remains.
334 *
335 * Growing blocks "in place":
336 * ~~~~~~~~~~~~~~~~~~~~~~~~~
337 * The address of the block with the greatest address is kept in last_op
338 * (if not known, last_op is 0). If it is known that the memory above
339 * last_op is not continuous, or contains a chunk from chunk_chain,
340 * last_op is set to 0.
341 *
342 * The chunk with address last_op may be grown by expanding into
343 * sbrk()ed-but-not-yet-used space, or trying to sbrk() more continuous
344 * memory.
345 *
346 * Management of last_op:
347 * ~~~~~~~~~~~~~~~~~~~~~
348 *
349 * free() never changes the boundaries of blocks, so is not relevant.
350 *
351 * The only way realloc() may change the boundaries of blocks is if it
352 * grows a block "in place". However, in the case of success such a
353 * chunk is automatically last_op, and it remains last_op. In the case
354 * of failure getpages_adjacent() clears last_op.
355 *
356 * malloc() may change blocks by calling morecore() only.
357 *
358 * morecore() may create new blocks by:
359 * a) biting pieces from chunk_chain (cannot create one above last_op);
360 * b) biting a piece from an unused block (if block was last_op, this
361 * may create a chunk from chain above last_op, thus last_op is
362 * invalidated in such a case).
363 * c) biting of sbrk()ed-but-not-yet-used space. This creates
364 * a block which is last_op.
365 * d) Allocating new pages by calling getpages();
366 *
367 * getpages() creates a new block. It marks last_op at the bottom of
368 * the chunk of memory it returns.
369 *
370 * Active pages footprint:
371 * ~~~~~~~~~~~~~~~~~~~~~~
372 * Note that we do not need to traverse the lists in nextf[i], just take
373 * the first element of this list. However, we *need* to traverse the
374 * list in chunk_chain, but most the time it should be a very short one,
375 * so we do not step on a lot of pages we are not going to use.
376 *
377 * Flaws:
378 * ~~~~~
379 * get_from_bigger_buckets(): forget to increment price => Quite
380 * aggressive.
381 */
382
135863df
AB
383/* I don't much care whether these are defined in sys/types.h--LAW */
384
385#define u_char unsigned char
386#define u_int unsigned int
56431972
RB
387/*
388 * I removed the definition of u_bigint which appeared to be u_bigint = UV
389 * u_bigint was only used in TWOK_MASKED and TWOK_SHIFT
390 * where I have used PTR2UV. RMB
391 */
135863df 392#define u_short unsigned short
8d063cd8 393
cf5c4ad8 394/* 286 and atarist like big chunks, which gives too much overhead. */
61ae2fbf 395#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC)
e8bc2b5c 396# undef PACK_MALLOC
cf5c4ad8
PP
397#endif
398
8d063cd8 399/*
cf5c4ad8
PP
400 * The description below is applicable if PACK_MALLOC is not defined.
401 *
8d063cd8
LW
402 * The overhead on a block is at least 4 bytes. When free, this space
403 * contains a pointer to the next free block, and the bottom two bits must
404 * be zero. When in use, the first byte is set to MAGIC, and the second
405 * byte is the size index. The remaining bytes are for alignment.
406 * If range checking is enabled and the size of the block fits
407 * in two bytes, then the top two bytes hold the size of the requested block
408 * plus the range checking words, and the header word MINUS ONE.
409 */
410union overhead {
411 union overhead *ov_next; /* when free */
85e6fe83 412#if MEM_ALIGNBYTES > 4
c623bd54 413 double strut; /* alignment problems */
a687059c 414#endif
8d063cd8
LW
415 struct {
416 u_char ovu_magic; /* magic number */
417 u_char ovu_index; /* bucket # */
418#ifdef RCHECK
419 u_short ovu_size; /* actual block size */
420 u_int ovu_rmagic; /* range magic number */
421#endif
422 } ovu;
423#define ov_magic ovu.ovu_magic
424#define ov_index ovu.ovu_index
425#define ov_size ovu.ovu_size
426#define ov_rmagic ovu.ovu_rmagic
427};
428
429#define MAGIC 0xff /* magic # on accounting info */
430#define RMAGIC 0x55555555 /* magic # on range info */
e8bc2b5c
GS
431#define RMAGIC_C 0x55 /* magic # on range info */
432
8d063cd8 433#ifdef RCHECK
c2a5c2d2
IZ
434# define RSLOP sizeof (u_int)
435# ifdef TWO_POT_OPTIMIZE
e8bc2b5c 436# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2)
c2a5c2d2 437# else
e8bc2b5c 438# define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
c2a5c2d2 439# endif
8d063cd8 440#else
c2a5c2d2 441# define RSLOP 0
8d063cd8
LW
442#endif
443
e8bc2b5c
GS
444#if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
445# undef BUCKETS_ROOT2
446#endif
447
448#ifdef BUCKETS_ROOT2
449# define BUCKET_TABLE_SHIFT 2
450# define BUCKET_POW2_SHIFT 1
451# define BUCKETS_PER_POW2 2
452#else
453# define BUCKET_TABLE_SHIFT MIN_BUC_POW2
454# define BUCKET_POW2_SHIFT 0
455# define BUCKETS_PER_POW2 1
456#endif
457
274c7500
IZ
458#if !defined(MEM_ALIGNBYTES) || ((MEM_ALIGNBYTES > 4) && !defined(STRICT_ALIGNMENT))
459/* Figure out the alignment of void*. */
460struct aligner {
461 char c;
462 void *p;
463};
464# define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
465#else
466# define ALIGN_SMALL MEM_ALIGNBYTES
467#endif
468
469#define IF_ALIGN_8(yes,no) ((ALIGN_SMALL>4) ? (yes) : (no))
470
e8bc2b5c
GS
471#ifdef BUCKETS_ROOT2
472# define MAX_BUCKET_BY_TABLE 13
473static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
474 {
475 0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
476 };
477# define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
478# define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \
479 ? buck_size[i] \
480 : ((1 << ((i) >> BUCKET_POW2_SHIFT)) \
481 - MEM_OVERHEAD(i) \
482 + POW2_OPTIMIZE_SURPLUS(i)))
483#else
484# define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
485# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) + POW2_OPTIMIZE_SURPLUS(i))
486#endif
487
488
cf5c4ad8 489#ifdef PACK_MALLOC
e8bc2b5c
GS
490/* In this case it is assumed that if we do sbrk() in 2K units, we
491 * will get 2K aligned arenas (at least after some initial
492 * alignment). The bucket number of the given subblock is on the start
493 * of 2K arena which contains the subblock. Several following bytes
494 * contain the magic numbers for the subblocks in the block.
cf5c4ad8
PP
495 *
496 * Sizes of chunks are powers of 2 for chunks in buckets <=
497 * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to
498 * get alignment right).
499 *
e8bc2b5c
GS
500 * Consider an arena for 2^n with n>MAX_PACKED. We suppose that
501 * starts of all the chunks in a 2K arena are in different
502 * 2^n-byte-long chunks. If the top of the last chunk is aligned on a
503 * boundary of 2K block, this means that sizeof(union
504 * overhead)*"number of chunks" < 2^n, or sizeof(union overhead)*2K <
505 * 4^n, or n > 6 + log2(sizeof()/2)/2, since a chunk of size 2^n -
506 * overhead is used. Since this rules out n = 7 for 8 byte alignment,
507 * we specialcase allocation of the first of 16 128-byte-long chunks.
cf5c4ad8
PP
508 *
509 * Note that with the above assumption we automatically have enough
510 * place for MAGIC at the start of 2K block. Note also that we
e8bc2b5c
GS
511 * overlay union overhead over the chunk, thus the start of small chunks
512 * is immediately overwritten after freeing. */
513# define MAX_PACKED_POW2 6
514# define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
515# define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
516# define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
56431972
RB
517# define TWOK_MASKED(x) (PTR2UV(x) & ~TWOK_MASK)
518# define TWOK_SHIFT(x) (PTR2UV(x) & TWOK_MASK)
519# define OV_INDEXp(block) (INT2PTR(u_char*,TWOK_MASKED(block)))
cf5c4ad8
PP
520# define OV_INDEX(block) (*OV_INDEXp(block))
521# define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \
e8bc2b5c
GS
522 (TWOK_SHIFT(block)>> \
523 (bucket>>BUCKET_POW2_SHIFT)) + \
524 (bucket >= MIN_NEEDS_SHIFT ? 1 : 0)))
525 /* A bucket can have a shift smaller than it size, we need to
526 shift its magic number so it will not overwrite index: */
527# ifdef BUCKETS_ROOT2
528# define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2 - 1) /* Shift 80 greater than chunk 64. */
529# else
530# define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2) /* Shift 128 greater than chunk 32. */
531# endif
cf5c4ad8
PP
532# define CHUNK_SHIFT 0
533
e8bc2b5c
GS
534/* Number of active buckets of given ordinal. */
535#ifdef IGNORE_SMALL_BAD_FREE
536#define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
537# define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
538 ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE(bucket) \
539 : n_blks[bucket] )
540#else
541# define N_BLKS(bucket) n_blks[bucket]
542#endif
543
544static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
545 {
546# if BUCKETS_PER_POW2==1
547 0, 0,
548 (MIN_BUC_POW2==2 ? 384 : 0),
549 224, 120, 62, 31, 16, 8, 4, 2
550# else
551 0, 0, 0, 0,
552 (MIN_BUC_POW2==2 ? 384 : 0), (MIN_BUC_POW2==2 ? 384 : 0), /* 4, 4 */
553 224, 149, 120, 80, 62, 41, 31, 25, 16, 16, 8, 8, 4, 4, 2, 2
554# endif
555 };
556
557/* Shift of the first bucket with the given ordinal inside 2K chunk. */
558#ifdef IGNORE_SMALL_BAD_FREE
559# define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
560 ? ((1<<LOG_OF_MIN_ARENA) \
561 - BUCKET_SIZE(bucket) * N_BLKS(bucket)) \
562 : blk_shift[bucket])
563#else
564# define BLK_SHIFT(bucket) blk_shift[bucket]
565#endif
566
567static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
568 {
569# if BUCKETS_PER_POW2==1
570 0, 0,
571 (MIN_BUC_POW2==2 ? 512 : 0),
572 256, 128, 64, 64, /* 8 to 64 */
573 16*sizeof(union overhead),
574 8*sizeof(union overhead),
575 4*sizeof(union overhead),
576 2*sizeof(union overhead),
577# else
578 0, 0, 0, 0,
579 (MIN_BUC_POW2==2 ? 512 : 0), (MIN_BUC_POW2==2 ? 512 : 0),
580 256, 260, 128, 128, 64, 80, 64, 48, /* 8 to 96 */
581 16*sizeof(union overhead), 16*sizeof(union overhead),
582 8*sizeof(union overhead), 8*sizeof(union overhead),
583 4*sizeof(union overhead), 4*sizeof(union overhead),
584 2*sizeof(union overhead), 2*sizeof(union overhead),
585# endif
586 };
cf5c4ad8 587
5bbd1ef5
IZ
588# define NEEDED_ALIGNMENT 0x800 /* 2k boundaries */
589# define WANTED_ALIGNMENT 0x800 /* 2k boundaries */
590
cf5c4ad8
PP
591#else /* !PACK_MALLOC */
592
593# define OV_MAGIC(block,bucket) (block)->ov_magic
594# define OV_INDEX(block) (block)->ov_index
595# define CHUNK_SHIFT 1
e8bc2b5c 596# define MAX_PACKED -1
5bbd1ef5
IZ
597# define NEEDED_ALIGNMENT MEM_ALIGNBYTES
598# define WANTED_ALIGNMENT 0x400 /* 1k boundaries */
599
cf5c4ad8
PP
600#endif /* !PACK_MALLOC */
601
e8bc2b5c
GS
602#define M_OVERHEAD (sizeof(union overhead) + RSLOP)
603
604#ifdef PACK_MALLOC
605# define MEM_OVERHEAD(bucket) \
606 (bucket <= MAX_PACKED ? 0 : M_OVERHEAD)
607# ifdef SMALL_BUCKET_VIA_TABLE
608# define START_SHIFTS_BUCKET ((MAX_PACKED_POW2 + 1) * BUCKETS_PER_POW2)
609# define START_SHIFT MAX_PACKED_POW2
610# ifdef BUCKETS_ROOT2 /* Chunks of size 3*2^n. */
611# define SIZE_TABLE_MAX 80
612# else
613# define SIZE_TABLE_MAX 64
614# endif
615static char bucket_of[] =
616 {
617# ifdef BUCKETS_ROOT2 /* Chunks of size 3*2^n. */
618 /* 0 to 15 in 4-byte increments. */
619 (sizeof(void*) > 4 ? 6 : 5), /* 4/8, 5-th bucket for better reports */
620 6, /* 8 */
274c7500 621 IF_ALIGN_8(8,7), 8, /* 16/12, 16 */
e8bc2b5c
GS
622 9, 9, 10, 10, /* 24, 32 */
623 11, 11, 11, 11, /* 48 */
624 12, 12, 12, 12, /* 64 */
625 13, 13, 13, 13, /* 80 */
626 13, 13, 13, 13 /* 80 */
627# else /* !BUCKETS_ROOT2 */
628 /* 0 to 15 in 4-byte increments. */
629 (sizeof(void*) > 4 ? 3 : 2),
630 3,
631 4, 4,
632 5, 5, 5, 5,
633 6, 6, 6, 6,
634 6, 6, 6, 6
635# endif /* !BUCKETS_ROOT2 */
636 };
637# else /* !SMALL_BUCKET_VIA_TABLE */
638# define START_SHIFTS_BUCKET MIN_BUCKET
639# define START_SHIFT (MIN_BUC_POW2 - 1)
640# endif /* !SMALL_BUCKET_VIA_TABLE */
641#else /* !PACK_MALLOC */
642# define MEM_OVERHEAD(bucket) M_OVERHEAD
643# ifdef SMALL_BUCKET_VIA_TABLE
644# undef SMALL_BUCKET_VIA_TABLE
645# endif
646# define START_SHIFTS_BUCKET MIN_BUCKET
647# define START_SHIFT (MIN_BUC_POW2 - 1)
648#endif /* !PACK_MALLOC */
cf5c4ad8 649
8d063cd8 650/*
55497cff
PP
651 * Big allocations are often of the size 2^n bytes. To make them a
652 * little bit better, make blocks of size 2^n+pagesize for big n.
653 */
654
655#ifdef TWO_POT_OPTIMIZE
656
5f05dabc
PP
657# ifndef PERL_PAGESIZE
658# define PERL_PAGESIZE 4096
659# endif
e8bc2b5c
GS
660# ifndef FIRST_BIG_POW2
661# define FIRST_BIG_POW2 15 /* 32K, 16K is used too often. */
5f05dabc 662# endif
e8bc2b5c 663# define FIRST_BIG_BLOCK (1<<FIRST_BIG_POW2)
55497cff
PP
664/* If this value or more, check against bigger blocks. */
665# define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD)
666/* If less than this value, goes into 2^n-overhead-block. */
667# define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD)
668
e8bc2b5c
GS
669# define POW2_OPTIMIZE_ADJUST(nbytes) \
670 ((nbytes >= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0)
671# define POW2_OPTIMIZE_SURPLUS(bucket) \
672 ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)
673
674#else /* !TWO_POT_OPTIMIZE */
675# define POW2_OPTIMIZE_ADJUST(nbytes)
676# define POW2_OPTIMIZE_SURPLUS(bucket) 0
677#endif /* !TWO_POT_OPTIMIZE */
678
679#if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
680# define BARK_64K_LIMIT(what,nbytes,size) \
681 if (nbytes > 0xffff) { \
682 PerlIO_printf(PerlIO_stderr(), \
683 "%s too large: %lx\n", what, size); \
684 my_exit(1); \
685 }
686#else /* !HAS_64K_LIMIT || !PERL_CORE */
687# define BARK_64K_LIMIT(what,nbytes,size)
688#endif /* !HAS_64K_LIMIT || !PERL_CORE */
55497cff 689
e8bc2b5c
GS
690#ifndef MIN_SBRK
691# define MIN_SBRK 2048
692#endif
693
694#ifndef FIRST_SBRK
d720c441 695# define FIRST_SBRK (48*1024)
e8bc2b5c
GS
696#endif
697
698/* Minimal sbrk in percents of what is already alloced. */
699#ifndef MIN_SBRK_FRAC
700# define MIN_SBRK_FRAC 3
701#endif
702
703#ifndef SBRK_ALLOW_FAILURES
704# define SBRK_ALLOW_FAILURES 3
705#endif
55497cff 706
e8bc2b5c
GS
707#ifndef SBRK_FAILURE_PRICE
708# define SBRK_FAILURE_PRICE 50
55497cff
PP
709#endif
710
e8bc2b5c
GS
711#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
712
713# ifndef BIG_SIZE
714# define BIG_SIZE (1<<16) /* 64K */
715# endif
716
3541dd58 717#ifdef I_MACH_CTHREADS
772fe5b3
HM
718# undef MUTEX_LOCK
719# define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END
720# undef MUTEX_UNLOCK
721# define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
3541dd58
HM
722#endif
723
55497cff
PP
724static char *emergency_buffer;
725static MEM_SIZE emergency_buffer_size;
726
cea2e8a9
GS
727static int findbucket (union overhead *freep, int srchlen);
728static void morecore (register int bucket);
729# if defined(DEBUGGING)
730static void botch (char *diag, char *s);
731# endif
732static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip);
733static Malloc_t emergency_sbrk (MEM_SIZE size);
734static void* get_from_chain (MEM_SIZE size);
735static void* get_from_bigger_buckets(int bucket, MEM_SIZE size);
736static union overhead *getpages (int needed, int *nblksp, int bucket);
737static int getpages_adjacent(int require);
738
739static Malloc_t
740emergency_sbrk(MEM_SIZE size)
55497cff 741{
28ac10b1
IZ
742 MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
743
55497cff
PP
744 if (size >= BIG_SIZE) {
745 /* Give the possibility to recover: */
741df71a 746 MALLOC_UNLOCK;
1b979e0a 747 croak("Out of memory during \"large\" request for %i bytes", size);
55497cff
PP
748 }
749
28ac10b1
IZ
750 if (emergency_buffer_size >= rsize) {
751 char *old = emergency_buffer;
752
753 emergency_buffer_size -= rsize;
754 emergency_buffer += rsize;
755 return old;
756 } else {
cea2e8a9 757 dTHX;
55497cff
PP
758 /* First offense, give a possibility to recover by dieing. */
759 /* No malloc involved here: */
4a33f861 760 GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0);
55497cff
PP
761 SV *sv;
762 char *pv;
28ac10b1 763 int have = 0;
2d8e6c8d 764 STRLEN n_a;
55497cff 765
28ac10b1
IZ
766 if (emergency_buffer_size) {
767 add_to_chain(emergency_buffer, emergency_buffer_size, 0);
768 emergency_buffer_size = 0;
769 emergency_buffer = Nullch;
770 have = 1;
771 }
4a33f861 772 if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
55497cff 773 if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
28ac10b1
IZ
774 || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
775 if (have)
776 goto do_croak;
55497cff 777 return (char *)-1; /* Now die die die... */
28ac10b1 778 }
55497cff 779 /* Got it, now detach SvPV: */
2d8e6c8d 780 pv = SvPV(sv, n_a);
55497cff 781 /* Check alignment: */
56431972 782 if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
55497cff 783 PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
bbce6d69 784 return (char *)-1; /* die die die */
55497cff
PP
785 }
786
28ac10b1
IZ
787 emergency_buffer = pv - sizeof(union overhead);
788 emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
55497cff 789 SvPOK_off(sv);
28ac10b1
IZ
790 SvPVX(sv) = Nullch;
791 SvCUR(sv) = SvLEN(sv) = 0;
55497cff 792 }
28ac10b1 793 do_croak:
741df71a 794 MALLOC_UNLOCK;
28ac10b1 795 croak("Out of memory during request for %i bytes", size);
55497cff
PP
796}
797
e8bc2b5c 798#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
55497cff 799# define emergency_sbrk(size) -1
e8bc2b5c 800#endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
55497cff
PP
801
802/*
e8bc2b5c 803 * nextf[i] is the pointer to the next free block of size 2^i. The
8d063cd8
LW
804 * smallest allocatable block is 8 bytes. The overhead information
805 * precedes the data area returned to the user.
806 */
e8bc2b5c 807#define NBUCKETS (32*BUCKETS_PER_POW2 + 1)
8d063cd8 808static union overhead *nextf[NBUCKETS];
cf5c4ad8
PP
809
810#ifdef USE_PERL_SBRK
811#define sbrk(a) Perl_sbrk(a)
20ce7b12 812Malloc_t Perl_sbrk (int size);
8ac85365
NIS
813#else
814#ifdef DONT_DECLARE_STD
815#ifdef I_UNISTD
816#include <unistd.h>
817#endif
cf5c4ad8 818#else
52082926 819extern Malloc_t sbrk(int);
8ac85365 820#endif
cf5c4ad8 821#endif
8d063cd8 822
c07a80fd 823#ifdef DEBUGGING_MSTATS
8d063cd8
LW
824/*
825 * nmalloc[i] is the difference between the number of mallocs and frees
826 * for a given block size.
827 */
828static u_int nmalloc[NBUCKETS];
5f05dabc
PP
829static u_int sbrk_slack;
830static u_int start_slack;
8d063cd8
LW
831#endif
832
e8bc2b5c
GS
833static u_int goodsbrk;
834
760ac839 835#ifdef DEBUGGING
3541dd58
HM
836#undef ASSERT
837#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p)); else
cea2e8a9
GS
838static void
839botch(char *diag, char *s)
8d063cd8 840{
d720c441 841 PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
3028581b 842 PerlProc_abort();
8d063cd8
LW
843}
844#else
3541dd58 845#define ASSERT(p, diag)
8d063cd8
LW
846#endif
847
2304df62 848Malloc_t
86058a2d 849Perl_malloc(register size_t nbytes)
8d063cd8
LW
850{
851 register union overhead *p;
e8bc2b5c 852 register int bucket;
ee0007ab 853 register MEM_SIZE shiftr;
8d063cd8 854
c2a5c2d2 855#if defined(DEBUGGING) || defined(RCHECK)
ee0007ab 856 MEM_SIZE size = nbytes;
45d8adaa
LW
857#endif
858
e8bc2b5c 859 BARK_64K_LIMIT("Allocation",nbytes,nbytes);
45d8adaa
LW
860#ifdef DEBUGGING
861 if ((long)nbytes < 0)
cea2e8a9 862 croak("%s", "panic: malloc");
45d8adaa 863#endif
45d8adaa 864
741df71a 865 MALLOC_LOCK;
8d063cd8
LW
866 /*
867 * Convert amount of memory requested into
868 * closest block size stored in hash buckets
869 * which satisfies request. Account for
870 * space used per block for accounting.
871 */
cf5c4ad8 872#ifdef PACK_MALLOC
e8bc2b5c
GS
873# ifdef SMALL_BUCKET_VIA_TABLE
874 if (nbytes == 0)
875 bucket = MIN_BUCKET;
876 else if (nbytes <= SIZE_TABLE_MAX) {
877 bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT];
878 } else
879# else
043bf814
RB
880 if (nbytes == 0)
881 nbytes = 1;
e8bc2b5c
GS
882 if (nbytes <= MAX_POW2_ALGO) goto do_shifts;
883 else
884# endif
55497cff 885#endif
e8bc2b5c
GS
886 {
887 POW2_OPTIMIZE_ADJUST(nbytes);
888 nbytes += M_OVERHEAD;
889 nbytes = (nbytes + 3) &~ 3;
890 do_shifts:
891 shiftr = (nbytes - 1) >> START_SHIFT;
892 bucket = START_SHIFTS_BUCKET;
893 /* apart from this loop, this is O(1) */
894 while (shiftr >>= 1)
895 bucket += BUCKETS_PER_POW2;
cf5c4ad8 896 }
8d063cd8
LW
897 /*
898 * If nothing in hash bucket right now,
899 * request more memory from the system.
900 */
901 if (nextf[bucket] == NULL)
902 morecore(bucket);
e8bc2b5c 903 if ((p = nextf[bucket]) == NULL) {
741df71a 904 MALLOC_UNLOCK;
55497cff 905#ifdef PERL_CORE
0b250b9e
GS
906 {
907 dTHX;
908 if (!PL_nomemok) {
909 PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
910 my_exit(1);
911 }
ee0007ab 912 }
45d8adaa 913#else
8d063cd8 914 return (NULL);
45d8adaa
LW
915#endif
916 }
917
e8bc2b5c
GS
918 DEBUG_m(PerlIO_printf(Perl_debug_log,
919 "0x%lx: (%05lu) malloc %ld bytes\n",
4a33f861 920 (unsigned long)(p+1), (unsigned long)(PL_an++),
e8bc2b5c 921 (long)size));
45d8adaa 922
8d063cd8 923 /* remove from linked list */
802004fa 924#if defined(RCHECK)
56431972 925 if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1))
760ac839 926 PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n",
a0d0e21e 927 (unsigned long)*((int*)p),(unsigned long)p);
bf38876a
LW
928#endif
929 nextf[bucket] = p->ov_next;
e8bc2b5c
GS
930#ifdef IGNORE_SMALL_BAD_FREE
931 if (bucket >= FIRST_BUCKET_WITH_CHECK)
932#endif
933 OV_MAGIC(p, bucket) = MAGIC;
cf5c4ad8
PP
934#ifndef PACK_MALLOC
935 OV_INDEX(p) = bucket;
936#endif
8d063cd8
LW
937#ifdef RCHECK
938 /*
939 * Record allocated size of block and
940 * bound space with magic numbers.
941 */
8d063cd8 942 p->ov_rmagic = RMAGIC;
e8bc2b5c
GS
943 if (bucket <= MAX_SHORT_BUCKET) {
944 int i;
945
946 nbytes = size + M_OVERHEAD;
947 p->ov_size = nbytes - 1;
948 if ((i = nbytes & 3)) {
949 i = 4 - i;
950 while (i--)
951 *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C;
952 }
953 nbytes = (nbytes + 3) &~ 3;
954 *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
955 }
8d063cd8 956#endif
741df71a 957 MALLOC_UNLOCK;
cf5c4ad8 958 return ((Malloc_t)(p + CHUNK_SHIFT));
8d063cd8
LW
959}
960
e8bc2b5c
GS
961static char *last_sbrk_top;
962static char *last_op; /* This arena can be easily extended. */
963static int sbrked_remains;
964static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
965
966#ifdef DEBUGGING_MSTATS
967static int sbrks;
968#endif
969
970struct chunk_chain_s {
971 struct chunk_chain_s *next;
972 MEM_SIZE size;
973};
974static struct chunk_chain_s *chunk_chain;
975static int n_chunks;
976static char max_bucket;
977
978/* Cutoff a piece of one of the chunks in the chain. Prefer smaller chunk. */
cea2e8a9
GS
979static void *
980get_from_chain(MEM_SIZE size)
e8bc2b5c
GS
981{
982 struct chunk_chain_s *elt = chunk_chain, **oldp = &chunk_chain;
983 struct chunk_chain_s **oldgoodp = NULL;
984 long min_remain = LONG_MAX;
985
986 while (elt) {
987 if (elt->size >= size) {
988 long remains = elt->size - size;
989 if (remains >= 0 && remains < min_remain) {
990 oldgoodp = oldp;
991 min_remain = remains;
992 }
993 if (remains == 0) {
994 break;
995 }
996 }
997 oldp = &( elt->next );
998 elt = elt->next;
999 }
1000 if (!oldgoodp) return NULL;
1001 if (min_remain) {
1002 void *ret = *oldgoodp;
1003 struct chunk_chain_s *next = (*oldgoodp)->next;
1004
1005 *oldgoodp = (struct chunk_chain_s *)((char*)ret + size);
1006 (*oldgoodp)->size = min_remain;
1007 (*oldgoodp)->next = next;
1008 return ret;
1009 } else {
1010 void *ret = *oldgoodp;
1011 *oldgoodp = (*oldgoodp)->next;
1012 n_chunks--;
1013 return ret;
1014 }
1015}
1016
cea2e8a9
GS
1017static void
1018add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip)
e8bc2b5c
GS
1019{
1020 struct chunk_chain_s *next = chunk_chain;
1021 char *cp = (char*)p;
1022
1023 cp += chip;
1024 chunk_chain = (struct chunk_chain_s *)cp;
1025 chunk_chain->size = size - chip;
1026 chunk_chain->next = next;
1027 n_chunks++;
1028}
1029
cea2e8a9
GS
1030static void *
1031get_from_bigger_buckets(int bucket, MEM_SIZE size)
e8bc2b5c
GS
1032{
1033 int price = 1;
1034 static int bucketprice[NBUCKETS];
1035 while (bucket <= max_bucket) {
1036 /* We postpone stealing from bigger buckets until we want it
1037 often enough. */
1038 if (nextf[bucket] && bucketprice[bucket]++ >= price) {
1039 /* Steal it! */
1040 void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT);
1041 bucketprice[bucket] = 0;
1042 if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) {
1043 last_op = NULL; /* Disable optimization */
1044 }
1045 nextf[bucket] = nextf[bucket]->ov_next;
1046#ifdef DEBUGGING_MSTATS
1047 nmalloc[bucket]--;
1048 start_slack -= M_OVERHEAD;
1049#endif
1050 add_to_chain(ret, (BUCKET_SIZE(bucket) +
1051 POW2_OPTIMIZE_SURPLUS(bucket)),
1052 size);
1053 return ret;
1054 }
1055 bucket++;
1056 }
1057 return NULL;
1058}
1059
cea2e8a9
GS
1060static union overhead *
1061getpages(int needed, int *nblksp, int bucket)
fa423c5b
IZ
1062{
1063 /* Need to do (possibly expensive) system call. Try to
1064 optimize it for rare calling. */
1065 MEM_SIZE require = needed - sbrked_remains;
1066 char *cp;
1067 union overhead *ovp;
1068 int slack = 0;
1069
1070 if (sbrk_good > 0) {
1071 if (!last_sbrk_top && require < FIRST_SBRK)
1072 require = FIRST_SBRK;
1073 else if (require < MIN_SBRK) require = MIN_SBRK;
1074
1075 if (require < goodsbrk * MIN_SBRK_FRAC / 100)
1076 require = goodsbrk * MIN_SBRK_FRAC / 100;
1077 require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
1078 } else {
1079 require = needed;
1080 last_sbrk_top = 0;
1081 sbrked_remains = 0;
1082 }
1083
1084 DEBUG_m(PerlIO_printf(Perl_debug_log,
1085 "sbrk(%ld) for %ld-byte-long arena\n",
1086 (long)require, (long) needed));
1087 cp = (char *)sbrk(require);
1088#ifdef DEBUGGING_MSTATS
1089 sbrks++;
1090#endif
1091 if (cp == last_sbrk_top) {
1092 /* Common case, anything is fine. */
1093 sbrk_good++;
1094 ovp = (union overhead *) (cp - sbrked_remains);
e9397286 1095 last_op = cp - sbrked_remains;
fa423c5b
IZ
1096 sbrked_remains = require - (needed - sbrked_remains);
1097 } else if (cp == (char *)-1) { /* no more room! */
1098 ovp = (union overhead *)emergency_sbrk(needed);
1099 if (ovp == (union overhead *)-1)
1100 return 0;
e9397286
GS
1101 if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */
1102 last_op = 0;
1103 }
fa423c5b
IZ
1104 return ovp;
1105 } else { /* Non-continuous or first sbrk(). */
1106 long add = sbrked_remains;
1107 char *newcp;
1108
1109 if (sbrked_remains) { /* Put rest into chain, we
1110 cannot use it right now. */
1111 add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1112 sbrked_remains, 0);
1113 }
1114
1115 /* Second, check alignment. */
1116 slack = 0;
1117
61ae2fbf 1118#if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */
fa423c5b 1119# ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */
5bbd1ef5
IZ
1120 /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may
1121 improve performance of memory access. */
56431972
RB
1122 if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */
1123 slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1));
fa423c5b
IZ
1124 add += slack;
1125 }
1126# endif
61ae2fbf 1127#endif /* !atarist && !MINT */
fa423c5b
IZ
1128
1129 if (add) {
1130 DEBUG_m(PerlIO_printf(Perl_debug_log,
1131 "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",
1132 (long)add, (long) slack,
1133 (long) sbrked_remains));
1134 newcp = (char *)sbrk(add);
1135#if defined(DEBUGGING_MSTATS)
1136 sbrks++;
1137 sbrk_slack += add;
1138#endif
1139 if (newcp != cp + require) {
1140 /* Too bad: even rounding sbrk() is not continuous.*/
1141 DEBUG_m(PerlIO_printf(Perl_debug_log,
1142 "failed to fix bad sbrk()\n"));
1143#ifdef PACK_MALLOC
1144 if (slack) {
741df71a 1145 MALLOC_UNLOCK;
5bbd1ef5 1146 fatalcroak("panic: Off-page sbrk\n");
fa423c5b
IZ
1147 }
1148#endif
1149 if (sbrked_remains) {
1150 /* Try again. */
1151#if defined(DEBUGGING_MSTATS)
1152 sbrk_slack += require;
1153#endif
1154 require = needed;
1155 DEBUG_m(PerlIO_printf(Perl_debug_log,
1156 "straight sbrk(%ld)\n",
1157 (long)require));
1158 cp = (char *)sbrk(require);
1159#ifdef DEBUGGING_MSTATS
1160 sbrks++;
1161#endif
1162 if (cp == (char *)-1)
1163 return 0;
1164 }
1165 sbrk_good = -1; /* Disable optimization!
1166 Continue with not-aligned... */
1167 } else {
1168 cp += slack;
1169 require += sbrked_remains;
1170 }
1171 }
1172
1173 if (last_sbrk_top) {
1174 sbrk_good -= SBRK_FAILURE_PRICE;
1175 }
1176
1177 ovp = (union overhead *) cp;
1178 /*
1179 * Round up to minimum allocation size boundary
1180 * and deduct from block count to reflect.
1181 */
1182
5bbd1ef5 1183# if NEEDED_ALIGNMENT > MEM_ALIGNBYTES
56431972 1184 if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1))
5bbd1ef5
IZ
1185 fatalcroak("Misalignment of sbrk()\n");
1186 else
1187# endif
fa423c5b 1188#ifndef I286 /* Again, this should always be ok on an 80286 */
56431972 1189 if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) {
fa423c5b
IZ
1190 DEBUG_m(PerlIO_printf(Perl_debug_log,
1191 "fixing sbrk(): %d bytes off machine alignement\n",
56431972
RB
1192 (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1))));
1193 ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) &
5bbd1ef5 1194 (MEM_ALIGNBYTES - 1));
fa423c5b
IZ
1195 (*nblksp)--;
1196# if defined(DEBUGGING_MSTATS)
1197 /* This is only approx. if TWO_POT_OPTIMIZE: */
5bbd1ef5 1198 sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
fa423c5b
IZ
1199# endif
1200 }
1201#endif
5bbd1ef5 1202 ; /* Finish `else' */
fa423c5b 1203 sbrked_remains = require - needed;
e9397286 1204 last_op = cp;
fa423c5b
IZ
1205 }
1206 last_sbrk_top = cp + require;
fa423c5b
IZ
1207#ifdef DEBUGGING_MSTATS
1208 goodsbrk += require;
1209#endif
1210 return ovp;
1211}
1212
cea2e8a9
GS
1213static int
1214getpages_adjacent(int require)
fa423c5b
IZ
1215{
1216 if (require <= sbrked_remains) {
1217 sbrked_remains -= require;
1218 } else {
1219 char *cp;
1220
1221 require -= sbrked_remains;
1222 /* We do not try to optimize sbrks here, we go for place. */
1223 cp = (char*) sbrk(require);
1224#ifdef DEBUGGING_MSTATS
1225 sbrks++;
1226 goodsbrk += require;
1227#endif
1228 if (cp == last_sbrk_top) {
1229 sbrked_remains = 0;
1230 last_sbrk_top = cp + require;
1231 } else {
28ac10b1
IZ
1232 if (cp == (char*)-1) { /* Out of memory */
1233#ifdef DEBUGGING_MSTATS
1234 goodsbrk -= require;
1235#endif
1236 return 0;
1237 }
fa423c5b
IZ
1238 /* Report the failure: */
1239 if (sbrked_remains)
1240 add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1241 sbrked_remains, 0);
1242 add_to_chain((void*)cp, require, 0);
1243 sbrk_good -= SBRK_FAILURE_PRICE;
1244 sbrked_remains = 0;
1245 last_sbrk_top = 0;
1246 last_op = 0;
1247 return 0;
1248 }
1249 }
1250
1251 return 1;
1252}
1253
8d063cd8
LW
1254/*
1255 * Allocate more memory to the indicated bucket.
1256 */
cea2e8a9
GS
1257static void
1258morecore(register int bucket)
8d063cd8 1259{
72aaf631 1260 register union overhead *ovp;
8d063cd8 1261 register int rnu; /* 2^rnu bytes will be requested */
fa423c5b 1262 int nblks; /* become nblks blocks of the desired size */
bbce6d69 1263 register MEM_SIZE siz, needed;
8d063cd8
LW
1264
1265 if (nextf[bucket])
1266 return;
e8bc2b5c 1267 if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
741df71a 1268 MALLOC_UNLOCK;
d720c441 1269 croak("%s", "Out of memory during ridiculously large request");
55497cff 1270 }
d720c441 1271 if (bucket > max_bucket)
e8bc2b5c 1272 max_bucket = bucket;
d720c441 1273
e8bc2b5c
GS
1274 rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT))
1275 ? LOG_OF_MIN_ARENA
1276 : (bucket >> BUCKET_POW2_SHIFT) );
1277 /* This may be overwritten later: */
1278 nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */
1279 needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket);
1280 if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */
1281 ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT;
1282 nextf[rnu << BUCKET_POW2_SHIFT]
1283 = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next;
1284#ifdef DEBUGGING_MSTATS
1285 nmalloc[rnu << BUCKET_POW2_SHIFT]--;
1286 start_slack -= M_OVERHEAD;
1287#endif
1288 DEBUG_m(PerlIO_printf(Perl_debug_log,
1289 "stealing %ld bytes from %ld arena\n",
1290 (long) needed, (long) rnu << BUCKET_POW2_SHIFT));
1291 } else if (chunk_chain
1292 && (ovp = (union overhead*) get_from_chain(needed))) {
1293 DEBUG_m(PerlIO_printf(Perl_debug_log,
1294 "stealing %ld bytes from chain\n",
1295 (long) needed));
d720c441
IZ
1296 } else if ( (ovp = (union overhead*)
1297 get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
1298 needed)) ) {
e8bc2b5c
GS
1299 DEBUG_m(PerlIO_printf(Perl_debug_log,
1300 "stealing %ld bytes from bigger buckets\n",
1301 (long) needed));
1302 } else if (needed <= sbrked_remains) {
1303 ovp = (union overhead *)(last_sbrk_top - sbrked_remains);
1304 sbrked_remains -= needed;
1305 last_op = (char*)ovp;
fa423c5b
IZ
1306 } else
1307 ovp = getpages(needed, &nblks, bucket);
e8bc2b5c 1308
fa423c5b
IZ
1309 if (!ovp)
1310 return;
e8bc2b5c 1311
8d063cd8
LW
1312 /*
1313 * Add new memory allocated to that on
1314 * free list for this hash bucket.
1315 */
e8bc2b5c 1316 siz = BUCKET_SIZE(bucket);
cf5c4ad8 1317#ifdef PACK_MALLOC
72aaf631 1318 *(u_char*)ovp = bucket; /* Fill index. */
e8bc2b5c
GS
1319 if (bucket <= MAX_PACKED) {
1320 ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1321 nblks = N_BLKS(bucket);
cf5c4ad8 1322# ifdef DEBUGGING_MSTATS
e8bc2b5c 1323 start_slack += BLK_SHIFT(bucket);
cf5c4ad8 1324# endif
e8bc2b5c
GS
1325 } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) {
1326 ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
cf5c4ad8 1327 siz -= sizeof(union overhead);
72aaf631 1328 } else ovp++; /* One chunk per block. */
e8bc2b5c 1329#endif /* PACK_MALLOC */
72aaf631 1330 nextf[bucket] = ovp;
5f05dabc
PP
1331#ifdef DEBUGGING_MSTATS
1332 nmalloc[bucket] += nblks;
e8bc2b5c
GS
1333 if (bucket > MAX_PACKED) {
1334 start_slack += M_OVERHEAD * nblks;
1335 }
5f05dabc 1336#endif
8d063cd8 1337 while (--nblks > 0) {
72aaf631
MB
1338 ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
1339 ovp = (union overhead *)((caddr_t)ovp + siz);
8d063cd8 1340 }
8595d6f1 1341 /* Not all sbrks return zeroed memory.*/
72aaf631 1342 ovp->ov_next = (union overhead *)NULL;
cf5c4ad8 1343#ifdef PACK_MALLOC
e8bc2b5c
GS
1344 if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */
1345 union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next;
1346 nextf[7*BUCKETS_PER_POW2] =
1347 (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2]
1348 - sizeof(union overhead));
1349 nextf[7*BUCKETS_PER_POW2]->ov_next = n_op;
cf5c4ad8
PP
1350 }
1351#endif /* !PACK_MALLOC */
8d063cd8
LW
1352}
1353
94b6baf5 1354Free_t
86058a2d 1355Perl_mfree(void *mp)
cea2e8a9 1356{
ee0007ab 1357 register MEM_SIZE size;
72aaf631 1358 register union overhead *ovp;
352d5a3a 1359 char *cp = (char*)mp;
cf5c4ad8
PP
1360#ifdef PACK_MALLOC
1361 u_char bucket;
1362#endif
8d063cd8 1363
e8bc2b5c
GS
1364 DEBUG_m(PerlIO_printf(Perl_debug_log,
1365 "0x%lx: (%05lu) free\n",
4a33f861 1366 (unsigned long)cp, (unsigned long)(PL_an++)));
45d8adaa 1367
cf5c4ad8
PP
1368 if (cp == NULL)
1369 return;
72aaf631 1370 ovp = (union overhead *)((caddr_t)cp
e8bc2b5c 1371 - sizeof (union overhead) * CHUNK_SHIFT);
cf5c4ad8 1372#ifdef PACK_MALLOC
72aaf631 1373 bucket = OV_INDEX(ovp);
cf5c4ad8 1374#endif
e8bc2b5c
GS
1375#ifdef IGNORE_SMALL_BAD_FREE
1376 if ((bucket >= FIRST_BUCKET_WITH_CHECK)
1377 && (OV_MAGIC(ovp, bucket) != MAGIC))
1378#else
1379 if (OV_MAGIC(ovp, bucket) != MAGIC)
1380#endif
1381 {
68dc0745 1382 static int bad_free_warn = -1;
cf5c4ad8 1383 if (bad_free_warn == -1) {
5fd9e9a4 1384 char *pbf = PerlEnv_getenv("PERL_BADFREE");
cf5c4ad8
PP
1385 bad_free_warn = (pbf) ? atoi(pbf) : 1;
1386 }
1387 if (!bad_free_warn)
1388 return;
8990e307 1389#ifdef RCHECK
a687059c 1390 warn("%s free() ignored",
72aaf631 1391 ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
8990e307 1392#else
d720c441 1393 warn("%s", "Bad free() ignored");
8990e307 1394#endif
8d063cd8 1395 return; /* sanity */
e8bc2b5c 1396 }
741df71a 1397 MALLOC_LOCK;
8d063cd8 1398#ifdef RCHECK
3541dd58 1399 ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
e8bc2b5c
GS
1400 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
1401 int i;
1402 MEM_SIZE nbytes = ovp->ov_size + 1;
1403
1404 if ((i = nbytes & 3)) {
1405 i = 4 - i;
1406 while (i--) {
3541dd58 1407 ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
d720c441 1408 == RMAGIC_C, "chunk's tail overwrite");
e8bc2b5c
GS
1409 }
1410 }
1411 nbytes = (nbytes + 3) &~ 3;
3541dd58 1412 ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite");
e8bc2b5c 1413 }
72aaf631 1414 ovp->ov_rmagic = RMAGIC - 1;
8d063cd8 1415#endif
3541dd58 1416 ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
72aaf631
MB
1417 size = OV_INDEX(ovp);
1418 ovp->ov_next = nextf[size];
1419 nextf[size] = ovp;
741df71a 1420 MALLOC_UNLOCK;
8d063cd8
LW
1421}
1422
1423/*
1424 * When a program attempts "storage compaction" as mentioned in the
1425 * old malloc man page, it realloc's an already freed block. Usually
1426 * this is the last block it freed; occasionally it might be farther
1427 * back. We have to search all the free lists for the block in order
1428 * to determine its bucket: 1st we make one pass thru the lists
1429 * checking only the first block in each; if that fails we search
378cc40b 1430 * ``reall_srchlen'' blocks in each list for a match (the variable
8d063cd8
LW
1431 * is extern so the caller can modify it). If that fails we just copy
1432 * however many bytes was given to realloc() and hope it's not huge.
1433 */
22c35a8c 1434#define reall_srchlen 4 /* 4 should be plenty, -1 =>'s whole list */
8d063cd8 1435
2304df62 1436Malloc_t
86058a2d 1437Perl_realloc(void *mp, size_t nbytes)
cea2e8a9 1438{
ee0007ab 1439 register MEM_SIZE onb;
72aaf631 1440 union overhead *ovp;
d720c441
IZ
1441 char *res;
1442 int prev_bucket;
e8bc2b5c
GS
1443 register int bucket;
1444 int was_alloced = 0, incr;
352d5a3a 1445 char *cp = (char*)mp;
8d063cd8 1446
e8bc2b5c 1447#if defined(DEBUGGING) || !defined(PERL_CORE)
ee0007ab 1448 MEM_SIZE size = nbytes;
45d8adaa 1449
45d8adaa 1450 if ((long)nbytes < 0)
cea2e8a9 1451 croak("%s", "panic: realloc");
45d8adaa 1452#endif
e8bc2b5c
GS
1453
1454 BARK_64K_LIMIT("Reallocation",nbytes,size);
1455 if (!cp)
86058a2d 1456 return Perl_malloc(nbytes);
45d8adaa 1457
741df71a 1458 MALLOC_LOCK;
72aaf631 1459 ovp = (union overhead *)((caddr_t)cp
e8bc2b5c
GS
1460 - sizeof (union overhead) * CHUNK_SHIFT);
1461 bucket = OV_INDEX(ovp);
1462#ifdef IGNORE_SMALL_BAD_FREE
1463 if ((bucket < FIRST_BUCKET_WITH_CHECK)
1464 || (OV_MAGIC(ovp, bucket) == MAGIC))
1465#else
1466 if (OV_MAGIC(ovp, bucket) == MAGIC)
1467#endif
1468 {
55497cff 1469 was_alloced = 1;
8d063cd8
LW
1470 } else {
1471 /*
1472 * Already free, doing "compaction".
1473 *
1474 * Search for the old block of memory on the
1475 * free list. First, check the most common
1476 * case (last element free'd), then (this failing)
378cc40b 1477 * the last ``reall_srchlen'' items free'd.
8d063cd8
LW
1478 * If all lookups fail, then assume the size of
1479 * the memory block being realloc'd is the
1480 * smallest possible.
1481 */
e8bc2b5c
GS
1482 if ((bucket = findbucket(ovp, 1)) < 0 &&
1483 (bucket = findbucket(ovp, reall_srchlen)) < 0)
1484 bucket = 0;
8d063cd8 1485 }
e8bc2b5c 1486 onb = BUCKET_SIZE_REAL(bucket);
55497cff
PP
1487 /*
1488 * avoid the copy if same size block.
e8bc2b5c
GS
1489 * We are not agressive with boundary cases. Note that it might
1490 * (for a small number of cases) give false negative if
55497cff 1491 * both new size and old one are in the bucket for
e8bc2b5c
GS
1492 * FIRST_BIG_POW2, but the new one is near the lower end.
1493 *
1494 * We do not try to go to 1.5 times smaller bucket so far.
55497cff 1495 */
e8bc2b5c
GS
1496 if (nbytes > onb) incr = 1;
1497 else {
1498#ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING
1499 if ( /* This is a little bit pessimal if PACK_MALLOC: */
1500 nbytes > ( (onb >> 1) - M_OVERHEAD )
1501# ifdef TWO_POT_OPTIMIZE
1502 || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND )
1503# endif
1504 )
1505#else /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1506 prev_bucket = ( (bucket > MAX_PACKED + 1)
1507 ? bucket - BUCKETS_PER_POW2
1508 : bucket - 1);
1509 if (nbytes > BUCKET_SIZE_REAL(prev_bucket))
1510#endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1511 incr = 0;
1512 else incr = -1;
1513 }
1514 if (!was_alloced
2ce36478 1515#ifdef STRESS_REALLOC
e8bc2b5c 1516 || 1 /* always do it the hard way */
2ce36478 1517#endif
e8bc2b5c
GS
1518 ) goto hard_way;
1519 else if (incr == 0) {
852c2e52 1520 inplace_label:
a687059c
LW
1521#ifdef RCHECK
1522 /*
1523 * Record new allocated size of block and
1524 * bound space with magic numbers.
1525 */
72aaf631 1526 if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
e8bc2b5c
GS
1527 int i, nb = ovp->ov_size + 1;
1528
1529 if ((i = nb & 3)) {
1530 i = 4 - i;
1531 while (i--) {
3541dd58 1532 ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite");
e8bc2b5c
GS
1533 }
1534 }
1535 nb = (nb + 3) &~ 3;
3541dd58 1536 ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite");
a687059c
LW
1537 /*
1538 * Convert amount of memory requested into
1539 * closest block size stored in hash buckets
1540 * which satisfies request. Account for
1541 * space used per block for accounting.
1542 */
cf5c4ad8 1543 nbytes += M_OVERHEAD;
72aaf631 1544 ovp->ov_size = nbytes - 1;
e8bc2b5c
GS
1545 if ((i = nbytes & 3)) {
1546 i = 4 - i;
1547 while (i--)
1548 *((char *)((caddr_t)ovp + nbytes - RSLOP + i))
1549 = RMAGIC_C;
1550 }
1551 nbytes = (nbytes + 3) &~ 3;
72aaf631 1552 *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
a687059c
LW
1553 }
1554#endif
45d8adaa 1555 res = cp;
741df71a 1556 MALLOC_UNLOCK;
42ac124e
IZ
1557 DEBUG_m(PerlIO_printf(Perl_debug_log,
1558 "0x%lx: (%05lu) realloc %ld bytes inplace\n",
1559 (unsigned long)res,(unsigned long)(PL_an++),
1560 (long)size));
e8bc2b5c
GS
1561 } else if (incr == 1 && (cp - M_OVERHEAD == last_op)
1562 && (onb > (1 << LOG_OF_MIN_ARENA))) {
1563 MEM_SIZE require, newarena = nbytes, pow;
1564 int shiftr;
1565
1566 POW2_OPTIMIZE_ADJUST(newarena);
1567 newarena = newarena + M_OVERHEAD;
1568 /* newarena = (newarena + 3) &~ 3; */
1569 shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA;
1570 pow = LOG_OF_MIN_ARENA + 1;
1571 /* apart from this loop, this is O(1) */
1572 while (shiftr >>= 1)
1573 pow++;
1574 newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2);
1575 require = newarena - onb - M_OVERHEAD;
1576
fa423c5b 1577 if (getpages_adjacent(require)) {
e8bc2b5c 1578#ifdef DEBUGGING_MSTATS
fa423c5b
IZ
1579 nmalloc[bucket]--;
1580 nmalloc[pow * BUCKETS_PER_POW2]++;
e8bc2b5c 1581#endif
fa423c5b
IZ
1582 *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
1583 goto inplace_label;
1584 } else
1585 goto hard_way;
e8bc2b5c
GS
1586 } else {
1587 hard_way:
741df71a 1588 MALLOC_UNLOCK;
42ac124e
IZ
1589 DEBUG_m(PerlIO_printf(Perl_debug_log,
1590 "0x%lx: (%05lu) realloc %ld bytes the hard way\n",
1591 (unsigned long)cp,(unsigned long)(PL_an++),
1592 (long)size));
86058a2d 1593 if ((res = (char*)Perl_malloc(nbytes)) == NULL)
e8bc2b5c
GS
1594 return (NULL);
1595 if (cp != res) /* common optimization */
1596 Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
1597 if (was_alloced)
86058a2d 1598 Perl_mfree(cp);
45d8adaa 1599 }
2304df62 1600 return ((Malloc_t)res);
8d063cd8
LW
1601}
1602
1603/*
1604 * Search ``srchlen'' elements of each free list for a block whose
1605 * header starts at ``freep''. If srchlen is -1 search the whole list.
1606 * Return bucket number, or -1 if not found.
1607 */
ee0007ab 1608static int
8ac85365 1609findbucket(union overhead *freep, int srchlen)
8d063cd8
LW
1610{
1611 register union overhead *p;
1612 register int i, j;
1613
1614 for (i = 0; i < NBUCKETS; i++) {
1615 j = 0;
1616 for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
1617 if (p == freep)
1618 return (i);
1619 j++;
1620 }
1621 }
1622 return (-1);
1623}
1624
cf5c4ad8 1625Malloc_t
86058a2d 1626Perl_calloc(register size_t elements, register size_t size)
cf5c4ad8
PP
1627{
1628 long sz = elements * size;
86058a2d 1629 Malloc_t p = Perl_malloc(sz);
cf5c4ad8
PP
1630
1631 if (p) {
1632 memset((void*)p, 0, sz);
1633 }
1634 return p;
1635}
1636
e8bc2b5c 1637MEM_SIZE
cea2e8a9 1638Perl_malloced_size(void *p)
e8bc2b5c 1639{
8d6dde3e
IZ
1640 union overhead *ovp = (union overhead *)
1641 ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
1642 int bucket = OV_INDEX(ovp);
1643#ifdef RCHECK
1644 /* The caller wants to have a complete control over the chunk,
1645 disable the memory checking inside the chunk. */
1646 if (bucket <= MAX_SHORT_BUCKET) {
1647 MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
1648 ovp->ov_size = size + M_OVERHEAD - 1;
1649 *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC;
1650 }
1651#endif
e8bc2b5c
GS
1652 return BUCKET_SIZE_REAL(bucket);
1653}
1654
e8bc2b5c
GS
1655# ifdef BUCKETS_ROOT2
1656# define MIN_EVEN_REPORT 6
1657# else
1658# define MIN_EVEN_REPORT MIN_BUCKET
1659# endif
8d063cd8
LW
1660/*
1661 * mstats - print out statistics about malloc
1662 *
1663 * Prints two lines of numbers, one showing the length of the free list
1664 * for each size category, the second showing the number of mallocs -
1665 * frees for each size category.
1666 */
ee0007ab 1667void
864dbfa3 1668Perl_dump_mstats(pTHX_ char *s)
8d063cd8 1669{
df31f264 1670#ifdef DEBUGGING_MSTATS
8d063cd8
LW
1671 register int i, j;
1672 register union overhead *p;
e8bc2b5c 1673 int topbucket=0, topbucket_ev=0, topbucket_odd=0, totfree=0, total=0;
c07a80fd 1674 u_int nfree[NBUCKETS];
e8bc2b5c
GS
1675 int total_chain = 0;
1676 struct chunk_chain_s* nextchain = chunk_chain;
8d063cd8 1677
e8bc2b5c 1678 for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
8d063cd8
LW
1679 for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
1680 ;
c07a80fd 1681 nfree[i] = j;
e8bc2b5c
GS
1682 totfree += nfree[i] * BUCKET_SIZE_REAL(i);
1683 total += nmalloc[i] * BUCKET_SIZE_REAL(i);
1684 if (nmalloc[i]) {
1685 i % 2 ? (topbucket_odd = i) : (topbucket_ev = i);
1686 topbucket = i;
1687 }
c07a80fd
PP
1688 }
1689 if (s)
e8bc2b5c 1690 PerlIO_printf(PerlIO_stderr(),
d720c441 1691 "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n",
e8bc2b5c 1692 s,
d720c441
IZ
1693 (long)BUCKET_SIZE_REAL(MIN_BUCKET),
1694 (long)BUCKET_SIZE(MIN_BUCKET),
1695 (long)BUCKET_SIZE_REAL(topbucket), (long)BUCKET_SIZE(topbucket));
5f05dabc 1696 PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree);
e8bc2b5c
GS
1697 for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
1698 PerlIO_printf(PerlIO_stderr(),
1699 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1700 ? " %5d"
1701 : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1702 nfree[i]);
1703 }
1704#ifdef BUCKETS_ROOT2
1705 PerlIO_printf(PerlIO_stderr(), "\n\t ");
1706 for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
1707 PerlIO_printf(PerlIO_stderr(),
1708 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1709 ? " %5d"
1710 : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1711 nfree[i]);
8d063cd8 1712 }
e8bc2b5c 1713#endif
5f05dabc 1714 PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree);
e8bc2b5c
GS
1715 for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
1716 PerlIO_printf(PerlIO_stderr(),
1717 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1718 ? " %5d"
1719 : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1720 nmalloc[i] - nfree[i]);
c07a80fd 1721 }
e8bc2b5c
GS
1722#ifdef BUCKETS_ROOT2
1723 PerlIO_printf(PerlIO_stderr(), "\n\t ");
1724 for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
1725 PerlIO_printf(PerlIO_stderr(),
1726 ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1727 ? " %5d"
1728 : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1729 nmalloc[i] - nfree[i]);
1730 }
1731#endif
1732 while (nextchain) {
1733 total_chain += nextchain->size;
1734 nextchain = nextchain->next;
1735 }
1736 PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %d/%d:%d. Odd ends: pad+heads+chain+tail: %d+%d+%d+%d.\n",
1737 goodsbrk + sbrk_slack, sbrks, sbrk_good, sbrk_slack,
1738 start_slack, total_chain, sbrked_remains);
df31f264 1739#endif /* DEBUGGING_MSTATS */
c07a80fd 1740}
a687059c 1741#endif /* lint */
cf5c4ad8 1742
cf5c4ad8
PP
1743#ifdef USE_PERL_SBRK
1744
8f1f23e8 1745# if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__)
38ac2dc8
DD
1746# define PERL_SBRK_VIA_MALLOC
1747/*
1748 * MachTen's malloc() returns a buffer aligned on a two-byte boundary.
1749 * While this is adequate, it may slow down access to longer data
1750 * types by forcing multiple memory accesses. It also causes
1751 * complaints when RCHECK is in force. So we allocate six bytes
1752 * more than we need to, and return an address rounded up to an
1753 * eight-byte boundary.
1754 *
1755 * 980701 Dominic Dunlop <domo@computer.org>
1756 */
5bbd1ef5 1757# define SYSTEM_ALLOC_ALIGNMENT 2
38ac2dc8
DD
1758# endif
1759
760ac839 1760# ifdef PERL_SBRK_VIA_MALLOC
cf5c4ad8
PP
1761
1762/* it may seem schizophrenic to use perl's malloc and let it call system */
1763/* malloc, the reason for that is only the 3.2 version of the OS that had */
1764/* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
1765/* end to the cores */
1766
38ac2dc8
DD
1767# ifndef SYSTEM_ALLOC
1768# define SYSTEM_ALLOC(a) malloc(a)
1769# endif
5bbd1ef5
IZ
1770# ifndef SYSTEM_ALLOC_ALIGNMENT
1771# define SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES
1772# endif
cf5c4ad8 1773
760ac839 1774# endif /* PERL_SBRK_VIA_MALLOC */
cf5c4ad8
PP
1775
1776static IV Perl_sbrk_oldchunk;
1777static long Perl_sbrk_oldsize;
1778
760ac839
LW
1779# define PERLSBRK_32_K (1<<15)
1780# define PERLSBRK_64_K (1<<16)
cf5c4ad8 1781
b63effbb 1782Malloc_t
df0003d4 1783Perl_sbrk(int size)
cf5c4ad8
PP
1784{
1785 IV got;
1786 int small, reqsize;
1787
1788 if (!size) return 0;
55497cff 1789#ifdef PERL_CORE
cf5c4ad8
PP
1790 reqsize = size; /* just for the DEBUG_m statement */
1791#endif
57569e04
HM
1792#ifdef PACK_MALLOC
1793 size = (size + 0x7ff) & ~0x7ff;
1794#endif
cf5c4ad8
PP
1795 if (size <= Perl_sbrk_oldsize) {
1796 got = Perl_sbrk_oldchunk;
1797 Perl_sbrk_oldchunk += size;
1798 Perl_sbrk_oldsize -= size;
1799 } else {
1800 if (size >= PERLSBRK_32_K) {
1801 small = 0;
1802 } else {
cf5c4ad8
PP
1803 size = PERLSBRK_64_K;
1804 small = 1;
1805 }
5bbd1ef5
IZ
1806# if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
1807 size += NEEDED_ALIGNMENT - SYSTEM_ALLOC_ALIGNMENT;
1808# endif
cf5c4ad8 1809 got = (IV)SYSTEM_ALLOC(size);
5bbd1ef5 1810# if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
5a7d6335 1811 got = (got + NEEDED_ALIGNMENT - 1) & ~(NEEDED_ALIGNMENT - 1);
5bbd1ef5 1812# endif
cf5c4ad8
PP
1813 if (small) {
1814 /* Chunk is small, register the rest for future allocs. */
1815 Perl_sbrk_oldchunk = got + reqsize;
1816 Perl_sbrk_oldsize = size - reqsize;
1817 }
1818 }
1819
fb73857a 1820 DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
cf5c4ad8 1821 size, reqsize, Perl_sbrk_oldsize, got));
cf5c4ad8
PP
1822
1823 return (void *)got;
1824}
1825
1826#endif /* ! defined USE_PERL_SBRK */