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