X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=914436e968bcebada056bd0c774b1f70c65c4e42;hb=bf8300decce77d53edc393ca2221fb591a778c59;hp=3ed1689dbdb84e82a614b9b94b8e9fac8eda8477;hpb=075abff3feb0c6965ba49108266b27bec1bd4ae6;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/malloc.c b/malloc.c
index 3ed1689..914436e 100644
--- a/malloc.c
+++ b/malloc.c
@@ -379,9 +379,6 @@
 #    ifndef UVxf
 #      define UVxf			"lx"
 #    endif
-#    ifndef Nullch
-#      define Nullch			NULL
-#    endif
 #    ifndef MEM_ALIGNBYTES
 #      define MEM_ALIGNBYTES		4
 #    endif
@@ -1156,17 +1153,16 @@ 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;
+    GV **gvp = (GV**)hv_fetchs(PL_defstash, "^M", FALSE);
 
-    if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
+    if (!gvp) gvp = (GV**)hv_fetchs(PL_defstash, "\015", FALSE);
     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);
+    pv = SvPV_nolen(sv);
     /* Check alignment: */
     if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
         PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
@@ -1174,7 +1170,7 @@ perl_get_emergency_buffer(IV *size)
     }
 
     SvPOK_off(sv);
-    SvPV_set(sv, Nullch);
+    SvPV_set(sv, NULL);
     SvCUR_set(sv, 0);
     SvLEN_set(sv, 0);
     *size = malloced_size(pv) + M_OVERHEAD;
@@ -1250,7 +1246,7 @@ emergency_sbrk(MEM_SIZE size)
 	if (emergency_buffer_size) {
 	    add_to_chain(emergency_buffer, emergency_buffer_size, 0);
 	    emergency_buffer_size = 0;
-	    emergency_buffer = Nullch;
+	    emergency_buffer = NULL;
 	    have = 1;
 	}
 
@@ -1277,7 +1273,7 @@ emergency_sbrk(MEM_SIZE size)
     MALLOC_UNLOCK;
     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;
+    return NULL;
 }
 
 #else /*  !defined(PERL_EMERGENCY_SBRK) */
@@ -1292,10 +1288,12 @@ write2(char *mess)
 
 #ifdef DEBUGGING
 #undef ASSERT
-#define	ASSERT(p,diag)   if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__);  else
+#define	ASSERT(p,diag)   if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__);
+
 static void
 botch(char *diag, char *s, char *file, int line)
 {
+    dVAR;
     if (!(PERL_MAYBE_ALIVE && PERL_GET_THX))
 	goto do_write;
     else {
@@ -1337,7 +1335,7 @@ fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
 {
     unsigned char *e = s + nbytes;
     long *lp;
-    long lfill = *(long*)fill;
+    const long lfill = *(long*)fill;
 
     if (PTR2UV(s) & (sizeof(long)-1)) {		/* Align the pattern */
 	int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
@@ -1378,7 +1376,7 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
 {
     unsigned char *e = s + nbytes;
     long *lp;
-    long lfill = *(long*)fill;
+    const long lfill = *(long*)fill;
 
     if (PTR2UV(s) & (sizeof(long)-1)) {		/* Align the pattern */
 	int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
@@ -1406,22 +1404,12 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
 #  define FILLCHECK_DEADBEEF(s, n)	((void)0)
 #endif
 
-Malloc_t
-Perl_malloc(register size_t nbytes)
+int
+S_ajust_size_and_find_bucket(size_t *nbytes_p)
 {
-  	register union overhead *p;
-  	register int bucket;
-  	register MEM_SIZE shiftr;
-
-#if defined(DEBUGGING) || defined(RCHECK)
-	MEM_SIZE size = nbytes;
-#endif
-
-	BARK_64K_LIMIT("Allocation",nbytes,nbytes);
-#ifdef DEBUGGING
-	if ((long)nbytes < 0)
-	    croak("%s", "panic: malloc");
-#endif
+  	MEM_SIZE shiftr;
+	int bucket;
+	size_t nbytes = *nbytes_p;
 
 	/*
 	 * Convert amount of memory requested into
@@ -1456,6 +1444,28 @@ Perl_malloc(register size_t nbytes)
 	    while (shiftr >>= 1)
   		bucket += BUCKETS_PER_POW2;
 	}
+	*nbytes_p = nbytes;
+	return bucket;
+}
+
+Malloc_t
+Perl_malloc(size_t nbytes)
+{
+        dVAR;
+  	register union overhead *p;
+  	register int bucket;
+
+#if defined(DEBUGGING) || defined(RCHECK)
+	MEM_SIZE size = nbytes;
+#endif
+
+	BARK_64K_LIMIT("Allocation",nbytes,nbytes);
+#ifdef DEBUGGING
+	if ((long)nbytes < 0)
+	    croak("%s", "panic: malloc");
+#endif
+
+	bucket = S_ajust_size_and_find_bucket(&nbytes);
 	MALLOC_LOCK;
 	/*
 	 * If nothing in hash bucket right now,
@@ -1516,7 +1526,7 @@ Perl_malloc(register size_t nbytes)
 	     || (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) {
 	    dTHX;
 	    PerlIO_printf(PerlIO_stderr(),
-			  "Unaligned `next' pointer in the free "
+			  "Unaligned \"next\" pointer in the free "
 			  "chain 0x%"UVxf" at 0x%"UVxf"\n",
 			  PTR2UV(p->ov_next), PTR2UV(p));
 	}
@@ -1666,6 +1676,7 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size)
 static union overhead *
 getpages(MEM_SIZE needed, int *nblksp, int bucket)
 {
+    dVAR;
     /* Need to do (possibly expensive) system call. Try to
        optimize it for rare calling. */
     MEM_SIZE require = needed - sbrked_remains;
@@ -1805,7 +1816,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
 # endif
 	}
 #endif
-	;				/* Finish `else' */
+	;				/* Finish "else" */
 	sbrked_remains = require - needed;
 	last_op = cp;
     }
@@ -1866,6 +1877,7 @@ getpages_adjacent(MEM_SIZE require)
 static void
 morecore(register int bucket)
 {
+        dVAR;
   	register union overhead *ovp;
   	register int rnu;       /* 2^rnu bytes will be requested */
   	int nblks;		/* become nblks blocks of the desired size */
@@ -1899,9 +1911,9 @@ morecore(register int bucket)
 		    }
 		}
 		if (t && *t) {
-		    write2("Unrecognized part of PERL_MALLOC_OPT: `");
+		    write2("Unrecognized part of PERL_MALLOC_OPT: \"");
 		    write2(t);
-		    write2("'\n");
+		    write2("\"\n");
 		}
 		if (changed)
 		    MallocCfg[MallocCfg_cfg_env_read] = 1;
@@ -1998,11 +2010,12 @@ morecore(register int bucket)
 }
 
 Free_t
-Perl_mfree(void *mp)
+Perl_mfree(Malloc_t where)
 {
+        dVAR;
   	register MEM_SIZE size;
 	register union overhead *ovp;
-	char *cp = (char*)mp;
+	char *cp = (char*)where;
 #ifdef PACK_MALLOC
 	u_char bucket;
 #endif 
@@ -2104,6 +2117,7 @@ Perl_mfree(void *mp)
 Malloc_t
 Perl_realloc(void *mp, size_t nbytes)
 {
+        dVAR;
   	register MEM_SIZE onb;
 	union overhead *ovp;
   	char *res;
@@ -2142,7 +2156,7 @@ Perl_realloc(void *mp, size_t nbytes)
 		    bad_free_warn = (pbf) ? atoi(pbf) : 1;
 		}
 		if (!bad_free_warn)
-		    return Nullch;
+		    return NULL;
 #ifdef RCHECK
 #ifdef PERL_CORE
 		{
@@ -2170,7 +2184,7 @@ Perl_realloc(void *mp, size_t nbytes)
 		warn("%s", "Bad realloc() ignored");
 #endif
 #endif
-		return Nullch;			/* sanity */
+		return NULL;			/* sanity */
 	    }
 
 	onb = BUCKET_SIZE_REAL(bucket);
@@ -2319,7 +2333,7 @@ Perl_strdup(const char *s)
     MEM_SIZE l = strlen(s);
     char *s1 = (char *)Perl_malloc(l+1);
 
-    return CopyD(s, s1, (MEM_SIZE)(l+1), char);
+    return (char *)CopyD(s, s1, (MEM_SIZE)(l+1), char);
 }
 
 #ifdef PERL_CORE
@@ -2342,7 +2356,7 @@ Perl_putenv(char *a)
   if (l < sizeof(buf))
       var = buf;
   else
-      var = Perl_malloc(l + 1);
+      var = (char *)Perl_malloc(l + 1);
   Copy(a, var, l, char);
   var[l + 1] = 0;
   my_setenv(var, val+1);
@@ -2355,14 +2369,17 @@ Perl_putenv(char *a)
 MEM_SIZE
 Perl_malloced_size(void *p)
 {
-    union overhead *ovp = (union overhead *)
+    union overhead * const ovp = (union overhead *)
 	((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
-    int bucket = OV_INDEX(ovp);
+    const int bucket = OV_INDEX(ovp);
+
+    PERL_ARGS_ASSERT_MALLOCED_SIZE;
+
 #ifdef RCHECK
     /* The caller wants to have a complete control over the chunk,
        disable the memory checking inside the chunk.  */
     if (bucket <= MAX_SHORT_BUCKET) {
-	MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
+	const MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
 	ovp->ov_size = size + M_OVERHEAD - 1;
 	*((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC;
     }
@@ -2370,6 +2387,13 @@ Perl_malloced_size(void *p)
     return BUCKET_SIZE_REAL(bucket);
 }
 
+
+MEM_SIZE
+Perl_malloc_good_size(size_t wanted)
+{
+    return BUCKET_SIZE_REAL(S_ajust_size_and_find_bucket(&wanted));
+}
+
 #  ifdef BUCKETS_ROOT2
 #    define MIN_EVEN_REPORT 6
 #  else
@@ -2384,6 +2408,8 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
   	register union overhead *p;
 	struct chunk_chain_s* nextchain;
 
+	PERL_ARGS_ASSERT_GET_MSTATS;
+
   	buf->topbucket = buf->topbucket_ev = buf->topbucket_odd 
 	    = buf->totfree = buf->total = buf->total_chain = 0;
 
@@ -2424,6 +2450,8 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
 		buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i);
 	    }
 	}
+#else /* defined DEBUGGING_MSTATS */
+	PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n");
 #endif	/* defined DEBUGGING_MSTATS */
 	return 0;		/* XXX unused */
 }
@@ -2435,7 +2463,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
  * frees for each size category.
  */
 void
-Perl_dump_mstats(pTHX_ char *s)
+Perl_dump_mstats(pTHX_ const char *s)
 {
 #ifdef DEBUGGING_MSTATS
   	register int i;
@@ -2443,6 +2471,8 @@ Perl_dump_mstats(pTHX_ char *s)
 	UV nf[NBUCKETS];
 	UV nt[NBUCKETS];
 
+	PERL_ARGS_ASSERT_DUMP_MSTATS;
+
 	buffer.nfree  = nf;
 	buffer.ntotal = nt;
 	get_mstats(&buffer, NBUCKETS, 0);
@@ -2495,6 +2525,8 @@ Perl_dump_mstats(pTHX_ char *s)
 		      buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good,
 		      buffer.sbrk_slack, buffer.start_slack,
 		      buffer.total_chain, buffer.sbrked_remains);
+#else /* DEBUGGING_MSTATS */
+	PerlIO_printf(Perl_error_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",s);
 #endif /* DEBUGGING_MSTATS */
 }