X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=dc5a69f383ade167471fe6e64098797f1407a04b;hb=9394203c9c91af30a21f8e1e6ad98183a3989990;hp=ba4aac20e034e1fdc2efb4d32514007f14fa3843;hpb=e93972868551f65a3c55f75eec9e71a0cd42d790;p=p5sagit%2Fp5-mst-13.2.git diff --git a/malloc.c b/malloc.c index ba4aac2..dc5a69f 100644 --- a/malloc.c +++ b/malloc.c @@ -63,6 +63,9 @@ # Which allocator to use if PERL_SBRK_VIA_MALLOC SYSTEM_ALLOC(a) malloc(a) + # Minimal alignment (in bytes, should be a power of 2) of SYSTEM_ALLOC + SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES + # Disable memory overwrite checking with DEBUGGING. Memory and speed # optimization, error reporting pessimization. NO_RCHECK undef @@ -134,6 +137,9 @@ # Type returned by free() Free_t void + # Very fatal condition reporting function (cannot call any ) + fatalcroak(arg) write(2,arg,strlen(arg)) + exit(2) + # Fatal error reporting function croak(format, arg) warn(idem) + exit(1) @@ -141,8 +147,8 @@ warn(format, arg) fprintf(stderr, idem) # Locking/unlocking for MT operation - MALLOC_LOCK MUTEX_LOCK(PL_malloc_mutex) - MALLOC_UNLOCK MUTEX_UNLOCK(PL_malloc_mutex) + MALLOC_LOCK MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex) + MALLOC_UNLOCK MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex) # Locking/unlocking mutex for MT operation MUTEX_LOCK(l) void @@ -179,7 +185,7 @@ #define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */ #define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2) -#if !(defined(I286) || defined(atarist)) +#if !(defined(I286) || defined(atarist) || defined(__MINT__)) /* take 2k unless the block is bigger than that */ # define LOG_OF_MIN_ARENA 11 #else @@ -207,7 +213,7 @@ * This is designed for use in a program that uses vast quantities of memory, * but bombs when it runs out. * - * Modifications Copyright Ilya Zakharevich 1996-98. + * Modifications Copyright Ilya Zakharevich 1996-99. * * Still very quick, but much more thrifty. (Std config is 10% slower * than it was, and takes 67% of old heap size for typical usage.) @@ -221,7 +227,12 @@ #ifdef PERL_CORE # include "EXTERN.h" +#define PERL_IN_MALLOC_C # include "perl.h" +# if defined(PERL_IMPLICIT_CONTEXT) +# define croak Perl_croak_nocontext +# define warn Perl_warn_nocontext +# endif #else # ifdef PERL_FOR_X2P # include "../EXTERN.h" @@ -267,6 +278,15 @@ # ifdef DEBUGGING # undef DEBUGGING # endif +# ifndef pTHX +# define pTHX void +# define pTHX_ +# define dTHX extern int Perl___notused +# define WITH_THX(s) s +# endif +# ifndef PERL_GET_INTERP +# define PERL_GET_INTERP PL_curinterp +# endif #endif #ifndef MUTEX_LOCK @@ -278,16 +298,20 @@ #endif #ifndef MALLOC_LOCK -# define MALLOC_LOCK MUTEX_LOCK(PL_malloc_mutex) +# define MALLOC_LOCK MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex) #endif #ifndef MALLOC_UNLOCK -# define MALLOC_UNLOCK MUTEX_UNLOCK(PL_malloc_mutex) +# define MALLOC_UNLOCK MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex) #endif +# ifndef fatalcroak /* make depend */ +# define fatalcroak(mess) (write(2, (mess), strlen(mess)), exit(2)) +# endif + #ifdef DEBUGGING # undef DEBUG_m -# define DEBUG_m(a) if (PL_debug & 128) a +# define DEBUG_m(a) if (PERL_GET_INTERP && PL_debug & 128) a #endif /* @@ -367,7 +391,7 @@ #define u_short unsigned short /* 286 and atarist like big chunks, which gives too much overhead. */ -#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC) +#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC) # undef PACK_MALLOC #endif @@ -401,13 +425,6 @@ union overhead { #define ov_rmagic ovu.ovu_rmagic }; -#ifdef DEBUGGING -static void botch _((char *diag, char *s)); -#endif -static void morecore _((int bucket)); -static int findbucket _((union overhead *freep, int srchlen)); -static void add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip); - #define MAGIC 0xff /* magic # on accounting info */ #define RMAGIC 0x55555555 /* magic # on range info */ #define RMAGIC_C 0x55 /* magic # on range info */ @@ -567,12 +584,18 @@ static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = # endif }; +# define NEEDED_ALIGNMENT 0x800 /* 2k boundaries */ +# define WANTED_ALIGNMENT 0x800 /* 2k boundaries */ + #else /* !PACK_MALLOC */ # define OV_MAGIC(block,bucket) (block)->ov_magic # define OV_INDEX(block) (block)->ov_index # define CHUNK_SHIFT 1 # define MAX_PACKED -1 +# define NEEDED_ALIGNMENT MEM_ALIGNBYTES +# define WANTED_ALIGNMENT 0x400 /* 1k boundaries */ + #endif /* !PACK_MALLOC */ #define M_OVERHEAD (sizeof(union overhead) + RSLOP) @@ -699,7 +722,18 @@ static char bucket_of[] = static char *emergency_buffer; static MEM_SIZE emergency_buffer_size; -static Malloc_t emergency_sbrk(MEM_SIZE size); + +static int findbucket (union overhead *freep, int srchlen); +static void morecore (register int bucket); +# if defined(DEBUGGING) +static void botch (char *diag, char *s); +# endif +static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip); +static Malloc_t emergency_sbrk (MEM_SIZE size); +static void* get_from_chain (MEM_SIZE size); +static void* get_from_bigger_buckets(int bucket, MEM_SIZE size); +static union overhead *getpages (int needed, int *nblksp, int bucket); +static int getpages_adjacent(int require); static Malloc_t emergency_sbrk(MEM_SIZE size) @@ -719,13 +753,14 @@ emergency_sbrk(MEM_SIZE size) emergency_buffer += rsize; return old; } else { - dTHR; + dTHX; /* First offense, give a possibility to recover by dieing. */ /* No malloc involved here: */ GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0); SV *sv; char *pv; int have = 0; + STRLEN n_a; if (emergency_buffer_size) { add_to_chain(emergency_buffer, emergency_buffer_size, 0); @@ -741,9 +776,9 @@ emergency_sbrk(MEM_SIZE size) return (char *)-1; /* Now die die die... */ } /* Got it, now detach SvPV: */ - pv = SvPV(sv, PL_na); + pv = SvPV(sv, n_a); /* Check alignment: */ - if (((UV)(pv - sizeof(union overhead))) & ((1<> CHUNK_SHIFT)) { /* Not aligned. */ - slack = (0x800 >> CHUNK_SHIFT) - - ((UV)cp & (0x7FF >> CHUNK_SHIFT)); + /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may + improve performance of memory access. */ + if ((UV)cp & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */ + slack = WANTED_ALIGNMENT - ((UV)cp & (WANTED_ALIGNMENT - 1)); add += slack; } # endif -#endif /* atarist */ +#endif /* !atarist && !MINT */ if (add) { DEBUG_m(PerlIO_printf(Perl_debug_log, @@ -1105,7 +1139,7 @@ getpages(int needed, int *nblksp, int bucket) #ifdef PACK_MALLOC if (slack) { MALLOC_UNLOCK; - croak("%s", "panic: Off-page sbrk"); + fatalcroak("panic: Off-page sbrk\n"); } #endif if (sbrked_remains) { @@ -1142,19 +1176,26 @@ getpages(int needed, int *nblksp, int bucket) * and deduct from block count to reflect. */ +# if NEEDED_ALIGNMENT > MEM_ALIGNBYTES + if ((UV)ovp & (NEEDED_ALIGNMENT - 1)) + fatalcroak("Misalignment of sbrk()\n"); + else +# endif #ifndef I286 /* Again, this should always be ok on an 80286 */ - if ((UV)ovp & 7) { - ovp = (union overhead *)(((UV)ovp + 8) & ~7); + if ((UV)ovp & (MEM_ALIGNBYTES - 1)) { DEBUG_m(PerlIO_printf(Perl_debug_log, "fixing sbrk(): %d bytes off machine alignement\n", - (int)((UV)ovp & 7))); + (int)((UV)ovp & (MEM_ALIGNBYTES - 1)))); + ovp = (union overhead *)(((UV)ovp + MEM_ALIGNBYTES) & + (MEM_ALIGNBYTES - 1)); (*nblksp)--; # if defined(DEBUGGING_MSTATS) /* This is only approx. if TWO_POT_OPTIMIZE: */ - sbrk_slack += (1 << bucket); + sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT)); # endif } #endif + ; /* Finish `else' */ sbrked_remains = require - needed; last_op = cp; } @@ -1307,8 +1348,8 @@ morecore(register int bucket) } Free_t -free(void *mp) -{ +Perl_mfree(void *mp) +{ register MEM_SIZE size; register union overhead *ovp; char *cp = (char*)mp; @@ -1389,8 +1430,8 @@ free(void *mp) #define reall_srchlen 4 /* 4 should be plenty, -1 =>'s whole list */ Malloc_t -realloc(void *mp, size_t nbytes) -{ +Perl_realloc(void *mp, size_t nbytes) +{ register MEM_SIZE onb; union overhead *ovp; char *res; @@ -1403,12 +1444,12 @@ realloc(void *mp, size_t nbytes) MEM_SIZE size = nbytes; if ((long)nbytes < 0) - croak("%s", "panic: realloc"); + croak("%s", "panic: realloc"); #endif BARK_64K_LIMIT("Reallocation",nbytes,size); if (!cp) - return malloc(nbytes); + return Perl_malloc(nbytes); MALLOC_LOCK; ovp = (union overhead *)((caddr_t)cp @@ -1545,12 +1586,12 @@ realloc(void *mp, size_t nbytes) "0x%lx: (%05lu) realloc %ld bytes the hard way\n", (unsigned long)cp,(unsigned long)(PL_an++), (long)size)); - if ((res = (char*)malloc(nbytes)) == NULL) + if ((res = (char*)Perl_malloc(nbytes)) == NULL) return (NULL); if (cp != res) /* common optimization */ Copy(cp, res, (MEM_SIZE)(nbytes */ -# define SYSTEM_ALLOC(a) ((void *)(((unsigned)malloc((a)+6)+6)&~7)) +# define SYSTEM_ALLOC_ALIGNMENT 2 # endif # ifdef PERL_SBRK_VIA_MALLOC -# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC) -# undef malloc /* Expose names that */ -# undef calloc /* HIDEMYMALLOC hides */ -# undef realloc -# undef free -# else -# include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC" -# endif /* it may seem schizophrenic to use perl's malloc and let it call system */ /* malloc, the reason for that is only the 3.2 version of the OS that had */ @@ -1737,6 +1763,9 @@ dump_mstats(char *s) # ifndef SYSTEM_ALLOC # define SYSTEM_ALLOC(a) malloc(a) # endif +# ifndef SYSTEM_ALLOC_ALIGNMENT +# define SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES +# endif # endif /* PERL_SBRK_VIA_MALLOC */ @@ -1770,10 +1799,13 @@ Perl_sbrk(int size) size = PERLSBRK_64_K; small = 1; } +# if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT + size += NEEDED_ALIGNMENT - SYSTEM_ALLOC_ALIGNMENT; +# endif got = (IV)SYSTEM_ALLOC(size); -#ifdef PACK_MALLOC - got = (got + 0x7ff) & ~0x7ff; -#endif +# if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT + got = (got + NEEDED_ALIGNMENT - 1) & ~(NEEDED_ALIGNMENT - 1); +# endif if (small) { /* Chunk is small, register the rest for future allocs. */ Perl_sbrk_oldchunk = got + reqsize;