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