source: git/omalloc/pmalloc.c @ 8627ad

spielwiese
Last change on this file since 8627ad was 13fe1b, checked in by Hans Schönemann <hannes@…>, 23 years ago
*hannes: DecAlpha-ccc-port git-svn-id: file:///usr/local/Singular/svn/trunk@5409 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 47.8 KB
Line 
1/*******************************************************************
2 *  File:    pmalloc.h
3 *  Purpose: implementation of malloc from Perl's 5.005 distribution
4 *
5 *  Version: $Id: pmalloc.c,v 1.4 2001-04-30 09:02:15 Singular Exp $
6 *******************************************************************/
7
8#include "omMalloc.h"
9
10
11/*    malloc.c
12 *
13 */
14
15/*
16  Here are some notes on configuring Perl's malloc.
17
18  There are two macros which serve as bulk disablers of advanced
19  features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by
20  default).  Look in the list of default values below to understand
21  their exact effect.  Defining NO_FANCY_MALLOC returns malloc.c to the
22  state of the malloc in Perl 5.004.  Additionally defining PLAIN_MALLOC
23  returns it to the state as of Perl 5.000.
24
25  Note that some of the settings below may be ignored in the code based
26  on values of other macros.  The PERL_CORE symbol is only defined when
27  perl itself is being compiled (so malloc can make some assumptions
28  about perl's facilities being available to it).
29
30  Each config option has a short description, followed by its name,
31  default value, and a comment about the default (if applicable).  Some
32  options take a precise value, while the others are just boolean.
33  The boolean ones are listed first.
34
35    # Enable code for an emergency memory pool in $^M.  See perlvar.pod
36    # for a description of $^M.
37    PERL_EMERGENCY_SBRK         (!PLAIN_MALLOC && PERL_CORE)
38
39    # Enable code for printing memory statistics.
40    DEBUGGING_MSTATS            (!PLAIN_MALLOC && PERL_CORE)
41
42    # Move allocation info for small buckets into separate areas.
43    # Memory optimization (especially for small allocations, of the
44    # less than 64 bytes).  Since perl usually makes a large number
45    # of small allocations, this is usually a win.
46    PACK_MALLOC                 (!PLAIN_MALLOC && !RCHECK)
47
48    # Add one page to big powers of two when calculating bucket size.
49    # This is targeted at big allocations, as are common in image
50    # processing.
51    TWO_POT_OPTIMIZE            !PLAIN_MALLOC
52
53    # Use intermediate bucket sizes between powers-of-two.  This is
54    # generally a memory optimization, and a (small) speed pessimization.
55    BUCKETS_ROOT2               !NO_FANCY_MALLOC
56
57    # Do not check small deallocations for bad free().  Memory
58    # and speed optimization, error reporting pessimization.
59    IGNORE_SMALL_BAD_FREE       (!NO_FANCY_MALLOC && !RCHECK)
60
61    # Use table lookup to decide in which bucket a given allocation will go.
62    SMALL_BUCKET_VIA_TABLE      !NO_FANCY_MALLOC
63
64    # Use a perl-defined sbrk() instead of the (presumably broken or
65    # missing) system-supplied sbrk().
66    USE_PERL_SBRK               undef
67
68    # Use system malloc() (or calloc() etc.) to emulate sbrk(). Normally
69    # only used with broken sbrk()s.
70    PERL_SBRK_VIA_MALLOC        undef
71
72    # Which allocator to use if PERL_SBRK_VIA_MALLOC
73    SYSTEM_ALLOC(a)             malloc(a)
74
75    # Disable memory overwrite checking with DEBUGGING.  Memory and speed
76    # optimization, error reporting pessimization.
77    NO_RCHECK                   undef
78
79    # Enable memory overwrite checking with DEBUGGING.  Memory and speed
80    # pessimization, error reporting optimization
81    RCHECK                      (DEBUGGING && !NO_RCHECK)
82
83    # Failed allocations bigger than this size croak (if
84    # PERL_EMERGENCY_SBRK is enabled) without touching $^M.  See
85    # perlvar.pod for a description of $^M.
86    BIG_SIZE                     (1<<16)        # 64K
87
88    # Starting from this power of two, add an extra page to the
89    # size of the bucket. This enables optimized allocations of sizes
90    # close to powers of 2.  Note that the value is indexed at 0.
91    FIRST_BIG_POW2              15              # 32K, 16K is used too often
92
93    # Estimate of minimal memory footprint.  malloc uses this value to
94    # request the most reasonable largest blocks of memory from the system.
95    FIRST_SBRK                  (48*1024)
96
97    # Round up sbrk()s to multiples of this.
98    MIN_SBRK                    2048
99
100    # Round up sbrk()s to multiples of this percent of footprint.
101    MIN_SBRK_FRAC               3
102
103    # Add this much memory to big powers of two to get the bucket size.
104    PERL_PAGESIZE               4096
105
106    # This many sbrk() discontinuities should be tolerated even
107    # from the start without deciding that sbrk() is usually
108    # discontinuous.
109    SBRK_ALLOW_FAILURES         3
110
111    # This many continuous sbrk()s compensate for one discontinuous one.
112    SBRK_FAILURE_PRICE          50
113
114    # Some configurations may ask for 12-byte-or-so allocations which
115    # require 8-byte alignment (?!).  In such situation one needs to
116    # define this to disable 12-byte bucket (will increase memory footprint)
117    STRICT_ALIGNMENT            undef
118
119  This implementation assumes that calling PerlIO_printf() does not
120  result in any memory allocation calls (used during a panic).
121
122 */
123
124#ifndef NO_FANCY_MALLOC
125#  ifndef SMALL_BUCKET_VIA_TABLE
126#    define SMALL_BUCKET_VIA_TABLE
127#  endif
128#  ifndef BUCKETS_ROOT2
129#    define BUCKETS_ROOT2
130#  endif
131#  ifndef IGNORE_SMALL_BAD_FREE
132#    define IGNORE_SMALL_BAD_FREE
133#  endif
134#endif
135
136#ifndef PLAIN_MALLOC                    /* Bulk enable features */
137#  ifndef PACK_MALLOC
138#      define PACK_MALLOC
139#  endif
140#  ifndef TWO_POT_OPTIMIZE
141#    define TWO_POT_OPTIMIZE
142#  endif
143#  if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK)
144#    define PERL_EMERGENCY_SBRK
145#  endif
146#  if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
147#    define DEBUGGING_MSTATS
148#  endif
149#endif
150
151#define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
152#define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
153
154#if !(defined(I286) || defined(atarist) || defined(__MINT__))
155        /* take 2k unless the block is bigger than that */
156#  define LOG_OF_MIN_ARENA 11
157#else
158        /* take 16k unless the block is bigger than that
159           (80286s like large segments!), probably good on the atari too */
160#  define LOG_OF_MIN_ARENA 14
161#endif
162
163#ifndef lint
164#  if defined(DEBUGGING) && !defined(NO_RCHECK)
165#    define RCHECK
166#  endif
167#  if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE)
168#    undef IGNORE_SMALL_BAD_FREE
169#  endif
170/*
171 * malloc.c (Caltech) 2/21/82
172 * Chris Kingsley, kingsley@cit-20.
173 *
174 * This is a very fast storage allocator.  It allocates blocks of a small
175 * number of different sizes, and keeps free lists of each size.  Blocks that
176 * don't exactly fit are passed up to the next larger size.  In this
177 * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
178 * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
179 * This is designed for use in a program that uses vast quantities of memory,
180 * but bombs when it runs out.
181 */
182
183#ifdef PERL_CORE
184#  include "EXTERN.h"
185#  include "perl.h"
186#else
187#  ifdef PERL_FOR_X2P
188#    include "../EXTERN.h"
189#    include "../perl.h"
190#  else
191#    include <stdlib.h>
192#    include <stdio.h>
193#    include <memory.h>
194#    define _(arg) arg
195#    ifndef Malloc_t
196#      define Malloc_t void *
197#    endif
198#    ifndef MEM_SIZE
199#      define MEM_SIZE unsigned long
200#    endif
201#    ifndef LONG_MAX
202#      define LONG_MAX 0x7FFFFFFF
203#    endif
204#    ifndef UV
205#      define UV unsigned long
206#    endif
207#    ifndef caddr_t
208#      define caddr_t char *
209#    endif
210#    ifndef Free_t
211#      define Free_t void
212#    endif
213#    define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
214#    define PerlEnv_getenv getenv
215#    define PerlIO_printf fprintf
216#    define PerlIO_stderr() stderr
217#  endif
218#  ifndef croak                         /* make depend */
219#    define croak(mess, arg) do {warn((mess), (arg)); exit(1);} while(0)
220#  endif
221#  ifndef warn
222#    define warn(mess, arg) do {fprintf(stderr, (mess), (arg));} while(0)
223#  endif
224#  ifdef DEBUG_m
225#    undef DEBUG_m
226#  endif
227#  define DEBUG_m(a)
228#  ifdef DEBUGGING
229#     undef DEBUGGING
230#  endif
231#endif
232
233#ifndef MUTEX_LOCK
234#  define MUTEX_LOCK(l)
235#endif
236
237#ifndef MUTEX_UNLOCK
238#  define MUTEX_UNLOCK(l)
239#endif
240
241#ifdef DEBUGGING
242#  undef DEBUG_m
243#  define DEBUG_m(a)  if (PL_debug & 128)   a
244#endif
245
246/* I don't much care whether these are defined in sys/types.h--LAW */
247
248#define u_char unsigned char
249#define u_int unsigned int
250
251#ifdef HAS_QUAD
252#  define u_bigint UV                   /* Needs to eat *void. */
253#else  /* needed? */
254#  define u_bigint unsigned long        /* Needs to eat *void. */
255#endif
256
257#define u_short unsigned short
258
259/* 286 and atarist like big chunks, which gives too much overhead. */
260#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC)
261#  undef PACK_MALLOC
262#endif
263
264/*
265 * The description below is applicable if PACK_MALLOC is not defined.
266 *
267 * The overhead on a block is at least 4 bytes.  When free, this space
268 * contains a pointer to the next free block, and the bottom two bits must
269 * be zero.  When in use, the first byte is set to MAGIC, and the second
270 * byte is the size index.  The remaining bytes are for alignment.
271 * If range checking is enabled and the size of the block fits
272 * in two bytes, then the top two bytes hold the size of the requested block
273 * plus the range checking words, and the header word MINUS ONE.
274 */
275union   overhead {
276        union   overhead *ov_next;      /* when free */
277#if MEM_ALIGNBYTES > 4
278        double  strut;                  /* alignment problems */
279#endif
280        struct {
281                u_char  ovu_magic;      /* magic number */
282                u_char  ovu_index;      /* bucket # */
283#ifdef RCHECK
284                u_short ovu_size;       /* actual block size */
285                u_int   ovu_rmagic;     /* range magic number */
286#endif
287        } ovu;
288#define ov_magic        ovu.ovu_magic
289#define ov_index        ovu.ovu_index
290#define ov_size         ovu.ovu_size
291#define ov_rmagic       ovu.ovu_rmagic
292};
293
294#ifdef DEBUGGING
295static void botch _((char *diag, char *s));
296#endif
297static void morecore _((int bucket));
298static int findbucket _((union overhead *freep, int srchlen));
299static void add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip);
300
301#define MAGIC           0xff            /* magic # on accounting info */
302#define RMAGIC          0x55555555      /* magic # on range info */
303#define RMAGIC_C        0x55            /* magic # on range info */
304
305#ifdef RCHECK
306#  define       RSLOP           sizeof (u_int)
307#  ifdef TWO_POT_OPTIMIZE
308#    define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2)
309#  else
310#    define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
311#  endif
312#else
313#  define       RSLOP           0
314#endif
315
316#if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
317#  undef BUCKETS_ROOT2
318#endif
319
320#ifdef BUCKETS_ROOT2
321#  define BUCKET_TABLE_SHIFT 2
322#  define BUCKET_POW2_SHIFT 1
323#  define BUCKETS_PER_POW2 2
324#else
325#  define BUCKET_TABLE_SHIFT MIN_BUC_POW2
326#  define BUCKET_POW2_SHIFT 0
327#  define BUCKETS_PER_POW2 1
328#endif
329
330#if !defined(MEM_ALIGNBYTES) || ((MEM_ALIGNBYTES > 4) && !defined(STRICT_ALIGNMENT))
331/* Figure out the alignment of void*. */
332struct aligner {
333  char c;
334  void *p;
335};
336#  define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
337#else
338#  define ALIGN_SMALL MEM_ALIGNBYTES
339#endif
340
341#define IF_ALIGN_8(yes,no)      ((ALIGN_SMALL>4) ? (yes) : (no))
342
343#ifdef BUCKETS_ROOT2
344#  define MAX_BUCKET_BY_TABLE 13
345static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
346  {
347      0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
348  };
349#  define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
350#  define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE               \
351                               ? buck_size[i]                           \
352                               : ((1 << ((i) >> BUCKET_POW2_SHIFT))     \
353                                  - MEM_OVERHEAD(i)                     \
354                                  + POW2_OPTIMIZE_SURPLUS(i)))
355#else
356#  define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
357#  define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) + POW2_OPTIMIZE_SURPLUS(i))
358#endif
359
360
361#ifdef PACK_MALLOC
362/* In this case it is assumed that if we do sbrk() in 2K units, we
363 * will get 2K aligned arenas (at least after some initial
364 * alignment). The bucket number of the given subblock is on the start
365 * of 2K arena which contains the subblock.  Several following bytes
366 * contain the magic numbers for the subblocks in the block.
367 *
368 * Sizes of chunks are powers of 2 for chunks in buckets <=
369 * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to
370 * get alignment right).
371 *
372 * Consider an arena for 2^n with n>MAX_PACKED.  We suppose that
373 * starts of all the chunks in a 2K arena are in different
374 * 2^n-byte-long chunks.  If the top of the last chunk is aligned on a
375 * boundary of 2K block, this means that sizeof(union
376 * overhead)*"number of chunks" < 2^n, or sizeof(union overhead)*2K <
377 * 4^n, or n > 6 + log2(sizeof()/2)/2, since a chunk of size 2^n -
378 * overhead is used.  Since this rules out n = 7 for 8 byte alignment,
379 * we specialcase allocation of the first of 16 128-byte-long chunks.
380 *
381 * Note that with the above assumption we automatically have enough
382 * place for MAGIC at the start of 2K block.  Note also that we
383 * overlay union overhead over the chunk, thus the start of small chunks
384 * is immediately overwritten after freeing.  */
385#  define MAX_PACKED_POW2 6
386#  define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
387#  define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
388#  define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
389#  define TWOK_MASKED(x) ((u_bigint)(x) & ~TWOK_MASK)
390#  define TWOK_SHIFT(x) ((u_bigint)(x) & TWOK_MASK)
391#  define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block)))
392#  define OV_INDEX(block) (*OV_INDEXp(block))
393#  define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) +                  \
394                                    (TWOK_SHIFT(block)>>                \
395                                     (bucket>>BUCKET_POW2_SHIFT)) +     \
396                                    (bucket >= MIN_NEEDS_SHIFT ? 1 : 0)))
397    /* A bucket can have a shift smaller than it size, we need to
398       shift its magic number so it will not overwrite index: */
399#  ifdef BUCKETS_ROOT2
400#    define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2 - 1) /* Shift 80 greater than chunk 64. */
401#  else
402#    define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2) /* Shift 128 greater than chunk 32. */
403#  endif
404#  define CHUNK_SHIFT 0
405
406/* Number of active buckets of given ordinal. */
407#ifdef IGNORE_SMALL_BAD_FREE
408#define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
409#  define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK           \
410                         ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE(bucket) \
411                         : n_blks[bucket] )
412#else
413#  define N_BLKS(bucket) n_blks[bucket]
414#endif
415
416static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
417  {
418#  if BUCKETS_PER_POW2==1
419      0, 0,
420      (MIN_BUC_POW2==2 ? 384 : 0),
421      224, 120, 62, 31, 16, 8, 4, 2
422#  else
423      0, 0, 0, 0,
424      (MIN_BUC_POW2==2 ? 384 : 0), (MIN_BUC_POW2==2 ? 384 : 0), /* 4, 4 */
425      224, 149, 120, 80, 62, 41, 31, 25, 16, 16, 8, 8, 4, 4, 2, 2
426#  endif
427  };
428
429/* Shift of the first bucket with the given ordinal inside 2K chunk. */
430#ifdef IGNORE_SMALL_BAD_FREE
431#  define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK        \
432                              ? ((1<<LOG_OF_MIN_ARENA)                  \
433                                 - BUCKET_SIZE(bucket) * N_BLKS(bucket)) \
434                              : blk_shift[bucket])
435#else
436#  define BLK_SHIFT(bucket) blk_shift[bucket]
437#endif
438
439static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
440  {
441#  if BUCKETS_PER_POW2==1
442      0, 0,
443      (MIN_BUC_POW2==2 ? 512 : 0),
444      256, 128, 64, 64,                 /* 8 to 64 */
445      16*sizeof(union overhead),
446      8*sizeof(union overhead),
447      4*sizeof(union overhead),
448      2*sizeof(union overhead),
449#  else
450      0, 0, 0, 0,
451      (MIN_BUC_POW2==2 ? 512 : 0), (MIN_BUC_POW2==2 ? 512 : 0),
452      256, 260, 128, 128, 64, 80, 64, 48, /* 8 to 96 */
453      16*sizeof(union overhead), 16*sizeof(union overhead),
454      8*sizeof(union overhead), 8*sizeof(union overhead),
455      4*sizeof(union overhead), 4*sizeof(union overhead),
456      2*sizeof(union overhead), 2*sizeof(union overhead),
457#  endif
458  };
459
460#else  /* !PACK_MALLOC */
461
462#  define OV_MAGIC(block,bucket) (block)->ov_magic
463#  define OV_INDEX(block) (block)->ov_index
464#  define CHUNK_SHIFT 1
465#  define MAX_PACKED -1
466#endif /* !PACK_MALLOC */
467
468#define M_OVERHEAD (sizeof(union overhead) + RSLOP)
469
470#ifdef PACK_MALLOC
471#  define MEM_OVERHEAD(bucket) \
472  (bucket <= MAX_PACKED ? 0 : M_OVERHEAD)
473#  ifdef SMALL_BUCKET_VIA_TABLE
474#    define START_SHIFTS_BUCKET ((MAX_PACKED_POW2 + 1) * BUCKETS_PER_POW2)
475#    define START_SHIFT MAX_PACKED_POW2
476#    ifdef BUCKETS_ROOT2                /* Chunks of size 3*2^n. */
477#      define SIZE_TABLE_MAX 80
478#    else
479#      define SIZE_TABLE_MAX 64
480#    endif
481static char bucket_of[] =
482  {
483#    ifdef BUCKETS_ROOT2                /* Chunks of size 3*2^n. */
484      /* 0 to 15 in 4-byte increments. */
485      (sizeof(void*) > 4 ? 6 : 5),      /* 4/8, 5-th bucket for better reports */
486      6,                                /* 8 */
487      IF_ALIGN_8(8,7), 8,               /* 16/12, 16 */
488      9, 9, 10, 10,                     /* 24, 32 */
489      11, 11, 11, 11,                   /* 48 */
490      12, 12, 12, 12,                   /* 64 */
491      13, 13, 13, 13,                   /* 80 */
492      13, 13, 13, 13                    /* 80 */
493#    else /* !BUCKETS_ROOT2 */
494      /* 0 to 15 in 4-byte increments. */
495      (sizeof(void*) > 4 ? 3 : 2),
496      3,
497      4, 4,
498      5, 5, 5, 5,
499      6, 6, 6, 6,
500      6, 6, 6, 6
501#    endif /* !BUCKETS_ROOT2 */
502  };
503#  else  /* !SMALL_BUCKET_VIA_TABLE */
504#    define START_SHIFTS_BUCKET MIN_BUCKET
505#    define START_SHIFT (MIN_BUC_POW2 - 1)
506#  endif /* !SMALL_BUCKET_VIA_TABLE */
507#else  /* !PACK_MALLOC */
508#  define MEM_OVERHEAD(bucket) M_OVERHEAD
509#  ifdef SMALL_BUCKET_VIA_TABLE
510#    undef SMALL_BUCKET_VIA_TABLE
511#  endif
512#  define START_SHIFTS_BUCKET MIN_BUCKET
513#  define START_SHIFT (MIN_BUC_POW2 - 1)
514#endif /* !PACK_MALLOC */
515
516/*
517 * Big allocations are often of the size 2^n bytes. To make them a
518 * little bit better, make blocks of size 2^n+pagesize for big n.
519 */
520
521#ifdef TWO_POT_OPTIMIZE
522
523#  ifndef PERL_PAGESIZE
524#    define PERL_PAGESIZE 4096
525#  endif
526#  ifndef FIRST_BIG_POW2
527#    define FIRST_BIG_POW2 15   /* 32K, 16K is used too often. */
528#  endif
529#  define FIRST_BIG_BLOCK (1<<FIRST_BIG_POW2)
530/* If this value or more, check against bigger blocks. */
531#  define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD)
532/* If less than this value, goes into 2^n-overhead-block. */
533#  define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD)
534
535#  define POW2_OPTIMIZE_ADJUST(nbytes)                          \
536   ((nbytes >= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0)
537#  define POW2_OPTIMIZE_SURPLUS(bucket)                         \
538   ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)
539
540#else  /* !TWO_POT_OPTIMIZE */
541#  define POW2_OPTIMIZE_ADJUST(nbytes)
542#  define POW2_OPTIMIZE_SURPLUS(bucket) 0
543#endif /* !TWO_POT_OPTIMIZE */
544
545#if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
546#  define BARK_64K_LIMIT(what,nbytes,size)                              \
547        if (nbytes > 0xffff) {                                          \
548                PerlIO_printf(PerlIO_stderr(),                          \
549                              "%s too large: %lx\n", what, size);       \
550                my_exit(1);                                             \
551        }
552#else /* !HAS_64K_LIMIT || !PERL_CORE */
553#  define BARK_64K_LIMIT(what,nbytes,size)
554#endif /* !HAS_64K_LIMIT || !PERL_CORE */
555
556#ifndef MIN_SBRK
557#  define MIN_SBRK 2048
558#endif
559
560#ifndef FIRST_SBRK
561#  define FIRST_SBRK (48*1024)
562#endif
563
564/* Minimal sbrk in percents of what is already alloced. */
565#ifndef MIN_SBRK_FRAC
566#  define MIN_SBRK_FRAC 3
567#endif
568
569#ifndef SBRK_ALLOW_FAILURES
570#  define SBRK_ALLOW_FAILURES 3
571#endif
572
573#ifndef SBRK_FAILURE_PRICE
574#  define SBRK_FAILURE_PRICE 50
575#endif
576
577#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
578
579#  ifndef BIG_SIZE
580#    define BIG_SIZE (1<<16)            /* 64K */
581#  endif
582
583#ifdef MUTEX_INIT_CALLS_MALLOC
584#  undef      MUTEX_LOCK
585#  define MUTEX_LOCK(m)       STMT_START { if (*m) mutex_lock(*m); } STMT_END
586#  undef      MUTEX_UNLOCK
587#  define MUTEX_UNLOCK(m)     STMT_START { if (*m) mutex_unlock(*m); } STMT_END
588#endif
589
590static char *emergency_buffer;
591static MEM_SIZE emergency_buffer_size;
592static Malloc_t emergency_sbrk(MEM_SIZE size);
593
594static Malloc_t
595emergency_sbrk(MEM_SIZE size)
596{
597    MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
598
599    if (size >= BIG_SIZE) {
600        /* Give the possibility to recover: */
601        MUTEX_UNLOCK(&PL_malloc_mutex);
602        croak("Out of memory during \"large\" request for %i bytes", size);
603    }
604
605    if (emergency_buffer_size >= rsize) {
606        char *old = emergency_buffer;
607       
608        emergency_buffer_size -= rsize;
609        emergency_buffer += rsize;
610        return old;
611    } else {           
612        dTHR;
613        /* First offense, give a possibility to recover by dieing. */
614        /* No malloc involved here: */
615        GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0);
616        SV *sv;
617        char *pv;
618        int have = 0;
619        STRLEN n_a;
620
621        if (emergency_buffer_size) {
622            add_to_chain(emergency_buffer, emergency_buffer_size, 0);
623            emergency_buffer_size = 0;
624            emergency_buffer = Nullch;
625            have = 1;
626        }
627        if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
628        if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
629            || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
630            if (have)
631                goto do_croak;
632            return (char *)-1;          /* Now die die die... */
633        }
634        /* Got it, now detach SvPV: */
635        pv = SvPV(sv, n_a);
636        /* Check alignment: */
637        if (((UV)(pv - sizeof(union overhead))) & ((1<<LOG_OF_MIN_ARENA) - 1)) {
638            PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
639            return (char *)-1;          /* die die die */
640        }
641
642        emergency_buffer = pv - sizeof(union overhead);
643        emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
644        SvPOK_off(sv);
645        SvPVX(sv) = Nullch;
646        SvCUR(sv) = SvLEN(sv) = 0;
647    }
648  do_croak:
649    MUTEX_UNLOCK(&PL_malloc_mutex);
650    croak("Out of memory during request for %i bytes", size);
651}
652
653#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
654#  define emergency_sbrk(size)  -1
655#endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
656
657/*
658 * nextf[i] is the pointer to the next free block of size 2^i.  The
659 * smallest allocatable block is 8 bytes.  The overhead information
660 * precedes the data area returned to the user.
661 */
662#define NBUCKETS (32*BUCKETS_PER_POW2 + 1)
663static  union overhead *nextf[NBUCKETS];
664
665#ifdef USE_PERL_SBRK
666#define sbrk(a) Perl_sbrk(a)
667Malloc_t Perl_sbrk _((int size));
668#else
669#ifdef DONT_DECLARE_STD
670#ifdef I_UNISTD
671#include <unistd.h>
672#endif
673#else
674extern  Malloc_t sbrk(int);
675#endif
676#endif
677
678#ifdef DEBUGGING_MSTATS
679/*
680 * nmalloc[i] is the difference between the number of mallocs and frees
681 * for a given block size.
682 */
683static  u_int nmalloc[NBUCKETS];
684static  u_int sbrk_slack;
685static  u_int start_slack;
686#endif
687
688static  u_int goodsbrk;
689
690#ifdef DEBUGGING
691#undef ASSERT
692#define ASSERT(p,diag)   if (!(p)) botch(diag,STRINGIFY(p));  else
693static void
694botch(char *diag, char *s)
695{
696        PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
697        PerlProc_abort();
698}
699#else
700#define ASSERT(p, diag)
701#endif
702
703Malloc_t
704malloc(register size_t nbytes)
705{
706        register union overhead *p;
707        register int bucket;
708        register MEM_SIZE shiftr;
709
710#if defined(DEBUGGING) || defined(RCHECK)
711        MEM_SIZE size = nbytes;
712#endif
713
714        BARK_64K_LIMIT("Allocation",nbytes,nbytes);
715#ifdef DEBUGGING
716        if ((long)nbytes < 0)
717                croak("%s", "panic: malloc");
718#endif
719
720        MUTEX_LOCK(&PL_malloc_mutex);
721        /*
722         * Convert amount of memory requested into
723         * closest block size stored in hash buckets
724         * which satisfies request.  Account for
725         * space used per block for accounting.
726         */
727#ifdef PACK_MALLOC
728#  ifdef SMALL_BUCKET_VIA_TABLE
729        if (nbytes == 0)
730            bucket = MIN_BUCKET;
731        else if (nbytes <= SIZE_TABLE_MAX) {
732            bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT];
733        } else
734#  else
735        if (nbytes == 0)
736            nbytes = 1;
737        if (nbytes <= MAX_POW2_ALGO) goto do_shifts;
738        else
739#  endif
740#endif
741        {
742            POW2_OPTIMIZE_ADJUST(nbytes);
743            nbytes += M_OVERHEAD;
744            nbytes = (nbytes + 3) &~ 3;
745          do_shifts:
746            shiftr = (nbytes - 1) >> START_SHIFT;
747            bucket = START_SHIFTS_BUCKET;
748            /* apart from this loop, this is O(1) */
749            while (shiftr >>= 1)
750                bucket += BUCKETS_PER_POW2;
751        }
752        /*
753         * If nothing in hash bucket right now,
754         * request more memory from the system.
755         */
756        if (nextf[bucket] == NULL)
757                morecore(bucket);
758        if ((p = nextf[bucket]) == NULL) {
759                MUTEX_UNLOCK(&PL_malloc_mutex);
760#ifdef PERL_CORE
761                if (!PL_nomemok) {
762                    PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
763                    my_exit(1);
764                }
765#else
766                return (NULL);
767#endif
768        }
769
770        DEBUG_m(PerlIO_printf(Perl_debug_log,
771                              "0x%lx: (%05lu) malloc %ld bytes\n",
772                              (unsigned long)(p+1), (unsigned long)(PL_an++),
773                              (long)size));
774
775        /* remove from linked list */
776#if defined(RCHECK)
777        if (((UV)p) & (MEM_ALIGNBYTES - 1))
778            PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n",
779                (unsigned long)*((int*)p),(unsigned long)p);
780#endif
781        nextf[bucket] = p->ov_next;
782#ifdef IGNORE_SMALL_BAD_FREE
783        if (bucket >= FIRST_BUCKET_WITH_CHECK)
784#endif
785            OV_MAGIC(p, bucket) = MAGIC;
786#ifndef PACK_MALLOC
787        OV_INDEX(p) = bucket;
788#endif
789#ifdef RCHECK
790        /*
791         * Record allocated size of block and
792         * bound space with magic numbers.
793         */
794        p->ov_rmagic = RMAGIC;
795        if (bucket <= MAX_SHORT_BUCKET) {
796            int i;
797       
798            nbytes = size + M_OVERHEAD;
799            p->ov_size = nbytes - 1;
800            if ((i = nbytes & 3)) {
801                i = 4 - i;
802                while (i--)
803                    *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C;
804            }
805            nbytes = (nbytes + 3) &~ 3;
806            *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
807        }
808#endif
809        MUTEX_UNLOCK(&PL_malloc_mutex);
810        return ((Malloc_t)(p + CHUNK_SHIFT));
811}
812
813static char *last_sbrk_top;
814static char *last_op;                   /* This arena can be easily extended. */
815static int sbrked_remains;
816static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
817
818#ifdef DEBUGGING_MSTATS
819static int sbrks;
820#endif
821
822struct chunk_chain_s {
823    struct chunk_chain_s *next;
824    MEM_SIZE size;
825};
826static struct chunk_chain_s *chunk_chain;
827static int n_chunks;
828static char max_bucket;
829
830/* Cutoff a piece of one of the chunks in the chain.  Prefer smaller chunk. */
831static void *
832get_from_chain(MEM_SIZE size)
833{
834    struct chunk_chain_s *elt = chunk_chain, **oldp = &chunk_chain;
835    struct chunk_chain_s **oldgoodp = NULL;
836    long min_remain = LONG_MAX;
837
838    while (elt) {
839        if (elt->size >= size) {
840            long remains = elt->size - size;
841            if (remains >= 0 && remains < min_remain) {
842                oldgoodp = oldp;
843                min_remain = remains;
844            }
845            if (remains == 0) {
846                break;
847            }
848        }
849        oldp = &( elt->next );
850        elt = elt->next;
851    }
852    if (!oldgoodp) return NULL;
853    if (min_remain) {
854        void *ret = *oldgoodp;
855        struct chunk_chain_s *next = (*oldgoodp)->next;
856       
857        *oldgoodp = (struct chunk_chain_s *)((char*)ret + size);
858        (*oldgoodp)->size = min_remain;
859        (*oldgoodp)->next = next;
860        return ret;
861    } else {
862        void *ret = *oldgoodp;
863        *oldgoodp = (*oldgoodp)->next;
864        n_chunks--;
865        return ret;
866    }
867}
868
869static void
870add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip)
871{
872    struct chunk_chain_s *next = chunk_chain;
873    char *cp = (char*)p;
874
875    cp += chip;
876    chunk_chain = (struct chunk_chain_s *)cp;
877    chunk_chain->size = size - chip;
878    chunk_chain->next = next;
879    n_chunks++;
880}
881
882static void *
883get_from_bigger_buckets(int bucket, MEM_SIZE size)
884{
885    int price = 1;
886    static int bucketprice[NBUCKETS];
887    while (bucket <= max_bucket) {
888        /* We postpone stealing from bigger buckets until we want it
889           often enough. */
890        if (nextf[bucket] && bucketprice[bucket]++ >= price) {
891            /* Steal it! */
892            void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT);
893            bucketprice[bucket] = 0;
894            if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) {
895                last_op = NULL;         /* Disable optimization */
896            }
897            nextf[bucket] = nextf[bucket]->ov_next;
898#ifdef DEBUGGING_MSTATS
899            nmalloc[bucket]--;
900            start_slack -= M_OVERHEAD;
901#endif
902            add_to_chain(ret, (BUCKET_SIZE(bucket) +
903                               POW2_OPTIMIZE_SURPLUS(bucket)),
904                         size);
905            return ret;
906        }
907        bucket++;
908    }
909    return NULL;
910}
911
912static union overhead *
913getpages(int needed, int *nblksp, int bucket)
914{
915    /* Need to do (possibly expensive) system call. Try to
916       optimize it for rare calling. */
917    MEM_SIZE require = needed - sbrked_remains;
918    char *cp;
919    union overhead *ovp;
920    int slack = 0;
921
922    if (sbrk_good > 0) {
923        if (!last_sbrk_top && require < FIRST_SBRK)
924            require = FIRST_SBRK;
925        else if (require < MIN_SBRK) require = MIN_SBRK;
926
927        if (require < goodsbrk * MIN_SBRK_FRAC / 100)
928            require = goodsbrk * MIN_SBRK_FRAC / 100;
929        require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
930    } else {
931        require = needed;
932        last_sbrk_top = 0;
933        sbrked_remains = 0;
934    }
935
936    DEBUG_m(PerlIO_printf(Perl_debug_log,
937                          "sbrk(%ld) for %ld-byte-long arena\n",
938                          (long)require, (long) needed));
939    cp = (char *)sbrk(require);
940#ifdef DEBUGGING_MSTATS
941    sbrks++;
942#endif
943    if (cp == last_sbrk_top) {
944        /* Common case, anything is fine. */
945        sbrk_good++;
946        ovp = (union overhead *) (cp - sbrked_remains);
947        sbrked_remains = require - (needed - sbrked_remains);
948    } else if (cp == (char *)-1) { /* no more room! */
949        ovp = (union overhead *)emergency_sbrk(needed);
950        if (ovp == (union overhead *)-1)
951            return 0;
952        return ovp;
953    } else {                    /* Non-continuous or first sbrk(). */
954        long add = sbrked_remains;
955        char *newcp;
956
957        if (sbrked_remains) {   /* Put rest into chain, we
958                                   cannot use it right now. */
959            add_to_chain((void*)(last_sbrk_top - sbrked_remains),
960                         sbrked_remains, 0);
961        }
962
963        /* Second, check alignment. */
964        slack = 0;
965
966#if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */
967#  ifndef I286  /* The sbrk(0) call on the I286 always returns the next segment */
968
969        /* CHUNK_SHIFT is 1 for PACK_MALLOC, 0 otherwise. */
970        if ((UV)cp & (0x7FF >> CHUNK_SHIFT)) { /* Not aligned. */
971            slack = (0x800 >> CHUNK_SHIFT)
972                - ((UV)cp & (0x7FF >> CHUNK_SHIFT));
973            add += slack;
974        }
975#  endif
976#endif /* !atarist && !MINT */
977               
978        if (add) {
979            DEBUG_m(PerlIO_printf(Perl_debug_log,
980                                  "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",
981                                  (long)add, (long) slack,
982                                  (long) sbrked_remains));
983            newcp = (char *)sbrk(add);
984#if defined(DEBUGGING_MSTATS)
985            sbrks++;
986            sbrk_slack += add;
987#endif
988            if (newcp != cp + require) {
989                /* Too bad: even rounding sbrk() is not continuous.*/
990                DEBUG_m(PerlIO_printf(Perl_debug_log,
991                                      "failed to fix bad sbrk()\n"));
992#ifdef PACK_MALLOC
993                if (slack) {
994                    MUTEX_UNLOCK(&PL_malloc_mutex);
995                    croak("%s", "panic: Off-page sbrk");
996                }
997#endif
998                if (sbrked_remains) {
999                    /* Try again. */
1000#if defined(DEBUGGING_MSTATS)
1001                    sbrk_slack += require;
1002#endif
1003                    require = needed;
1004                    DEBUG_m(PerlIO_printf(Perl_debug_log,
1005                                          "straight sbrk(%ld)\n",
1006                                          (long)require));
1007                    cp = (char *)sbrk(require);
1008#ifdef DEBUGGING_MSTATS
1009                    sbrks++;
1010#endif
1011                    if (cp == (char *)-1)
1012                        return 0;
1013                }
1014                sbrk_good = -1; /* Disable optimization!
1015                                   Continue with not-aligned... */
1016            } else {
1017                cp += slack;
1018                require += sbrked_remains;
1019            }
1020        }
1021
1022        if (last_sbrk_top) {
1023            sbrk_good -= SBRK_FAILURE_PRICE;
1024        }
1025
1026        ovp = (union overhead *) cp;
1027        /*
1028         * Round up to minimum allocation size boundary
1029         * and deduct from block count to reflect.
1030         */
1031
1032#ifndef I286    /* Again, this should always be ok on an 80286 */
1033        if ((UV)ovp & 7) {
1034            ovp = (union overhead *)(((UV)ovp + 8) & ~7);
1035            DEBUG_m(PerlIO_printf(Perl_debug_log,
1036                                  "fixing sbrk(): %d bytes off machine alignement\n",
1037                                  (int)((UV)ovp & 7)));
1038            (*nblksp)--;
1039# if defined(DEBUGGING_MSTATS)
1040            /* This is only approx. if TWO_POT_OPTIMIZE: */
1041            sbrk_slack += (1 << bucket);
1042# endif
1043        }
1044#endif
1045        sbrked_remains = require - needed;
1046    }
1047    last_sbrk_top = cp + require;
1048    last_op = (char*) cp;
1049#ifdef DEBUGGING_MSTATS
1050    goodsbrk += require;
1051#endif 
1052    return ovp;
1053}
1054
1055static int
1056getpages_adjacent(int require)
1057{       
1058    if (require <= sbrked_remains) {
1059        sbrked_remains -= require;
1060    } else {
1061        char *cp;
1062
1063        require -= sbrked_remains;
1064        /* We do not try to optimize sbrks here, we go for place. */
1065        cp = (char*) sbrk(require);
1066#ifdef DEBUGGING_MSTATS
1067        sbrks++;
1068        goodsbrk += require;
1069#endif
1070        if (cp == last_sbrk_top) {
1071            sbrked_remains = 0;
1072            last_sbrk_top = cp + require;
1073        } else {
1074            if (cp == (char*)-1) {      /* Out of memory */
1075#ifdef DEBUGGING_MSTATS
1076                goodsbrk -= require;
1077#endif
1078                return 0;
1079            }
1080            /* Report the failure: */
1081            if (sbrked_remains)
1082                add_to_chain((void*)(last_sbrk_top - sbrked_remains),
1083                             sbrked_remains, 0);
1084            add_to_chain((void*)cp, require, 0);
1085            sbrk_good -= SBRK_FAILURE_PRICE;
1086            sbrked_remains = 0;
1087            last_sbrk_top = 0;
1088            last_op = 0;
1089            return 0;
1090        }
1091    }
1092       
1093    return 1;
1094}
1095
1096/*
1097 * Allocate more memory to the indicated bucket.
1098 */
1099static void
1100morecore(register int bucket)
1101{
1102        register union overhead *ovp;
1103        register int rnu;       /* 2^rnu bytes will be requested */
1104        int nblks;              /* become nblks blocks of the desired size */
1105        register MEM_SIZE siz, needed;
1106
1107        if (nextf[bucket])
1108                return;
1109        if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
1110            MUTEX_UNLOCK(&PL_malloc_mutex);
1111            croak("%s", "Out of memory during ridiculously large request");
1112        }
1113        if (bucket > max_bucket)
1114            max_bucket = bucket;
1115
1116        rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT))
1117                ? LOG_OF_MIN_ARENA
1118                : (bucket >> BUCKET_POW2_SHIFT) );
1119        /* This may be overwritten later: */
1120        nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */
1121        needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket);
1122        if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */
1123            ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT;
1124            nextf[rnu << BUCKET_POW2_SHIFT]
1125                = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next;
1126#ifdef DEBUGGING_MSTATS
1127            nmalloc[rnu << BUCKET_POW2_SHIFT]--;
1128            start_slack -= M_OVERHEAD;
1129#endif
1130            DEBUG_m(PerlIO_printf(Perl_debug_log,
1131                                  "stealing %ld bytes from %ld arena\n",
1132                                  (long) needed, (long) rnu << BUCKET_POW2_SHIFT));
1133        } else if (chunk_chain
1134                   && (ovp = (union overhead*) get_from_chain(needed))) {
1135            DEBUG_m(PerlIO_printf(Perl_debug_log,
1136                                  "stealing %ld bytes from chain\n",
1137                                  (long) needed));
1138        } else if ( (ovp = (union overhead*)
1139                     get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
1140                                             needed)) ) {
1141            DEBUG_m(PerlIO_printf(Perl_debug_log,
1142                                  "stealing %ld bytes from bigger buckets\n",
1143                                  (long) needed));
1144        } else if (needed <= sbrked_remains) {
1145            ovp = (union overhead *)(last_sbrk_top - sbrked_remains);
1146            sbrked_remains -= needed;
1147            last_op = (char*)ovp;
1148        } else
1149            ovp = getpages(needed, &nblks, bucket);
1150
1151        if (!ovp)
1152            return;
1153
1154        /*
1155         * Add new memory allocated to that on
1156         * free list for this hash bucket.
1157         */
1158        siz = BUCKET_SIZE(bucket);
1159#ifdef PACK_MALLOC
1160        *(u_char*)ovp = bucket; /* Fill index. */
1161        if (bucket <= MAX_PACKED) {
1162            ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1163            nblks = N_BLKS(bucket);
1164#  ifdef DEBUGGING_MSTATS
1165            start_slack += BLK_SHIFT(bucket);
1166#  endif
1167        } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) {
1168            ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
1169            siz -= sizeof(union overhead);
1170        } else ovp++;           /* One chunk per block. */
1171#endif /* PACK_MALLOC */
1172        nextf[bucket] = ovp;
1173#ifdef DEBUGGING_MSTATS
1174        nmalloc[bucket] += nblks;
1175        if (bucket > MAX_PACKED) {
1176            start_slack += M_OVERHEAD * nblks;
1177        }
1178#endif
1179        while (--nblks > 0) {
1180                ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
1181                ovp = (union overhead *)((caddr_t)ovp + siz);
1182        }
1183        /* Not all sbrks return zeroed memory.*/
1184        ovp->ov_next = (union overhead *)NULL;
1185#ifdef PACK_MALLOC
1186        if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */
1187            union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next;
1188            nextf[7*BUCKETS_PER_POW2] =
1189                (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2]
1190                                   - sizeof(union overhead));
1191            nextf[7*BUCKETS_PER_POW2]->ov_next = n_op;
1192        }
1193#endif /* !PACK_MALLOC */
1194}
1195
1196Free_t
1197free(void *mp)
1198{
1199        register MEM_SIZE size;
1200        register union overhead *ovp;
1201        char *cp = (char*)mp;
1202#ifdef PACK_MALLOC
1203        u_char bucket;
1204#endif
1205
1206        DEBUG_m(PerlIO_printf(Perl_debug_log,
1207                              "0x%lx: (%05lu) free\n",
1208                              (unsigned long)cp, (unsigned long)(PL_an++)));
1209
1210        if (cp == NULL)
1211                return;
1212        ovp = (union overhead *)((caddr_t)cp
1213                                - sizeof (union overhead) * CHUNK_SHIFT);
1214#ifdef PACK_MALLOC
1215        bucket = OV_INDEX(ovp);
1216#endif
1217#ifdef IGNORE_SMALL_BAD_FREE
1218        if ((bucket >= FIRST_BUCKET_WITH_CHECK)
1219            && (OV_MAGIC(ovp, bucket) != MAGIC))
1220#else
1221        if (OV_MAGIC(ovp, bucket) != MAGIC)
1222#endif
1223            {
1224                static int bad_free_warn = -1;
1225                if (bad_free_warn == -1) {
1226                    char *pbf = PerlEnv_getenv("PERL_BADFREE");
1227                    bad_free_warn = (pbf) ? atoi(pbf) : 1;
1228                }
1229                if (!bad_free_warn)
1230                    return;
1231#ifdef RCHECK
1232                warn("%s free() ignored",
1233                    ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
1234#else
1235                warn("%s", "Bad free() ignored");
1236#endif
1237                return;                         /* sanity */
1238            }
1239        MUTEX_LOCK(&PL_malloc_mutex);
1240#ifdef RCHECK
1241        ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
1242        if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
1243            int i;
1244            MEM_SIZE nbytes = ovp->ov_size + 1;
1245
1246            if ((i = nbytes & 3)) {
1247                i = 4 - i;
1248                while (i--) {
1249                    ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
1250                           == RMAGIC_C, "chunk's tail overwrite");
1251                }
1252            }
1253            nbytes = (nbytes + 3) &~ 3;
1254            ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite");     
1255        }
1256        ovp->ov_rmagic = RMAGIC - 1;
1257#endif
1258        ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
1259        size = OV_INDEX(ovp);
1260        ovp->ov_next = nextf[size];
1261        nextf[size] = ovp;
1262        MUTEX_UNLOCK(&PL_malloc_mutex);
1263}
1264
1265/*
1266 * When a program attempts "storage compaction" as mentioned in the
1267 * old malloc man page, it realloc's an already freed block.  Usually
1268 * this is the last block it freed; occasionally it might be farther
1269 * back.  We have to search all the free lists for the block in order
1270 * to determine its bucket: 1st we make one pass thru the lists
1271 * checking only the first block in each; if that fails we search
1272 * ``reall_srchlen'' blocks in each list for a match (the variable
1273 * is extern so the caller can modify it).  If that fails we just copy
1274 * however many bytes was given to realloc() and hope it's not huge.
1275 */
1276int reall_srchlen = 4;  /* 4 should be plenty, -1 =>'s whole list */
1277
1278Malloc_t
1279realloc(void *mp, size_t nbytes)
1280{
1281        register MEM_SIZE onb;
1282        union overhead *ovp;
1283        char *res;
1284        int prev_bucket;
1285        register int bucket;
1286        int was_alloced = 0, incr;
1287        char *cp = (char*)mp;
1288
1289#if defined(DEBUGGING) || !defined(PERL_CORE)
1290        MEM_SIZE size = nbytes;
1291
1292        if ((long)nbytes < 0)
1293                croak("%s", "panic: realloc");
1294#endif
1295
1296        BARK_64K_LIMIT("Reallocation",nbytes,size);
1297        if (!cp)
1298                return malloc(nbytes);
1299
1300        MUTEX_LOCK(&PL_malloc_mutex);
1301        ovp = (union overhead *)((caddr_t)cp
1302                                - sizeof (union overhead) * CHUNK_SHIFT);
1303        bucket = OV_INDEX(ovp);
1304#ifdef IGNORE_SMALL_BAD_FREE
1305        if ((bucket < FIRST_BUCKET_WITH_CHECK)
1306            || (OV_MAGIC(ovp, bucket) == MAGIC))
1307#else
1308        if (OV_MAGIC(ovp, bucket) == MAGIC)
1309#endif
1310        {
1311                was_alloced = 1;
1312        } else {
1313                /*
1314                 * Already free, doing "compaction".
1315                 *
1316                 * Search for the old block of memory on the
1317                 * free list.  First, check the most common
1318                 * case (last element free'd), then (this failing)
1319                 * the last ``reall_srchlen'' items free'd.
1320                 * If all lookups fail, then assume the size of
1321                 * the memory block being realloc'd is the
1322                 * smallest possible.
1323                 */
1324                if ((bucket = findbucket(ovp, 1)) < 0 &&
1325                    (bucket = findbucket(ovp, reall_srchlen)) < 0)
1326                        bucket = 0;
1327        }
1328        onb = BUCKET_SIZE_REAL(bucket);
1329        /*
1330         *  avoid the copy if same size block.
1331         *  We are not agressive with boundary cases. Note that it might
1332         *  (for a small number of cases) give false negative if
1333         *  both new size and old one are in the bucket for
1334         *  FIRST_BIG_POW2, but the new one is near the lower end.
1335         *
1336         *  We do not try to go to 1.5 times smaller bucket so far.
1337         */
1338        if (nbytes > onb) incr = 1;
1339        else {
1340#ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING
1341            if ( /* This is a little bit pessimal if PACK_MALLOC: */
1342                nbytes > ( (onb >> 1) - M_OVERHEAD )
1343#  ifdef TWO_POT_OPTIMIZE
1344                || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND )
1345#  endif       
1346                )
1347#else  /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1348                prev_bucket = ( (bucket > MAX_PACKED + 1)
1349                                ? bucket - BUCKETS_PER_POW2
1350                                : bucket - 1);
1351             if (nbytes > BUCKET_SIZE_REAL(prev_bucket))
1352#endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
1353                 incr = 0;
1354             else incr = -1;
1355        }
1356        if (!was_alloced
1357#ifdef STRESS_REALLOC
1358            || 1 /* always do it the hard way */
1359#endif
1360            ) goto hard_way;
1361        else if (incr == 0) {
1362          inplace_label:
1363#ifdef RCHECK
1364                /*
1365                 * Record new allocated size of block and
1366                 * bound space with magic numbers.
1367                 */
1368                if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
1369                       int i, nb = ovp->ov_size + 1;
1370
1371                       if ((i = nb & 3)) {
1372                           i = 4 - i;
1373                           while (i--) {
1374                               ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite");
1375                           }
1376                       }
1377                       nb = (nb + 3) &~ 3;
1378                       ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite");
1379                        /*
1380                         * Convert amount of memory requested into
1381                         * closest block size stored in hash buckets
1382                         * which satisfies request.  Account for
1383                         * space used per block for accounting.
1384                         */
1385                        nbytes += M_OVERHEAD;
1386                        ovp->ov_size = nbytes - 1;
1387                        if ((i = nbytes & 3)) {
1388                            i = 4 - i;
1389                            while (i--)
1390                                *((char *)((caddr_t)ovp + nbytes - RSLOP + i))
1391                                    = RMAGIC_C;
1392                        }
1393                        nbytes = (nbytes + 3) &~ 3;
1394                        *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
1395                }
1396#endif
1397                res = cp;
1398                MUTEX_UNLOCK(&PL_malloc_mutex);
1399                DEBUG_m(PerlIO_printf(Perl_debug_log,
1400                              "0x%lx: (%05lu) realloc %ld bytes inplace\n",
1401                              (unsigned long)res,(unsigned long)(PL_an++),
1402                              (long)size));
1403        } else if (incr == 1 && (cp - M_OVERHEAD == last_op)
1404                   && (onb > (1 << LOG_OF_MIN_ARENA))) {
1405            MEM_SIZE require, newarena = nbytes, pow;
1406            int shiftr;
1407
1408            POW2_OPTIMIZE_ADJUST(newarena);
1409            newarena = newarena + M_OVERHEAD;
1410            /* newarena = (newarena + 3) &~ 3; */
1411            shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA;
1412            pow = LOG_OF_MIN_ARENA + 1;
1413            /* apart from this loop, this is O(1) */
1414            while (shiftr >>= 1)
1415                pow++;
1416            newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2);
1417            require = newarena - onb - M_OVERHEAD;
1418       
1419            if (getpages_adjacent(require)) {
1420#ifdef DEBUGGING_MSTATS
1421                nmalloc[bucket]--;
1422                nmalloc[pow * BUCKETS_PER_POW2]++;
1423#endif 
1424                *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
1425                goto inplace_label;
1426            } else
1427                goto hard_way;
1428        } else {
1429          hard_way:
1430            MUTEX_UNLOCK(&PL_malloc_mutex);
1431            DEBUG_m(PerlIO_printf(Perl_debug_log,
1432                              "0x%lx: (%05lu) realloc %ld bytes the hard way\n",
1433                              (unsigned long)cp,(unsigned long)(PL_an++),
1434                              (long)size));
1435            if ((res = (char*)malloc(nbytes)) == NULL)
1436                return (NULL);
1437            if (cp != res)                      /* common optimization */
1438                Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
1439            if (was_alloced)
1440                free(cp);
1441        }
1442        return ((Malloc_t)res);
1443}
1444
1445/*
1446 * Search ``srchlen'' elements of each free list for a block whose
1447 * header starts at ``freep''.  If srchlen is -1 search the whole list.
1448 * Return bucket number, or -1 if not found.
1449 */
1450static int
1451findbucket(union overhead *freep, int srchlen)
1452{
1453        register union overhead *p;
1454        register int i, j;
1455
1456        for (i = 0; i < NBUCKETS; i++) {
1457                j = 0;
1458                for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
1459                        if (p == freep)
1460                                return (i);
1461                        j++;
1462                }
1463        }
1464        return (-1);
1465}
1466
1467Malloc_t
1468calloc(register size_t elements, register size_t size)
1469{
1470    long sz = elements * size;
1471    Malloc_t p = malloc(sz);
1472
1473    if (p) {
1474        memset((void*)p, 0, sz);
1475    }
1476    return p;
1477}
1478
1479MEM_SIZE
1480malloced_size(void *p)
1481{
1482    union overhead *ovp = (union overhead *)
1483        ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
1484    int bucket = OV_INDEX(ovp);
1485#ifdef RCHECK
1486    /* The caller wants to have a complete control over the chunk,
1487       disable the memory checking inside the chunk.  */
1488    if (bucket <= MAX_SHORT_BUCKET) {
1489        MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
1490        ovp->ov_size = size + M_OVERHEAD - 1;
1491        *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC;
1492    }
1493#endif
1494    return BUCKET_SIZE_REAL(bucket);
1495}
1496
1497#ifdef DEBUGGING_MSTATS
1498
1499#  ifdef BUCKETS_ROOT2
1500#    define MIN_EVEN_REPORT 6
1501#  else
1502#    define MIN_EVEN_REPORT MIN_BUCKET
1503#  endif
1504/*
1505 * mstats - print out statistics about malloc
1506 *
1507 * Prints two lines of numbers, one showing the length of the free list
1508 * for each size category, the second showing the number of mallocs -
1509 * frees for each size category.
1510 */
1511void
1512dump_mstats(char *s)
1513{
1514        register int i, j;
1515        register union overhead *p;
1516        int topbucket=0, topbucket_ev=0, topbucket_odd=0, totfree=0, total=0;
1517        u_int nfree[NBUCKETS];
1518        int total_chain = 0;
1519        struct chunk_chain_s* nextchain = chunk_chain;
1520
1521        for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
1522                for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
1523                        ;
1524                nfree[i] = j;
1525                totfree += nfree[i] * BUCKET_SIZE_REAL(i);
1526                total += nmalloc[i] * BUCKET_SIZE_REAL(i);
1527                if (nmalloc[i]) {
1528                    i % 2 ? (topbucket_odd = i) : (topbucket_ev = i);
1529                    topbucket = i;
1530                }
1531        }
1532        if (s)
1533            PerlIO_printf(PerlIO_stderr(),
1534                          "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n",
1535                          s,
1536                          (long)BUCKET_SIZE_REAL(MIN_BUCKET),
1537                          (long)BUCKET_SIZE(MIN_BUCKET),
1538                          (long)BUCKET_SIZE_REAL(topbucket), (long)BUCKET_SIZE(topbucket));
1539        PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree);
1540        for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
1541                PerlIO_printf(PerlIO_stderr(),
1542                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1543                               ? " %5d"
1544                               : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1545                              nfree[i]);
1546        }
1547#ifdef BUCKETS_ROOT2
1548        PerlIO_printf(PerlIO_stderr(), "\n\t   ");
1549        for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
1550                PerlIO_printf(PerlIO_stderr(),
1551                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1552                               ? " %5d"
1553                               : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1554                              nfree[i]);
1555        }
1556#endif
1557        PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree);
1558        for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
1559                PerlIO_printf(PerlIO_stderr(),
1560                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1561                               ? " %5d"
1562                               : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1563                              nmalloc[i] - nfree[i]);
1564        }
1565#ifdef BUCKETS_ROOT2
1566        PerlIO_printf(PerlIO_stderr(), "\n\t   ");
1567        for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
1568                PerlIO_printf(PerlIO_stderr(),
1569                              ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
1570                               ? " %5d"
1571                               : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
1572                              nmalloc[i] - nfree[i]);
1573        }
1574#endif
1575        while (nextchain) {
1576            total_chain += nextchain->size;
1577            nextchain = nextchain->next;
1578        }
1579        PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %d/%d:%d. Odd ends: pad+heads+chain+tail: %d+%d+%d+%d.\n",
1580                      goodsbrk + sbrk_slack, sbrks, sbrk_good, sbrk_slack,
1581                      start_slack, total_chain, sbrked_remains);
1582}
1583#else
1584void
1585dump_mstats(char *s)
1586{
1587}
1588#endif
1589#endif /* lint */
1590
1591
1592#ifdef USE_PERL_SBRK
1593
1594#   if defined(__MACHTEN_PPC__) || defined(__NeXT__)
1595#      define PERL_SBRK_VIA_MALLOC
1596/*
1597 * MachTen's malloc() returns a buffer aligned on a two-byte boundary.
1598 * While this is adequate, it may slow down access to longer data
1599 * types by forcing multiple memory accesses.  It also causes
1600 * complaints when RCHECK is in force.  So we allocate six bytes
1601 * more than we need to, and return an address rounded up to an
1602 * eight-byte boundary.
1603 *
1604 * 980701 Dominic Dunlop <domo@computer.org>
1605 */
1606#      define SYSTEM_ALLOC(a) ((void *)(((unsigned)malloc((a)+6)+6)&~7))
1607#   endif
1608
1609#   ifdef PERL_SBRK_VIA_MALLOC
1610#      if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
1611#         undef malloc          /* Expose names that  */
1612#         undef calloc          /* HIDEMYMALLOC hides */
1613#         undef realloc
1614#         undef free
1615#      else
1616#         include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC"
1617#      endif
1618
1619/* it may seem schizophrenic to use perl's malloc and let it call system */
1620/* malloc, the reason for that is only the 3.2 version of the OS that had */
1621/* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
1622/* end to the cores */
1623
1624#      ifndef SYSTEM_ALLOC
1625#         define SYSTEM_ALLOC(a) malloc(a)
1626#      endif
1627
1628#   endif  /* PERL_SBRK_VIA_MALLOC */
1629
1630static IV Perl_sbrk_oldchunk;
1631static long Perl_sbrk_oldsize;
1632
1633#   define PERLSBRK_32_K (1<<15)
1634#   define PERLSBRK_64_K (1<<16)
1635
1636Malloc_t
1637Perl_sbrk(int size)
1638{
1639    IV got;
1640    int small, reqsize;
1641
1642    if (!size) return 0;
1643#ifdef PERL_CORE
1644    reqsize = size; /* just for the DEBUG_m statement */
1645#endif
1646#ifdef PACK_MALLOC
1647    size = (size + 0x7ff) & ~0x7ff;
1648#endif
1649    if (size <= Perl_sbrk_oldsize) {
1650        got = Perl_sbrk_oldchunk;
1651        Perl_sbrk_oldchunk += size;
1652        Perl_sbrk_oldsize -= size;
1653    } else {
1654      if (size >= PERLSBRK_32_K) {
1655        small = 0;
1656      } else {
1657        size = PERLSBRK_64_K;
1658        small = 1;
1659      }
1660      got = (IV)SYSTEM_ALLOC(size);
1661#ifdef PACK_MALLOC
1662      got = (got + 0x7ff) & ~0x7ff;
1663#endif
1664      if (small) {
1665        /* Chunk is small, register the rest for future allocs. */
1666        Perl_sbrk_oldchunk = got + reqsize;
1667        Perl_sbrk_oldsize = size - reqsize;
1668      }
1669    }
1670
1671    DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
1672                    size, reqsize, Perl_sbrk_oldsize, got));
1673
1674    return (void *)got;
1675}
1676#endif /* ! defined USE_PERL_SBRK */
Note: See TracBrowser for help on using the repository browser.