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