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