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