X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=d8b28f21408b4612946b31091cc3fdbe30638f51;hb=0bfa2a8afc04ca8a47987d5890bbbe751faf4444;hp=fad5520bea6cfd1f3a90b10250ec37d788cf8bf3;hpb=86c11942206ec09dd2a486bb22552aa2f170e322;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index fad5520..d8b28f2 100644
--- a/util.c
+++ b/util.c
@@ -57,6 +57,16 @@ int putenv(char *);
  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  */
 
+static char *
+S_write_no_mem(pTHX)
+{
+    /* Can't use PerlIO to write as it allocates memory */
+    PerlLIO_write(PerlIO_fileno(Perl_error_log),
+		  PL_no_mem, strlen(PL_no_mem));
+    my_exit(1);
+    NORETURN_FUNCTION_END;
+}
+
 /* paranoid version of system's malloc() */
 
 Malloc_t
@@ -71,6 +81,9 @@ Perl_safesysmalloc(MEM_SIZE size)
 	    my_exit(1);
 	}
 #endif /* HAS_64K_LIMIT */
+#ifdef PERL_TRACK_MEMPOOL
+    size += sTHX;
+#endif
 #ifdef DEBUGGING
     if ((long)size < 0)
 	Perl_croak_nocontext("panic: malloc");
@@ -78,16 +91,17 @@ Perl_safesysmalloc(MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-    if (ptr != Nullch)
+    if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+        *(tTHX*)ptr = aTHX;
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
 	return ptr;
+}
     else if (PL_nomemok)
 	return Nullch;
     else {
-	/* Can't use PerlIO to write as it allocates memory */
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
-	return Nullch;
+	return write_no_mem();
     }
     /*NOTREACHED*/
 }
@@ -117,6 +131,14 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 
     if (!where)
 	return safesysmalloc(size);
+#ifdef PERL_TRACK_MEMPOOL
+    where = (Malloc_t)((char*)where-sTHX);
+    size += sTHX;
+    if (*(tTHX*)where != aTHX) {
+	/* int *nowhere = NULL; *nowhere = 0; */
+        Perl_croak_nocontext("panic: realloc from wrong pool");
+    }
+#endif
 #ifdef DEBUGGING
     if ((long)size < 0)
 	Perl_croak_nocontext("panic: realloc");
@@ -127,16 +149,16 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 
-    if (ptr != Nullch)
+    if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
 	return ptr;
+    }
     else if (PL_nomemok)
 	return Nullch;
     else {
-	/* Can't use PerlIO to write as it allocates memory */
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
-	return Nullch;
+	return write_no_mem();
     }
     /*NOTREACHED*/
 }
@@ -147,11 +169,18 @@ Free_t
 Perl_safesysfree(Malloc_t where)
 {
     dVAR;
-#ifdef PERL_IMPLICIT_SYS
+#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
     dTHX;
 #endif
     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
     if (where) {
+#ifdef PERL_TRACK_MEMPOOL
+        where = (Malloc_t)((char*)where-sTHX);
+        if (*(tTHX*)where != aTHX) {
+	    /* int *nowhere = NULL; *nowhere = 0; */
+            Perl_croak_nocontext("panic: free from wrong pool");
+	}
+#endif
 	PerlMem_free(where);
     }
 }
@@ -176,23 +205,23 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 	Perl_croak_nocontext("panic: calloc");
 #endif
     size *= count;
+#ifdef PERL_TRACK_MEMPOOL
+    size += sTHX;
+#endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
     if (ptr != Nullch) {
 	memset((void*)ptr, 0, size);
+#ifdef PERL_TRACK_MEMPOOL
+        *(tTHX*)ptr = aTHX;
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
 	return ptr;
     }
     else if (PL_nomemok)
 	return Nullch;
-    else {
-	/* Can't use PerlIO to write as it allocates memory */
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
-	return Nullch;
-    }
-    /*NOTREACHED*/
+    return write_no_mem();
 }
 
 /* These must be defined when not using Perl's malloc for binary
@@ -291,7 +320,7 @@ char *
 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 {
     register const I32 first = *little;
-    register const char *littleend = lend;
+    register const char * const littleend = lend;
 
     if (!first && little >= littleend)
 	return (char*)big;
@@ -321,7 +350,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
 {
     register const char *bigbeg;
     register const I32 first = *little;
-    register const char *littleend = lend;
+    register const char * const littleend = lend;
 
     if (!first && little >= littleend)
 	return (char*)bigend;
@@ -819,9 +848,7 @@ Perl_savesharedpv(pTHX_ const char *pv)
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
+	return write_no_mem();
     }
     return memcpy(newaddr,pv,pvlen);
 }
@@ -839,7 +866,7 @@ char *
 Perl_savesvpv(pTHX_ SV *sv)
 {
     STRLEN len;
-    const char *pv = SvPV_const(sv, len);
+    const char * const pv = SvPV_const(sv, len);
     register char *newaddr;
 
     ++len;
@@ -1358,7 +1385,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     if (ckDEAD(err)) {
 	SV * const msv = vmess(pat, args);
 	STRLEN msglen;
-	const char *message = SvPV_const(msv, msglen);
+	const char * const message = SvPV_const(msv, msglen);
 	const I32 utf8 = SvUTF8(msv);
 
 	if (PL_diehook) {
@@ -2658,7 +2685,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 	    if ((entry = hv_iternext(PL_pidstatus))) {
 		SV * const sv = hv_iterval(PL_pidstatus,entry);
 		I32 len;
-		const char *spid = hv_iterkey(entry,&len);
+		const char * const spid = hv_iterkey(entry,&len);
 
 		assert (len == sizeof(Pid_t));
 		memcpy((char *)&pid, spid, len);
@@ -2739,7 +2766,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
     /* Needs work for PerlIO ! */
     FILE * const f = PerlIO_findFILE(ptr);
-    I32 result = pclose(f);
+    const I32 result = pclose(f);
     PerlIO_releaseFILE(ptr,f);
     return result;
 }
@@ -2840,7 +2867,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #endif
     /* additional extensions to try in each dir if scriptname not found */
 #ifdef SEARCH_EXTS
-    const char *const exts[] = { SEARCH_EXTS };
+    static const char *const exts[] = { SEARCH_EXTS };
     const char *const *const ext = search_ext ? search_ext : exts;
     int extidx = 0, i = 0;
     const char *curext = Nullch;
@@ -3147,7 +3174,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
-    const MGVTBL* result = Null(MGVTBL*);
+    const MGVTBL* result;
 
     switch(vtbl_id) {
     case want_vtbl_sv:
@@ -3242,6 +3269,9 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
     case want_vtbl_utf8:
 	result = &PL_vtbl_utf8;
 	break;
+    default:
+	result = Null(MGVTBL*);
+	break;
     }
     return (MGVTBL*)result;
 }
@@ -3756,7 +3786,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 	 * size from the heap if they are given a NULL buffer pointer.
 	 * The problem is that this behaviour is not portable. */
 	if (getcwd(buf, sizeof(buf) - 1)) {
-	    sv_setpvn(sv, buf, strlen(buf));
+	    sv_setpv(sv, buf);
 	    return TRUE;
 	}
 	else {
@@ -3916,8 +3946,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     int saw_period = 0;
     int alpha = 0;
     int width = 3;
-    AV *av = newAV();
-    SV *hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    AV * const av = newAV();
+    SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
 #ifndef NODEFAULT_SHAREKEYS
@@ -4265,7 +4295,7 @@ Perl_vnumify(pTHX_ SV *vs)
     {
 	digit = SvIV(*av_fetch(av, i, 0));
 	if ( width < 3 ) {
-	    const int denom = (int)pow(10,(3-width));
+	    const int denom = (width == 2 ? 10 : 100);
 	    const div_t term = div((int)PERL_ABS(digit),denom);
 	    Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
 	}
@@ -4705,7 +4735,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #endif
   tidy_up_and_fail:
     {
-	int save_errno = errno;
+	const int save_errno = errno;
 	if (listener != -1)
 	    PerlLIO_close(listener);
 	if (connector != -1)
@@ -4945,8 +4975,8 @@ Perl_init_global_struct(pTHX)
 #ifdef PERL_GLOBAL_STRUCT
 #  define PERL_GLOBAL_STRUCT_INIT
 #  include "opcode.h" /* the ppaddr and check */
-    IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
-    IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
+    const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
+    const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
@@ -5025,7 +5055,7 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t
 				  " %s = %"IVdf": %"UVxf"\n",
 				  filename, linenumber, funcname, n, typesize,
 				  typename, n * typesize, PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, len));
+    PerlLIO_write(2,  buf, len);
 #endif
     return newalloc;
 }