perl 5.003_01: pod/perlxstut.pod
[p5sagit/p5-mst-13.2.git] / malloc.c
CommitLineData
a0d0e21e 1/* malloc.c
8d063cd8 2 *
8d063cd8 3 */
4
5#ifndef lint
a687059c 6#ifdef DEBUGGING
8d063cd8 7#define RCHECK
a687059c 8#endif
8d063cd8 9/*
10 * malloc.c (Caltech) 2/21/82
11 * Chris Kingsley, kingsley@cit-20.
12 *
13 * This is a very fast storage allocator. It allocates blocks of a small
14 * number of different sizes, and keeps free lists of each size. Blocks that
15 * don't exactly fit are passed up to the next larger size. In this
16 * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
cf5c4ad8 17 * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
8d063cd8 18 * This is designed for use in a program that uses vast quantities of memory,
19 * but bombs when it runs out.
20 */
21
135863df 22#include "EXTERN.h"
135863df 23#include "perl.h"
24
25/* I don't much care whether these are defined in sys/types.h--LAW */
26
27#define u_char unsigned char
28#define u_int unsigned int
29#define u_short unsigned short
8d063cd8 30
cf5c4ad8 31/* 286 and atarist like big chunks, which gives too much overhead. */
32#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
33#undef PACK_MALLOC
34#endif
35
36
8d063cd8 37/*
cf5c4ad8 38 * The description below is applicable if PACK_MALLOC is not defined.
39 *
8d063cd8 40 * The overhead on a block is at least 4 bytes. When free, this space
41 * contains a pointer to the next free block, and the bottom two bits must
42 * be zero. When in use, the first byte is set to MAGIC, and the second
43 * byte is the size index. The remaining bytes are for alignment.
44 * If range checking is enabled and the size of the block fits
45 * in two bytes, then the top two bytes hold the size of the requested block
46 * plus the range checking words, and the header word MINUS ONE.
47 */
48union overhead {
49 union overhead *ov_next; /* when free */
85e6fe83 50#if MEM_ALIGNBYTES > 4
c623bd54 51 double strut; /* alignment problems */
a687059c 52#endif
8d063cd8 53 struct {
54 u_char ovu_magic; /* magic number */
55 u_char ovu_index; /* bucket # */
56#ifdef RCHECK
57 u_short ovu_size; /* actual block size */
58 u_int ovu_rmagic; /* range magic number */
59#endif
60 } ovu;
61#define ov_magic ovu.ovu_magic
62#define ov_index ovu.ovu_index
63#define ov_size ovu.ovu_size
64#define ov_rmagic ovu.ovu_rmagic
65};
66
a0d0e21e 67#ifdef debug
68static void botch _((char *s));
69#endif
70static void morecore _((int bucket));
71static int findbucket _((union overhead *freep, int srchlen));
72
8d063cd8 73#define MAGIC 0xff /* magic # on accounting info */
74#define RMAGIC 0x55555555 /* magic # on range info */
75#ifdef RCHECK
76#define RSLOP sizeof (u_int)
77#else
78#define RSLOP 0
79#endif
80
cf5c4ad8 81#ifdef PACK_MALLOC
82/*
83 * In this case it is assumed that if we do sbrk() in 2K units, we
84 * will get 2K aligned blocks. The bucket number of the given subblock is
85 * on the boundary of 2K block which contains the subblock.
86 * Several following bytes contain the magic numbers for the subblocks
87 * in the block.
88 *
89 * Sizes of chunks are powers of 2 for chunks in buckets <=
90 * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to
91 * get alignment right).
92 *
93 * We suppose that starts of all the chunks in a 2K block are in
94 * different 2^n-byte-long chunks. If the top of the last chunk is
95 * aligned on a boundary of 2K block, this means that
96 * sizeof(union overhead)*"number of chunks" < 2^n, or
97 * sizeof(union overhead)*2K < 4^n, or n > 6 + log2(sizeof()/2)/2, if a
98 * chunk of size 2^n - overhead is used. Since this rules out n = 7
99 * for 8 byte alignment, we specialcase allocation of the first of 16
100 * 128-byte-long chunks.
101 *
102 * Note that with the above assumption we automatically have enough
103 * place for MAGIC at the start of 2K block. Note also that we
104 * overlay union overhead over the chunk, thus the start of the chunk
105 * is immediately overwritten after freeing.
106 */
107# define MAX_PACKED 6
108# define MAX_2_POT_ALGO ((1<<(MAX_PACKED + 1)) - M_OVERHEAD)
109# define TWOK_MASK ((1<<11) - 1)
110# define TWOK_MASKED(x) ((int)x & ~TWOK_MASK)
111# define TWOK_SHIFT(x) ((int)x & TWOK_MASK)
112# define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block)))
113# define OV_INDEX(block) (*OV_INDEXp(block))
114# define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \
115 (TWOK_SHIFT(block)>>(bucket + 3)) + \
116 (bucket > MAX_NONSHIFT ? 1 : 0)))
117# define CHUNK_SHIFT 0
118
119static u_char n_blks[11 - 3] = {224, 120, 62, 31, 16, 8, 4, 2};
120static u_short blk_shift[11 - 3] = {256, 128, 64, 32,
121 16*sizeof(union overhead),
122 8*sizeof(union overhead),
123 4*sizeof(union overhead),
124 2*sizeof(union overhead),
125# define MAX_NONSHIFT 2 /* Shift 64 greater than chunk 32. */
126};
127
128# ifdef DEBUGGING_MSTATS
129static u_int sbrk_slack;
130static u_int start_slack;
131# endif
132
133#else /* !PACK_MALLOC */
134
135# define OV_MAGIC(block,bucket) (block)->ov_magic
136# define OV_INDEX(block) (block)->ov_index
137# define CHUNK_SHIFT 1
138#endif /* !PACK_MALLOC */
139
140# define M_OVERHEAD (sizeof(union overhead) + RSLOP)
141
8d063cd8 142/*
143 * nextf[i] is the pointer to the next free block of size 2^(i+3). The
144 * smallest allocatable block is 8 bytes. The overhead information
145 * precedes the data area returned to the user.
146 */
147#define NBUCKETS 30
148static union overhead *nextf[NBUCKETS];
cf5c4ad8 149
150#ifdef USE_PERL_SBRK
151#define sbrk(a) Perl_sbrk(a)
152char * Perl_sbrk _((int size));
153#else
8d063cd8 154extern char *sbrk();
cf5c4ad8 155#endif
8d063cd8 156
c07a80fd 157#ifdef DEBUGGING_MSTATS
8d063cd8 158/*
159 * nmalloc[i] is the difference between the number of mallocs and frees
160 * for a given block size.
161 */
162static u_int nmalloc[NBUCKETS];
163#include <stdio.h>
164#endif
165
166#ifdef debug
167#define ASSERT(p) if (!(p)) botch("p"); else
ee0007ab 168static void
8d063cd8 169botch(s)
170 char *s;
171{
172
173 printf("assertion botched: %s\n", s);
174 abort();
175}
176#else
177#define ASSERT(p)
178#endif
179
2304df62 180Malloc_t
8d063cd8 181malloc(nbytes)
ee0007ab 182 register MEM_SIZE nbytes;
8d063cd8 183{
184 register union overhead *p;
185 register int bucket = 0;
ee0007ab 186 register MEM_SIZE shiftr;
8d063cd8 187
45d8adaa 188#ifdef safemalloc
189#ifdef DEBUGGING
ee0007ab 190 MEM_SIZE size = nbytes;
45d8adaa 191#endif
192
193#ifdef MSDOS
194 if (nbytes > 0xffff) {
ee0007ab 195 fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes);
79072805 196 my_exit(1);
45d8adaa 197 }
198#endif /* MSDOS */
199#ifdef DEBUGGING
200 if ((long)nbytes < 0)
463ee0b2 201 croak("panic: malloc");
45d8adaa 202#endif
203#endif /* safemalloc */
204
8d063cd8 205 /*
206 * Convert amount of memory requested into
207 * closest block size stored in hash buckets
208 * which satisfies request. Account for
209 * space used per block for accounting.
210 */
cf5c4ad8 211#ifdef PACK_MALLOC
212 if (nbytes > MAX_2_POT_ALGO) {
213#endif
214 nbytes += M_OVERHEAD;
215 nbytes = (nbytes + 3) &~ 3;
216#ifdef PACK_MALLOC
217 } else if (nbytes == 0) {
218 nbytes = 1;
219 }
220#endif
8d063cd8 221 shiftr = (nbytes - 1) >> 2;
222 /* apart from this loop, this is O(1) */
223 while (shiftr >>= 1)
224 bucket++;
225 /*
226 * If nothing in hash bucket right now,
227 * request more memory from the system.
228 */
229 if (nextf[bucket] == NULL)
230 morecore(bucket);
45d8adaa 231 if ((p = (union overhead *)nextf[bucket]) == NULL) {
232#ifdef safemalloc
ee0007ab 233 if (!nomemok) {
234 fputs("Out of memory!\n", stderr);
79072805 235 my_exit(1);
ee0007ab 236 }
45d8adaa 237#else
8d063cd8 238 return (NULL);
45d8adaa 239#endif
240 }
241
242#ifdef safemalloc
cf5c4ad8 243 DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) malloc %ld bytes\n",
a0d0e21e 244 (unsigned long)(p+1),an++,(long)size));
45d8adaa 245#endif /* safemalloc */
246
8d063cd8 247 /* remove from linked list */
bf38876a 248#ifdef RCHECK
249 if (*((int*)p) & (sizeof(union overhead) - 1))
a0d0e21e 250 fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",
251 (unsigned long)*((int*)p),(unsigned long)p);
bf38876a 252#endif
253 nextf[bucket] = p->ov_next;
cf5c4ad8 254 OV_MAGIC(p, bucket) = MAGIC;
255#ifndef PACK_MALLOC
256 OV_INDEX(p) = bucket;
257#endif
c07a80fd 258#ifdef DEBUGGING_MSTATS
8d063cd8 259 nmalloc[bucket]++;
260#endif
261#ifdef RCHECK
262 /*
263 * Record allocated size of block and
264 * bound space with magic numbers.
265 */
266 if (nbytes <= 0x10000)
267 p->ov_size = nbytes - 1;
268 p->ov_rmagic = RMAGIC;
269 *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
270#endif
cf5c4ad8 271 return ((Malloc_t)(p + CHUNK_SHIFT));
8d063cd8 272}
273
274/*
275 * Allocate more memory to the indicated bucket.
276 */
a0d0e21e 277static void
8d063cd8 278morecore(bucket)
a687059c 279 register int bucket;
8d063cd8 280{
281 register union overhead *op;
282 register int rnu; /* 2^rnu bytes will be requested */
283 register int nblks; /* become nblks blocks of the desired size */
ee0007ab 284 register MEM_SIZE siz;
cf5c4ad8 285 int slack = 0;
8d063cd8 286
287 if (nextf[bucket])
288 return;
289 /*
290 * Insure memory is allocated
291 * on a page boundary. Should
292 * make getpageize call?
293 */
ee0007ab 294#ifndef atarist /* on the atari we dont have to worry about this */
8d063cd8 295 op = (union overhead *)sbrk(0);
cf5c4ad8 296# ifndef I286
297# ifdef PACK_MALLOC
298 if ((int)op & 0x7ff)
299 (void)sbrk(slack = 2048 - ((int)op & 0x7ff));
300# else
8d063cd8 301 if ((int)op & 0x3ff)
cf5c4ad8 302 (void)sbrk(slack = 1024 - ((int)op & 0x3ff));
303# endif
304# if defined(DEBUGGING_MSTATS) && defined(PACK_MALLOC)
305 sbrk_slack += slack;
306# endif
307# else
a687059c 308 /* The sbrk(0) call on the I286 always returns the next segment */
cf5c4ad8 309# endif
ee0007ab 310#endif /* atarist */
a687059c 311
ee0007ab 312#if !(defined(I286) || defined(atarist))
8d063cd8 313 /* take 2k unless the block is bigger than that */
314 rnu = (bucket <= 8) ? 11 : bucket + 3;
a687059c 315#else
316 /* take 16k unless the block is bigger than that
ee0007ab 317 (80286s like large segments!), probably good on the atari too */
a687059c 318 rnu = (bucket <= 11) ? 14 : bucket + 3;
319#endif
8d063cd8 320 nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */
cf5c4ad8 321 /* if (rnu < bucket)
322 rnu = bucket; Why anyone needs this? */
ee0007ab 323 op = (union overhead *)sbrk(1L << rnu);
8d063cd8 324 /* no more room! */
325 if ((int)op == -1)
326 return;
327 /*
328 * Round up to minimum allocation size boundary
329 * and deduct from block count to reflect.
330 */
a687059c 331#ifndef I286
cf5c4ad8 332# ifdef PACK_MALLOC
333 if ((int)op & 0x7ff)
334 croak("panic: Off-page sbrk");
335# endif
8d063cd8 336 if ((int)op & 7) {
ee0007ab 337 op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7);
8d063cd8 338 nblks--;
339 }
a687059c 340#else
341 /* Again, this should always be ok on an 80286 */
342#endif
8d063cd8 343 /*
344 * Add new memory allocated to that on
345 * free list for this hash bucket.
346 */
8d063cd8 347 siz = 1 << (bucket + 3);
cf5c4ad8 348#ifdef PACK_MALLOC
349 *(u_char*)op = bucket; /* Fill index. */
350 if (bucket <= MAX_PACKED - 3) {
351 op = (union overhead *) ((char*)op + blk_shift[bucket]);
352 nblks = n_blks[bucket];
353# ifdef DEBUGGING_MSTATS
354 start_slack += blk_shift[bucket];
355# endif
356 } else if (bucket <= 11 - 1 - 3) {
357 op = (union overhead *) ((char*)op + blk_shift[bucket]);
358 /* nblks = n_blks[bucket]; */
359 siz -= sizeof(union overhead);
360 } else op++; /* One chunk per block. */
361#endif /* !PACK_MALLOC */
362 nextf[bucket] = op;
8d063cd8 363 while (--nblks > 0) {
364 op->ov_next = (union overhead *)((caddr_t)op + siz);
365 op = (union overhead *)((caddr_t)op + siz);
366 }
cf5c4ad8 367#if defined(USE_PERL_SBRK) || defined(OS2)
368 /* all real sbrks return zeroe-d memory, perl's sbrk doesn't guarantee this */
369 op->ov_next = (union overhead *)NULL;
370#endif
371#ifdef PACK_MALLOC
372 if (bucket == 7 - 3) { /* Special case, explanation is above. */
373 union overhead *n_op = nextf[7 - 3]->ov_next;
374 nextf[7 - 3] = (union overhead *)((caddr_t)nextf[7 - 3]
375 - sizeof(union overhead));
376 nextf[7 - 3]->ov_next = n_op;
377 }
378#endif /* !PACK_MALLOC */
8d063cd8 379}
380
94b6baf5 381Free_t
352d5a3a 382free(mp)
2304df62 383 Malloc_t mp;
8d063cd8 384{
ee0007ab 385 register MEM_SIZE size;
8d063cd8 386 register union overhead *op;
352d5a3a 387 char *cp = (char*)mp;
cf5c4ad8 388#ifdef PACK_MALLOC
389 u_char bucket;
390#endif
8d063cd8 391
45d8adaa 392#ifdef safemalloc
cf5c4ad8 393 DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",(unsigned long)cp,an++));
45d8adaa 394#endif /* safemalloc */
395
cf5c4ad8 396 if (cp == NULL)
397 return;
398 op = (union overhead *)((caddr_t)cp
399 - sizeof (union overhead) * CHUNK_SHIFT);
400#ifdef PACK_MALLOC
401 bucket = OV_INDEX(op);
402#endif
8d063cd8 403#ifdef debug
cf5c4ad8 404 ASSERT(OV_MAGIC(op, bucket) == MAGIC); /* make sure it was in use */
8d063cd8 405#else
cf5c4ad8 406 if (OV_MAGIC(op, bucket) != MAGIC) {
407 static bad_free_warn = -1;
408 if (bad_free_warn == -1) {
409 char *pbf = getenv("PERL_BADFREE");
410 bad_free_warn = (pbf) ? atoi(pbf) : 1;
411 }
412 if (!bad_free_warn)
413 return;
8990e307 414#ifdef RCHECK
a687059c 415 warn("%s free() ignored",
8990e307 416 op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
417#else
418 warn("Bad free() ignored");
419#endif
8d063cd8 420 return; /* sanity */
378cc40b 421 }
8d063cd8 422#endif
423#ifdef RCHECK
424 ASSERT(op->ov_rmagic == RMAGIC);
cf5c4ad8 425 if (OV_INDEX(op) <= 13)
8d063cd8 426 ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
8990e307 427 op->ov_rmagic = RMAGIC - 1;
8d063cd8 428#endif
cf5c4ad8 429 ASSERT(OV_INDEX(op) < NBUCKETS);
430 size = OV_INDEX(op);
8d063cd8 431 op->ov_next = nextf[size];
432 nextf[size] = op;
c07a80fd 433#ifdef DEBUGGING_MSTATS
8d063cd8 434 nmalloc[size]--;
435#endif
436}
437
438/*
439 * When a program attempts "storage compaction" as mentioned in the
440 * old malloc man page, it realloc's an already freed block. Usually
441 * this is the last block it freed; occasionally it might be farther
442 * back. We have to search all the free lists for the block in order
443 * to determine its bucket: 1st we make one pass thru the lists
444 * checking only the first block in each; if that fails we search
378cc40b 445 * ``reall_srchlen'' blocks in each list for a match (the variable
8d063cd8 446 * is extern so the caller can modify it). If that fails we just copy
447 * however many bytes was given to realloc() and hope it's not huge.
448 */
378cc40b 449int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
8d063cd8 450
2304df62 451Malloc_t
352d5a3a 452realloc(mp, nbytes)
2304df62 453 Malloc_t mp;
ee0007ab 454 MEM_SIZE nbytes;
8d063cd8 455{
ee0007ab 456 register MEM_SIZE onb;
8d063cd8 457 union overhead *op;
458 char *res;
459 register int i;
460 int was_alloced = 0;
352d5a3a 461 char *cp = (char*)mp;
8d063cd8 462
45d8adaa 463#ifdef safemalloc
464#ifdef DEBUGGING
ee0007ab 465 MEM_SIZE size = nbytes;
45d8adaa 466#endif
467
468#ifdef MSDOS
469 if (nbytes > 0xffff) {
470 fprintf(stderr, "Reallocation too large: %lx\n", size);
79072805 471 my_exit(1);
45d8adaa 472 }
473#endif /* MSDOS */
474 if (!cp)
ee0007ab 475 return malloc(nbytes);
45d8adaa 476#ifdef DEBUGGING
477 if ((long)nbytes < 0)
463ee0b2 478 croak("panic: realloc");
45d8adaa 479#endif
480#endif /* safemalloc */
481
cf5c4ad8 482 op = (union overhead *)((caddr_t)cp
483 - sizeof (union overhead) * CHUNK_SHIFT);
484 i = OV_INDEX(op);
485 if (OV_MAGIC(op, i) == MAGIC) {
8d063cd8 486 was_alloced++;
8d063cd8 487 } else {
488 /*
489 * Already free, doing "compaction".
490 *
491 * Search for the old block of memory on the
492 * free list. First, check the most common
493 * case (last element free'd), then (this failing)
378cc40b 494 * the last ``reall_srchlen'' items free'd.
8d063cd8 495 * If all lookups fail, then assume the size of
496 * the memory block being realloc'd is the
497 * smallest possible.
498 */
499 if ((i = findbucket(op, 1)) < 0 &&
378cc40b 500 (i = findbucket(op, reall_srchlen)) < 0)
8d063cd8 501 i = 0;
502 }
cf5c4ad8 503 onb = (1L << (i + 3)) -
504#ifdef PACK_MALLOC
505 (i <= (MAX_PACKED - 3) ? 0 : M_OVERHEAD)
506#else
507 M_OVERHEAD
508#endif
509 ;
8d063cd8 510 /* avoid the copy if same size block */
511 if (was_alloced &&
cf5c4ad8 512 nbytes <= onb && nbytes > (onb >> 1) - M_OVERHEAD) {
a687059c 513#ifdef RCHECK
514 /*
515 * Record new allocated size of block and
516 * bound space with magic numbers.
517 */
cf5c4ad8 518 if (OV_INDEX(op) <= 13) {
a687059c 519 /*
520 * Convert amount of memory requested into
521 * closest block size stored in hash buckets
522 * which satisfies request. Account for
523 * space used per block for accounting.
524 */
cf5c4ad8 525 nbytes += M_OVERHEAD;
a687059c 526 nbytes = (nbytes + 3) &~ 3;
527 op->ov_size = nbytes - 1;
528 *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
529 }
530#endif
45d8adaa 531 res = cp;
a687059c 532 }
45d8adaa 533 else {
534 if ((res = (char*)malloc(nbytes)) == NULL)
535 return (NULL);
536 if (cp != res) /* common optimization */
ee0007ab 537 Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
45d8adaa 538 if (was_alloced)
539 free(cp);
540 }
541
542#ifdef safemalloc
543#ifdef DEBUGGING
a0d0e21e 544 if (debug & 128) {
545 fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)res,an++);
546 fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",
547 (unsigned long)res,an++,(long)size);
548 }
45d8adaa 549#endif
550#endif /* safemalloc */
2304df62 551 return ((Malloc_t)res);
8d063cd8 552}
553
554/*
555 * Search ``srchlen'' elements of each free list for a block whose
556 * header starts at ``freep''. If srchlen is -1 search the whole list.
557 * Return bucket number, or -1 if not found.
558 */
ee0007ab 559static int
8d063cd8 560findbucket(freep, srchlen)
561 union overhead *freep;
562 int srchlen;
563{
564 register union overhead *p;
565 register int i, j;
566
567 for (i = 0; i < NBUCKETS; i++) {
568 j = 0;
569 for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
570 if (p == freep)
571 return (i);
572 j++;
573 }
574 }
575 return (-1);
576}
577
cf5c4ad8 578Malloc_t
579calloc(elements, size)
580 register MEM_SIZE elements;
581 register MEM_SIZE size;
582{
583 long sz = elements * size;
584 Malloc_t p = malloc(sz);
585
586 if (p) {
587 memset((void*)p, 0, sz);
588 }
589 return p;
590}
591
c07a80fd 592#ifdef DEBUGGING_MSTATS
8d063cd8 593/*
594 * mstats - print out statistics about malloc
595 *
596 * Prints two lines of numbers, one showing the length of the free list
597 * for each size category, the second showing the number of mallocs -
598 * frees for each size category.
599 */
ee0007ab 600void
c07a80fd 601dump_mstats(s)
8d063cd8 602 char *s;
603{
604 register int i, j;
605 register union overhead *p;
c07a80fd 606 int topbucket=0, totfree=0, totused=0;
607 u_int nfree[NBUCKETS];
8d063cd8 608
c07a80fd 609 for (i=0; i < NBUCKETS; i++) {
8d063cd8 610 for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
611 ;
c07a80fd 612 nfree[i] = j;
613 totfree += nfree[i] * (1 << (i + 3));
8d063cd8 614 totused += nmalloc[i] * (1 << (i + 3));
c07a80fd 615 if (nfree[i] || nmalloc[i])
616 topbucket = i;
617 }
618 if (s)
619 fprintf(stderr, "Memory allocation statistics %s (buckets 8..%d)\n",
620 s, (1 << (topbucket + 3)) );
621 fprintf(stderr, " %7d free: ", totfree);
622 for (i=0; i <= topbucket; i++) {
623 fprintf(stderr, (i<5)?" %5d":" %3d", nfree[i]);
8d063cd8 624 }
c07a80fd 625 fprintf(stderr, "\n %7d used: ", totused);
626 for (i=0; i <= topbucket; i++) {
627 fprintf(stderr, (i<5)?" %5d":" %3d", nmalloc[i]);
628 }
629 fprintf(stderr, "\n");
cf5c4ad8 630#ifdef PACK_MALLOC
631 if (sbrk_slack || start_slack) {
632 fprintf(stderr, "Odd ends: %7d bytes from sbrk(), %7d from malloc.\n",
633 sbrk_slack, start_slack);
634 }
635#endif
c07a80fd 636}
637#else
638void
639dump_mstats(s)
640 char *s;
641{
8d063cd8 642}
643#endif
a687059c 644#endif /* lint */
cf5c4ad8 645
646
647#ifdef USE_PERL_SBRK
648
649#ifdef NeXT
650#ifdef HIDEMYMALLOC
651#undef malloc
652#else
653#include "Error: -DUSE_PERL_SBRK on the NeXT requires -DHIDEMYMALLOC"
654#endif
655
656/* it may seem schizophrenic to use perl's malloc and let it call system */
657/* malloc, the reason for that is only the 3.2 version of the OS that had */
658/* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
659/* end to the cores */
660
661#define SYSTEM_ALLOC(a) malloc(a)
662
663#else
664
665/* OS/2 comes to mind ... */
666
667#endif
668
669
670static IV Perl_sbrk_oldchunk;
671static long Perl_sbrk_oldsize;
672
673#define PERLSBRK_32_K (1<<15)
674#define PERLSBRK_64_K (1<<16)
675
676char *
677Perl_sbrk(size)
678int size;
679{
680 IV got;
681 int small, reqsize;
682
683 if (!size) return 0;
684#ifdef safemalloc
685 reqsize = size; /* just for the DEBUG_m statement */
686#endif
687 if (size <= Perl_sbrk_oldsize) {
688 got = Perl_sbrk_oldchunk;
689 Perl_sbrk_oldchunk += size;
690 Perl_sbrk_oldsize -= size;
691 } else {
692 if (size >= PERLSBRK_32_K) {
693 small = 0;
694 } else {
695#ifndef safemalloc
696 reqsize = size;
697#endif
698 size = PERLSBRK_64_K;
699 small = 1;
700 }
701 got = (IV)SYSTEM_ALLOC(size);
702 if (small) {
703 /* Chunk is small, register the rest for future allocs. */
704 Perl_sbrk_oldchunk = got + reqsize;
705 Perl_sbrk_oldsize = size - reqsize;
706 }
707 }
708
709#ifdef safemalloc
710 DEBUG_m(fprintf(stderr,"sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
711 size, reqsize, Perl_sbrk_oldsize, got));
712#endif
713
714 return (void *)got;
715}
716
717#endif /* ! defined USE_PERL_SBRK */