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