diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | dosish.h | 8 | ||||
| -rw-r--r-- | epoc/epocish.h | 2 | ||||
| -rw-r--r-- | malloc.c | 506 | ||||
| -rw-r--r-- | malloc_ctl.h | 54 | ||||
| -rw-r--r-- | os2/os2ish.h | 1 | ||||
| -rw-r--r-- | perl.c | 35 | ||||
| -rw-r--r-- | perl.h | 57 | ||||
| -rw-r--r-- | plan9/plan9ish.h | 2 | ||||
| -rw-r--r-- | sv.c | 4 | ||||
| -rw-r--r-- | unixish.h | 2 | ||||
| -rw-r--r-- | vms/vmsish.h | 2 |
12 files changed, 586 insertions, 88 deletions
@@ -2085,6 +2085,7 @@ makedir.SH Precursor to makedir Makefile.micro microperl Makefile Makefile.SH A script that generates Makefile malloc.c A version of malloc you might not want +malloc_ctl.h A version of malloc you might not want MANIFEST This list of files mg.c Magic code mg.h Magic header @@ -16,7 +16,7 @@ #ifdef DJGPP # define BIT_BUCKET "nul" # define OP_BINARY O_BINARY -# define PERL_SYS_INIT(c,v) Perl_DJGPP_init(c,v) +# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v) # define init_os_extras Perl_init_os_extras # include <signal.h> # define HAS_UTIME @@ -29,15 +29,15 @@ # define PERL_FS_VER_FMT "%d_%d_%d" #else /* DJGPP */ # ifdef WIN32 -# define PERL_SYS_INIT(c,v) Perl_win32_init(c,v) +# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v) # define PERL_SYS_TERM() Perl_win32_term() # define BIT_BUCKET "nul" # else # ifdef NETWARE -# define PERL_SYS_INIT(c,v) Perl_nw5_init(c,v) +# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_nw5_init(c,v) # define BIT_BUCKET "nwnul" # else -# define PERL_SYS_INIT(c,v) +# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ # endif /* NETWARE */ # endif diff --git a/epoc/epocish.h b/epoc/epocish.h index a7ef41871c..a971a8e6c7 100644 --- a/epoc/epocish.h +++ b/epoc/epocish.h @@ -108,7 +108,7 @@ /* epocemx setenv bug workaround */ #ifndef PERL_SYS_INIT -# define PERL_SYS_INIT(c,v) putenv(".dummy=foo"); putenv(".dummy"); MALLOC_INIT +# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) putenv(".dummy=foo"); putenv(".dummy"); MALLOC_INIT #endif #ifndef PERL_SYS_TERM @@ -27,9 +27,12 @@ options take a precise value, while the others are just boolean. The boolean ones are listed first. + # Read configuration settings from malloc_cfg.h + HAVE_MALLOC_CFG_H undef + # Enable code for an emergency memory pool in $^M. See perlvar.pod # for a description of $^M. - PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && PERL_CORE) + PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && (PERL_CORE || !NO_MALLOC_DYNAMIC_CFG)) # Enable code for printing memory statistics. DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE) @@ -78,6 +81,22 @@ # pessimization, error reporting optimization RCHECK (DEBUGGING && !NO_RCHECK) + # Do not overwrite uninit areas with DEBUGGING. Speed + # optimization, error reporting pessimization + NO_MFILL undef + + # Overwrite uninit areas with DEBUGGING. Speed + # pessimization, error reporting optimization + MALLOC_FILL (DEBUGGING && !NO_RCHECK && !NO_MFILL) + + # Do not check overwritten uninit areas with DEBUGGING. Speed + # optimization, error reporting pessimization + NO_FILL_CHECK undef + + # Check overwritten uninit areas with DEBUGGING. Speed + # pessimization, error reporting optimization + MALLOC_FILL_CHECK (DEBUGGING && !NO_RCHECK && !NO_FILL_CHECK) + # Failed allocations bigger than this size croak (if # PERL_EMERGENCY_SBRK is enabled) without touching $^M. See # perlvar.pod for a description of $^M. @@ -98,6 +117,9 @@ # Round up sbrk()s to multiples of this percent of footprint. MIN_SBRK_FRAC 3 + # Round up sbrk()s to multiples of this multiple of 1/1000 of footprint. + MIN_SBRK_FRAC1000 (10 * MIN_SBRK_FRAC) + # Add this much memory to big powers of two to get the bucket size. PERL_PAGESIZE 4096 @@ -114,6 +136,20 @@ # define this to disable 12-byte bucket (will increase memory footprint) STRICT_ALIGNMENT undef + # Do not allow configuration of runtime options at runtime + NO_MALLOC_DYNAMIC_CFG undef + + # Do not allow configuration of runtime options via $ENV{PERL_MALLOC_OPT} + NO_PERL_MALLOC_ENV undef + + [The variable consists of ;-separated parts of the form CODE=VALUE + with 1-character codes F, M, f, A, P, G, d, a, c for runtime + configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000, + SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness, + filldead, fillalive, fillcheck. The last 3 are for DEBUGGING + build, and allow switching the tests for free()ed memory read, + uninit memory reads, and free()ed memory write.] + This implementation assumes that calling PerlIO_printf() does not result in any memory allocation calls (used during a panic). @@ -138,12 +174,30 @@ # Unsigned integer type big enough to keep a pointer UV unsigned long + # Signed integer of the same sizeof() as UV + IV long + # Type of pointer with 1-byte granularity caddr_t char * # Type returned by free() Free_t void + # Conversion of pointer to integer + PTR2UV(ptr) ((UV)(ptr)) + + # Conversion of integer to pointer + INT2PTR(type, i) ((type)(i)) + + # printf()-%-Conversion of UV to pointer + UVuf "lu" + + # printf()-%-Conversion of UV to hex pointer + UVxf "lx" + + # Alignment to use + MEM_ALIGNBYTES 4 + # Very fatal condition reporting function (cannot call any ) fatalcroak(arg) write(2,arg,strlen(arg)) + exit(2) @@ -168,6 +222,10 @@ MUTEX_UNLOCK(l) void */ +#ifdef HAVE_MALLOC_CFG_H +# include "malloc_cfg.h" +#endif + #ifndef NO_FANCY_MALLOC # ifndef SMALL_BUCKET_VIA_TABLE # define SMALL_BUCKET_VIA_TABLE @@ -187,7 +245,7 @@ # ifndef TWO_POT_OPTIMIZE # define TWO_POT_OPTIMIZE # endif -# if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK) +# if (defined(PERL_CORE) || !defined(NO_MALLOC_DYNAMIC_CFG)) && !defined(PERL_EMERGENCY_SBRK) # define PERL_EMERGENCY_SBRK # endif # if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS) @@ -211,6 +269,12 @@ # if defined(DEBUGGING) && !defined(NO_RCHECK) # define RCHECK # endif +# if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_MFILL) && !defined(MALLOC_FILL) +# define MALLOC_FILL +# endif +# if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_FILL_CHECK) && !defined(MALLOC_FILL_CHECK) +# define MALLOC_FILL_CHECK +# endif # if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE) # undef IGNORE_SMALL_BAD_FREE # endif @@ -251,6 +315,11 @@ # define croak2 croak # define warn2 warn # endif +# if defined(USE_5005THREADS) || defined(USE_ITHREADS) +# define PERL_MAYBE_ALIVE PL_thr_key +# else +# define PERL_MAYBE_ALIVE 1 +# endif #else # ifdef PERL_FOR_X2P # include "../EXTERN.h" @@ -259,6 +328,10 @@ # include <stdlib.h> # include <stdio.h> # include <memory.h> +# ifdef OS2 +# include <io.h> +# endif +# include <string.h> # ifndef Malloc_t # define Malloc_t void * # endif @@ -274,6 +347,9 @@ # ifndef UV # define UV unsigned long # endif +# ifndef IV +# define IV long +# endif # ifndef caddr_t # define caddr_t char * # endif @@ -284,6 +360,25 @@ # define PerlEnv_getenv getenv # define PerlIO_printf fprintf # define PerlIO_stderr() stderr +# define PerlIO_puts(f,s) fputs(s,f) +# ifndef INT2PTR +# define INT2PTR(t,i) ((t)(i)) +# endif +# ifndef PTR2UV +# define PTR2UV(p) ((UV)(p)) +# endif +# ifndef UVuf +# define UVuf "lu" +# endif +# ifndef UVxf +# define UVxf "lx" +# endif +# ifndef Nullch +# define Nullch NULL +# endif +# ifndef MEM_ALIGNBYTES +# define MEM_ALIGNBYTES 4 +# endif # endif # ifndef croak /* make depend */ # define croak(mess, arg) (warn((mess), (arg)), exit(1)) @@ -295,7 +390,7 @@ # define warn(mess, arg) fprintf(stderr, (mess), (arg)) # endif # ifndef warn2 -# define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2)) +# define warn2(mess, arg1, arg2) fprintf(stderr, (mess), (arg1), (arg2)) # endif # ifdef DEBUG_m # undef DEBUG_m @@ -317,6 +412,7 @@ # ifndef PERL_GET_INTERP # define PERL_GET_INTERP PL_curinterp # endif +# define PERL_MAYBE_ALIVE 1 # ifndef Perl_malloc # define Perl_malloc malloc # endif @@ -332,7 +428,7 @@ # ifndef Perl_strdup # define Perl_strdup strdup # endif -#endif +#endif /* defined PERL_CORE */ #ifndef MUTEX_LOCK # define MUTEX_LOCK(l) @@ -358,7 +454,7 @@ # undef DEBUG_m # define DEBUG_m(a) \ STMT_START { \ - if (PERL_GET_INTERP) { \ + if (PERL_MAYBE_ALIVE && PERL_GET_THX) { \ dTHX; \ if (DEBUG_m_TEST) { \ PL_debug &= ~DEBUG_m_FLAG; \ @@ -480,7 +576,7 @@ union overhead { u_char ovu_index; /* bucket # */ u_char ovu_magic; /* magic number */ #ifdef RCHECK - u_short ovu_size; /* actual block size */ + u_short ovu_size; /* block size (requested + overhead - 1) */ u_int ovu_rmagic; /* range magic number */ #endif } ovu; @@ -497,7 +593,7 @@ union overhead { #ifdef RCHECK # define RSLOP sizeof (u_int) # ifdef TWO_POT_OPTIMIZE -# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) +# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) /* size-1 fits in short */ # else # define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2) # endif @@ -883,6 +979,12 @@ static int getpages_adjacent(MEM_SIZE require); # define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END #endif +#endif /* defined PERL_CORE */ + +#ifndef PTRSIZE +# define PTRSIZE sizeof(void*) +#endif + #ifndef BITS_IN_PTR # define BITS_IN_PTR (8*PTRSIZE) #endif @@ -908,6 +1010,82 @@ extern Malloc_t sbrk(int); # endif #endif +#ifndef MIN_SBRK_FRAC1000 /* Backward compatibility */ +# define MIN_SBRK_FRAC1000 (MIN_SBRK_FRAC * 10) +#endif + +#ifndef START_EXTERN_C +# ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# else +# define START_EXTERN_C +# endif +#endif + +#ifndef END_EXTERN_C +# ifdef __cplusplus +# define END_EXTERN_C }; +# else +# define END_EXTERN_C +# endif +#endif + +#include "malloc_ctl.h" + +#ifndef NO_MALLOC_DYNAMIC_CFG +# define PERL_MALLOC_OPT_CHARS "FMfAPGdac" + +static IV MallocCfg[MallocCfg_last] = { + FIRST_SBRK, + MIN_SBRK, + MIN_SBRK_FRAC, + SBRK_ALLOW_FAILURES, + SBRK_FAILURE_PRICE, + SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE, /* sbrk_goodness */ + 1, /* FILL_DEAD */ + 1, /* FILL_ALIVE */ + 1, /* FILL_CHECK */ + 0, /* MallocCfg_skip_cfg_env */ + 0, /* MallocCfg_cfg_env_read */ + 0, /* MallocCfg_emergency_buffer_size */ + 0, /* MallocCfg_emergency_buffer_prepared_size */ + 0 /* MallocCfg_emergency_buffer_last_req */ +}; +IV *MallocCfg_ptr = MallocCfg; + +# undef MIN_SBRK +# undef FIRST_SBRK +# undef MIN_SBRK_FRAC1000 +# undef SBRK_ALLOW_FAILURES +# undef SBRK_FAILURE_PRICE + +# define MIN_SBRK MallocCfg[MallocCfg_MIN_SBRK] +# define FIRST_SBRK MallocCfg[MallocCfg_FIRST_SBRK] +# define MIN_SBRK_FRAC1000 MallocCfg[MallocCfg_MIN_SBRK_FRAC1000] +# define SBRK_ALLOW_FAILURES MallocCfg[MallocCfg_SBRK_ALLOW_FAILURES] +# define SBRK_FAILURE_PRICE MallocCfg[MallocCfg_SBRK_FAILURE_PRICE] + +# define sbrk_goodness MallocCfg[MallocCfg_sbrk_goodness] + +# define emergency_buffer_size MallocCfg[MallocCfg_emergency_buffer_size] +# define emergency_buffer_last_req MallocCfg[MallocCfg_emergency_buffer_last_req] + +# define FILL_DEAD MallocCfg[MallocCfg_filldead] +# define FILL_ALIVE MallocCfg[MallocCfg_fillalive] +# define FILL_CHECK_CFG MallocCfg[MallocCfg_fillcheck] +# define FILL_CHECK (FILL_DEAD && FILL_CHECK_CFG) + +#else /* defined(NO_MALLOC_DYNAMIC_CFG) */ + +# define FILL_DEAD 1 +# define FILL_ALIVE 1 +# define FILL_CHECK 1 +static int sbrk_goodness = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE; + +# define NO_PERL_MALLOC_ENV + +#endif + #ifdef DEBUGGING_MSTATS /* * nmalloc[i] is the difference between the number of mallocs and frees @@ -922,27 +1100,107 @@ static u_int start_slack; static u_int goodsbrk; -# ifdef PERL_EMERGENCY_SBRK +#ifdef PERL_EMERGENCY_SBRK # ifndef BIG_SIZE # define BIG_SIZE (1<<16) /* 64K */ # endif static char *emergency_buffer; +static char *emergency_buffer_prepared; + +# ifdef NO_MALLOC_DYNAMIC_CFG static MEM_SIZE emergency_buffer_size; -static MEM_SIZE no_mem; /* 0 if the last request for more memory succeeded. - Otherwise the size of the failing request. */ + /* 0 if the last request for more memory succeeded. + Otherwise the size of the failing request. */ +static MEM_SIZE emergency_buffer_last_req; +# endif + +# ifndef emergency_sbrk_croak +# define emergency_sbrk_croak croak2 +# endif + +# ifdef PERL_CORE +static char * +perl_get_emergency_buffer(IV *size) +{ + 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; + STRLEN n_a; + + if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0); + if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) + || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) + return NULL; /* Now die die die... */ + /* Got it, now detach SvPV: */ + pv = SvPV(sv, n_a); + /* Check alignment: */ + if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) { + PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); + return NULL; /* die die die */ + } + + SvPOK_off(sv); + SvPVX(sv) = Nullch; + SvCUR(sv) = SvLEN(sv) = 0; + *size = malloced_size(pv) + M_OVERHEAD; + return pv - sizeof(union overhead); +} +# define PERL_GET_EMERGENCY_BUFFER(p) perl_get_emergency_buffer(p) +# else +# define PERL_GET_EMERGENCY_BUFFER(p) NULL +# endif /* defined PERL_CORE */ + +# ifndef NO_MALLOC_DYNAMIC_CFG +static char * +get_emergency_buffer(IV *size) +{ + char *pv = emergency_buffer_prepared; + + *size = MallocCfg[MallocCfg_emergency_buffer_prepared_size]; + emergency_buffer_prepared = 0; + MallocCfg[MallocCfg_emergency_buffer_prepared_size] = 0; + return pv; +} + +/* Returns 0 on success, -1 on bad alignment, -2 if not implemented */ +int +set_emergency_buffer(char *b, IV size) +{ + if (PTR2UV(b) & (NEEDED_ALIGNMENT - 1)) + return -1; + if (MallocCfg[MallocCfg_emergency_buffer_prepared_size]) + add_to_chain((void*)emergency_buffer_prepared, + MallocCfg[MallocCfg_emergency_buffer_prepared_size], 0); + emergency_buffer_prepared = b; + MallocCfg[MallocCfg_emergency_buffer_prepared_size] = size; + return 0; +} +# define GET_EMERGENCY_BUFFER(p) get_emergency_buffer(p) +# else /* NO_MALLOC_DYNAMIC_CFG */ +# define GET_EMERGENCY_BUFFER(p) NULL +int +set_emergency_buffer(char *b, IV size) +{ + return -1; +} +# endif static Malloc_t emergency_sbrk(MEM_SIZE size) { MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA; - if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) { + if (size >= BIG_SIZE + && (!emergency_buffer_last_req || (size < emergency_buffer_last_req))) { /* Give the possibility to recover, but avoid an infinite cycle. */ MALLOC_UNLOCK; - no_mem = size; - croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); + emergency_buffer_last_req = size; + emergency_sbrk_croak("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); } if (emergency_buffer_size >= rsize) { @@ -952,14 +1210,11 @@ emergency_sbrk(MEM_SIZE size) emergency_buffer += rsize; return old; } else { - 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; + IV Size; + char *pv = GET_EMERGENCY_BUFFER(&Size); int have = 0; - STRLEN n_a; if (emergency_buffer_size) { add_to_chain(emergency_buffer, emergency_buffer_size, 0); @@ -967,38 +1222,42 @@ emergency_sbrk(MEM_SIZE size) emergency_buffer = Nullch; have = 1; } - if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0); - if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) - || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) { + + if (!pv) + pv = PERL_GET_EMERGENCY_BUFFER(&Size); + if (!pv) { if (have) goto do_croak; return (char *)-1; /* Now die die die... */ } - /* Got it, now detach SvPV: */ - pv = SvPV(sv, n_a); + /* Check alignment: */ - if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) { + if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) { + dTHX; + PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); return (char *)-1; /* die die die */ } - emergency_buffer = pv - sizeof(union overhead); - emergency_buffer_size = malloced_size(pv) + M_OVERHEAD; - SvPOK_off(sv); - SvPVX(sv) = Nullch; - SvCUR(sv) = SvLEN(sv) = 0; + emergency_buffer = pv; + emergency_buffer_size = Size; } do_croak: MALLOC_UNLOCK; - croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); + emergency_sbrk_croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); /* NOTREACHED */ return Nullch; } -# else /* !defined(PERL_EMERGENCY_SBRK) */ +#else /* !defined(PERL_EMERGENCY_SBRK) */ # define emergency_sbrk(size) -1 -# endif -#endif /* ifdef PERL_CORE */ +#endif /* defined PERL_EMERGENCY_SBRK */ + +static void +write2(char *mess) +{ + write(2, mess, strlen(mess)); +} #ifdef DEBUGGING #undef ASSERT @@ -1006,14 +1265,103 @@ emergency_sbrk(MEM_SIZE size) static void botch(char *diag, char *s) { + if (!(PERL_MAYBE_ALIVE && PERL_GET_THX)) + goto do_write; + else { dTHX; - PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s); + + if (PerlIO_printf(PerlIO_stderr(), + "assertion botched (%s?): %s\n", diag, s) != 0) { + do_write: /* Can be initializing interpreter */ + write2("assertion botched ("); + write2(diag); + write2("?): "); + write2(s); + write2("\n"); + } PerlProc_abort(); + } } #else #define ASSERT(p, diag) #endif +#ifdef MALLOC_FILL +/* Fill should be long enough to cover long */ +static void +fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) +{ + unsigned char *e = s + nbytes; + long *lp; + long lfill = *(long*)fill; + + if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ + int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); + unsigned const char *f = fill + sizeof(long) - shift; + unsigned char *e1 = s + shift; + + while (s < e1) + *s++ = *f++; + } + lp = (long*)s; + while ((unsigned char*)(lp + 1) <= e) + *lp++ = lfill; + s = (unsigned char*)lp; + while (s < e) + *s++ = *fill++; +} +/* Just malloc()ed */ +static const unsigned char fill_feedadad[] = + {0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD, + 0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD}; +/* Just free()ed */ +static const unsigned char fill_deadbeef[] = + {0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF, + 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF}; +# define FILL_DEADBEEF(s, n) \ + (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0) +# define FILL_FEEDADAD(s, n) \ + (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0) +#else +# define FILL_DEADBEEF(s, n) ((void)0) +# define FILL_FEEDADAD(s, n) ((void)0) +# undef MALLOC_FILL_CHECK +#endif + +#ifdef MALLOC_FILL_CHECK +static int +cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) +{ + unsigned char *e = s + nbytes; + long *lp; + long lfill = *(long*)fill; + + if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ + int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); + unsigned const char *f = fill + sizeof(long) - shift; + unsigned char *e1 = s + shift; + + while (s < e1) + if (*s++ != *f++) + return 1; + } + lp = (long*)s; + while ((unsigned char*)(lp + 1) <= e) + if (*lp++ != lfill) + return 1; + s = (unsigned char*)lp; + while (s < e) + if (*s++ != *fill++) + return 1; + return 0; +} +# define FILLCHECK_DEADBEEF(s, n) \ + ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \ + "free()ed/realloc()ed-away memory was overwritten") +#else +# define FILLCHECK_DEADBEEF(s, n) ((void)0) +#endif + Malloc_t Perl_malloc(register size_t nbytes) { @@ -1111,14 +1459,17 @@ Perl_malloc(register size_t nbytes) } /* remove from linked list */ -#if defined(RCHECK) - if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1)) { +#ifdef DEBUGGING + if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1)) + /* Can't get this low */ + || (p && PTR2UV(p) < (1<<LOG_OF_MIN_ARENA)) ) { dTHX; PerlIO_printf(PerlIO_stderr(), "Unaligned pointer in the free chain 0x%"UVxf"\n", PTR2UV(p)); } - if ((PTR2UV(p->ov_next)) & (MEM_ALIGNBYTES - 1)) { + if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1)) + || (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) { dTHX; PerlIO_printf(PerlIO_stderr(), "Unaligned `next' pointer in the free " @@ -1135,6 +1486,9 @@ Perl_malloc(register size_t nbytes) PTR2UV((Malloc_t)(p + CHUNK_SHIFT)), (unsigned long)(PL_an++), (long)size)); + FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), + BUCKET_SIZE_REAL(bucket)); + #ifdef IGNORE_SMALL_BAD_FREE if (bucket >= FIRST_BUCKET_WITH_CHECK) #endif @@ -1161,6 +1515,7 @@ Perl_malloc(register size_t nbytes) nbytes = (nbytes + 3) &~ 3; *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; } + FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size); #endif return ((Malloc_t)(p + CHUNK_SHIFT)); } @@ -1168,7 +1523,6 @@ Perl_malloc(register size_t nbytes) static char *last_sbrk_top; static char *last_op; /* This arena can be easily extended. */ static MEM_SIZE sbrked_remains; -static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE; #ifdef DEBUGGING_MSTATS static int sbrks; @@ -1274,13 +1628,13 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) union overhead *ovp; MEM_SIZE slack = 0; - if (sbrk_good > 0) { + if (sbrk_goodness > 0) { if (!last_sbrk_top && require < FIRST_SBRK) require = FIRST_SBRK; else if (require < MIN_SBRK) require = MIN_SBRK; - if (require < goodsbrk * MIN_SBRK_FRAC / 100) - require = goodsbrk * MIN_SBRK_FRAC / 100; + if (require < goodsbrk * MIN_SBRK_FRAC1000 / 1000) + require = goodsbrk * MIN_SBRK_FRAC1000 / 1000; require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; } else { require = needed; @@ -1297,7 +1651,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) #endif if (cp == last_sbrk_top) { /* Common case, anything is fine. */ - sbrk_good++; + sbrk_goodness++; ovp = (union overhead *) (cp - sbrked_remains); last_op = cp - sbrked_remains; sbrked_remains = require - (needed - sbrked_remains); @@ -1369,7 +1723,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) if (cp == (char *)-1) return 0; } - sbrk_good = -1; /* Disable optimization! + sbrk_goodness = -1; /* Disable optimization! Continue with not-aligned... */ } else { cp += slack; @@ -1378,7 +1732,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) } if (last_sbrk_top) { - sbrk_good -= SBRK_FAILURE_PRICE; + sbrk_goodness -= SBRK_FAILURE_PRICE; } ovp = (union overhead *) cp; @@ -1411,7 +1765,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) last_op = cp; } #if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC) - no_mem = 0; + emergency_buffer_last_req = 0; #endif last_sbrk_top = cp + require; #ifdef DEBUGGING_MSTATS @@ -1450,7 +1804,7 @@ getpages_adjacent(MEM_SIZE require) add_to_chain((void*)(last_sbrk_top - sbrked_remains), sbrked_remains, 0); add_to_chain((void*)cp, require, 0); - sbrk_good -= SBRK_FAILURE_PRICE; + sbrk_goodness -= SBRK_FAILURE_PRICE; sbrked_remains = 0; last_sbrk_top = 0; last_op = 0; @@ -1471,9 +1825,44 @@ morecore(register int bucket) register int rnu; /* 2^rnu bytes will be requested */ int nblks; /* become nblks blocks of the desired size */ register MEM_SIZE siz, needed; + static int were_called = 0; if (nextf[bucket]) return; +#ifndef NO_PERL_MALLOC_ENV + if (!were_called) { + /* It's the our first time. Initialize ourselves */ + were_called = 1; /* Avoid a loop */ + if (!MallocCfg[MallocCfg_skip_cfg_env]) { + char *s = getenv("PERL_MALLOC_OPT"), *t = s, *off; + const char *opts = PERL_MALLOC_OPT_CHARS; + int changed = 0; + + while ( t && t[0] && t[1] == '=' + && ((off = strchr(opts, *t))) ) { + IV val = 0; + + t += 2; + while (*t <= '9' && *t >= '0') + val = 10*val + *t++ - '0'; + if (!*t || *t == ';') { + if (MallocCfg[off - opts] != val) + changed = 1; + MallocCfg[off - opts] = val; + if (*t) + t++; + } + } + if (t && *t) { + write2("Unrecognized part of PERL_MALLOC_OPT: `"); + write2(t); + write2("'\n"); + } + if (changed) + MallocCfg[MallocCfg_cfg_env_read] = 1; + } + } +#endif if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) { MALLOC_UNLOCK; croak("%s", "Out of memory during ridiculously large request"); @@ -1518,6 +1907,7 @@ morecore(register int bucket) if (!ovp) return; + FILL_DEADBEEF((unsigned char*)ovp, needed); /* * Add new memory allocated to that on @@ -1544,6 +1934,7 @@ morecore(register int bucket) start_slack += M_OVERHEAD * nblks; } #endif + while (--nblks > 0) { ovp->ov_next = (union overhead *)((caddr_t)ovp + siz); ovp = (union overhead *)((caddr_t)ovp + siz); @@ -1577,6 +1968,10 @@ Perl_mfree(void *mp) if (cp == NULL) return; +#ifdef DEBUGGING + if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1)) + croak("%s", "wrong alignment in free()"); +#endif ovp = (union overhead *)((caddr_t)cp - sizeof (union overhead) * CHUNK_SHIFT); #ifdef PACK_MALLOC @@ -1638,7 +2033,10 @@ Perl_mfree(void *mp) } nbytes = (nbytes + 3) &~ 3; ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes - RSLOP + sizeof(u_int)), + BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nbytes - RSLOP + sizeof(u_int))); } + FILL_DEADBEEF((unsigned char*)(ovp+1), BUCKET_SIZE_REAL(OV_INDEX(ovp))); ovp->ov_rmagic = RMAGIC - 1; #endif ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite"); @@ -1708,9 +2106,9 @@ Perl_realloc(void *mp, size_t nbytes) ? "of freed memory " : ""); } #else - warn("%srealloc() %signored", - (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), - ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : ""); + warn2("%srealloc() %signored", + (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), + ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : ""); #endif #else #ifdef PERL_CORE @@ -1776,6 +2174,14 @@ Perl_realloc(void *mp, size_t nbytes) } nb = (nb + 3) &~ 3; ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb - RSLOP + sizeof(u_int)), + BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nb - RSLOP + sizeof(u_int))); + if (nbytes > ovp->ov_size + 1 - M_OVERHEAD) + FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD, + nbytes - (ovp->ov_size + 1 - M_OVERHEAD)); + else + FILL_DEADBEEF((unsigned char*)cp + nbytes, + nb - M_OVERHEAD + RSLOP - nbytes); /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -1954,7 +2360,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) } buf->total_sbrk = goodsbrk + sbrk_slack; buf->sbrks = sbrks; - buf->sbrk_good = sbrk_good; + buf->sbrk_good = sbrk_goodness; buf->sbrk_slack = sbrk_slack; buf->start_slack = start_slack; buf->sbrked_remains = sbrked_remains; diff --git a/malloc_ctl.h b/malloc_ctl.h new file mode 100644 index 0000000000..e0bee00ea3 --- /dev/null +++ b/malloc_ctl.h @@ -0,0 +1,54 @@ +#ifndef MALLOC_CTL_H +# define MALLOC_CTL_H + +struct perl_mstats { + UV *nfree; + UV *ntotal; + IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain; + IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains; + IV minbucket; + /* Level 1 info */ + UV *bucket_mem_size; + UV *bucket_available_size; + UV nbuckets; +}; +typedef struct perl_mstats perl_mstats_t; + +START_EXTERN_C +Malloc_t Perl_malloc (MEM_SIZE nbytes); +Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size); +Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes); +/* 'mfree' rather than 'free', since there is already a 'perl_free' + * that causes clashes with case-insensitive linkers */ +Free_t Perl_mfree (Malloc_t where); +END_EXTERN_C + +#ifndef NO_MALLOC_DYNAMIC_CFG + +enum { + MallocCfg_FIRST_SBRK, + MallocCfg_MIN_SBRK, + MallocCfg_MIN_SBRK_FRAC1000, + MallocCfg_SBRK_ALLOW_FAILURES, + MallocCfg_SBRK_FAILURE_PRICE, + MallocCfg_sbrk_goodness, + + MallocCfg_filldead, + MallocCfg_fillalive, + MallocCfg_fillcheck, + + MallocCfg_skip_cfg_env, + MallocCfg_cfg_env_read, + + MallocCfg_emergency_buffer_size, + MallocCfg_emergency_buffer_last_req, + + MallocCfg_emergency_buffer_prepared_size, + + MallocCfg_last +}; +extern IV *MallocCfg_ptr; + +#endif + +#endif diff --git a/os2/os2ish.h b/os2/os2ish.h index b612683602..225d271236 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -218,6 +218,7 @@ void Perl_OS2_term(void **excH, int exitstatus, int flags); # define PERL_SYS_INIT3(argcp, argvp, envp) \ { void *xreg[2]; \ + MALLOC_CHECK_TAINT(*argcp, *argvp, *envp) \ _response(argcp, argvp); \ _wildcard(argcp, argvp); \ Perl_OS2_init3(*envp, xreg, 0) @@ -1033,6 +1033,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) break; case 't': + CHECK_MALLOC_TOO_LATE_FOR('t'); if( !PL_tainting ) { PL_taint_warn = TRUE; PL_tainting = TRUE; @@ -1040,6 +1041,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; case 'T': + CHECK_MALLOC_TOO_LATE_FOR('T'); PL_tainting = TRUE; PL_taint_warn = FALSE; s++; @@ -1222,6 +1224,7 @@ print \" \\@INC:\\n @INC\\n\";"); while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') { + CHECK_MALLOC_TOO_LATE_FOR('T'); PL_tainting = TRUE; PL_taint_warn = FALSE; } @@ -2424,12 +2427,12 @@ Perl_moreswitches(pTHX_ char *s) return s; case 't': if (!PL_tainting) - Perl_croak(aTHX_ "Too late for \"-t\" option"); + TOO_LATE_FOR('t'); s++; return s; case 'T': if (!PL_tainting) - Perl_croak(aTHX_ "Too late for \"-T\" option"); + TOO_LATE_FOR('T'); s++; return s; case 'u': @@ -3286,9 +3289,37 @@ S_init_ids(pTHX) PL_uid |= PL_gid << 16; PL_euid |= PL_egid << 16; #endif + /* Should not happen: */ + CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); } +#ifdef MYMALLOC +/* This is used very early in the lifetime of the program. */ +int +Perl_doing_taint(int argc, char *argv[], char *envp[]) +{ + int uid = PerlProc_getuid(); + int euid = PerlProc_geteuid(); + int gid = PerlProc_getgid(); + int egid = PerlProc_getegid(); + +#ifdef VMS + uid |= gid << 16; + euid |= egid << 16; +#endif + if (uid && (euid != uid || egid != gid)) + return 1; + /* This is a really primitive check; $ENV{PERL_MALLOC_OPT} is + ignored only if -T are the first chars together; otherwise one + gets "Too late" message. */ + if ( argc > 1 && argv[1][0] == '-' + && (argv[1][1] == 't' || argv[1][1] == 'T') ) + return 1; + return 0; +} +#endif + STATIC void S_forbid_setid(pTHX_ char *s) { @@ -481,28 +481,43 @@ int usleep(unsigned int); # else # define EMBEDMYMALLOC /* for compatibility */ # endif -START_EXTERN_C -Malloc_t Perl_malloc (MEM_SIZE nbytes); -Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size); -Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes); -/* 'mfree' rather than 'free', since there is already a 'perl_free' - * that causes clashes with case-insensitive linkers */ -Free_t Perl_mfree (Malloc_t where); -END_EXTERN_C - -typedef struct perl_mstats perl_mstats_t; # define safemalloc Perl_malloc # define safecalloc Perl_calloc # define saferealloc Perl_realloc # define safefree Perl_mfree +# define CHECK_MALLOC_TOO_LATE_FOR_(code) STMT_START { \ + if (!PL_tainting && MallocCfg_ptr[MallocCfg_cfg_env_read]) \ + code; \ + } STMT_END +# define CHECK_MALLOC_TOO_LATE_FOR(ch) \ + CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch)) +# define panic_write2(s) write(2, s, strlen(s)) +# define CHECK_MALLOC_TAINT(newval) \ + CHECK_MALLOC_TOO_LATE_FOR_( \ + if (newval) { \ + panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n");\ + exit(1); }) +extern int Perl_doing_taint(int argc, char *argv[], char *envp[]); +# define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \ + if (Perl_doing_taint(argc, argv, env)) { \ + MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \ + }} STMT_END; #else /* MYMALLOC */ # define safemalloc safesysmalloc # define safecalloc safesyscalloc # define saferealloc safesysrealloc # define safefree safesysfree +# define CHECK_MALLOC_TOO_LATE_FOR(ch) ((void)0) +# define CHECK_MALLOC_TAINT(newval) ((void)0) +# define MALLOC_CHECK_TAINT(argc,argv,env) #endif /* MYMALLOC */ +#define TOO_LATE_FOR_(ch,s) Perl_croak(aTHX_ "Too late for \"-%c\" option%s", (char)(ch), s) +#define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "") +#define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}") +#define MALLOC_CHECK_TAINT2(argc,argv) MALLOC_CHECK_TAINT(argc,argv,NULL) + #if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr) #define strchr index #define strrchr rindex @@ -1676,17 +1691,10 @@ int isnan(double d); #endif -struct perl_mstats { - UV *nfree; - UV *ntotal; - IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain; - IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains; - IV minbucket; - /* Level 1 info */ - UV *bucket_mem_size; - UV *bucket_available_size; - UV nbuckets; -}; +#ifdef MYMALLOC +# include "malloc_ctl.h" +#endif + struct RExC_state_t; typedef MEM_SIZE STRLEN; @@ -1935,13 +1943,6 @@ typedef struct clone_params CLONE_PARAMS; # endif #endif -#ifdef JPL - /* E.g. JPL needs to operate on a copy of the real environment. - * JDK 1.2 and 1.3 seem to get upset if the original environment - * is diddled with. */ -# define NEED_ENVIRON_DUP_FOR_MODIFY -#endif - #ifndef PERL_SYS_INIT3 # define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) #endif diff --git a/plan9/plan9ish.h b/plan9/plan9ish.h index 9b32a7dd80..5c922cf0ba 100644 --- a/plan9/plan9ish.h +++ b/plan9/plan9ish.h @@ -106,7 +106,7 @@ #define ABORT() kill(PerlProc_getpid(),SIGABRT); #define BIT_BUCKET "/dev/null" -#define PERL_SYS_INIT(c,v) MALLOC_INIT +#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) MALLOC_INIT #define dXSUB_SYS #define PERL_SYS_TERM() MALLOC_TERM @@ -10747,6 +10747,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; + PL_savestack_ix = 0; + PL_savestack_max = -1; PL_retstack = 0; PL_sig_pending = 0; Zero(&PL_debug_pad, 1, struct perl_debug_pad); @@ -10778,6 +10780,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; + PL_savestack_ix = 0; + PL_savestack_max = -1; PL_retstack = 0; PL_sig_pending = 0; Zero(&PL_debug_pad, 1, struct perl_debug_pad); @@ -129,7 +129,7 @@ #define Mkdir(path,mode) mkdir((path),(mode)) #ifndef PERL_SYS_INIT -# define PERL_SYS_INIT(c,v) PERL_FPU_INIT MALLOC_INIT +# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT MALLOC_INIT #endif #ifndef PERL_SYS_TERM diff --git a/vms/vmsish.h b/vms/vmsish.h index 1a29aa6b59..076a6967f6 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -331,7 +331,7 @@ struct interp_intern { #endif #define BIT_BUCKET "_NLA0:" -#define PERL_SYS_INIT(c,v) vms_image_init((c),(v)); MALLOC_INIT +#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v)); MALLOC_INIT #define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM #define dXSUB_SYS #define HAS_KILL |