view release on metacpan or  search on metacpan

malloc.c  view on Meta::CPAN

#ifdef DEBUGGING_MSTATS
                nmalloc[bucket]--;
                nmalloc[pow * BUCKETS_PER_POW2]++;
#endif 	    
                if (pow * BUCKETS_PER_POW2 > (MEM_SIZE)max_bucket)
                    max_bucket = pow * BUCKETS_PER_POW2;
                *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
                MALLOC_UNLOCK;
                goto inplace_label;
            } else {
                MALLOC_UNLOCK;		
                goto hard_way;
            }
        } else {
          hard_way:
            DEBUG_m(PerlIO_printf(Perl_debug_log, 
                              "0x%" UVxf ": (%05lu) realloc %ld bytes the hard way\n",
                              PTR2UV(cp),(unsigned long)(PL_an++),
                              (long)size));
            if ((res = (char*)Perl_malloc(nbytes)) == NULL)
                return (NULL);
            if (cp != res)			/* common optimization */
                Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
            Perl_mfree(cp);
        }
        return ((Malloc_t)res);
}

/*
=for apidoc calloc

Implements L<perlapi/C<Newxz>> which you should use instead.

=cut
*/

Malloc_t
Perl_calloc(size_t elements, size_t size)
{
    long sz = elements * size;
    Malloc_t p = Perl_malloc(sz);

    if (p) {
        memset((void*)p, 0, sz);
    }
    return p;
}

char *
Perl_strdup(const char *s)
{
    MEM_SIZE l = strlen(s);
    char *s1 = (char *)Perl_malloc(l+1);

    return (char *)CopyD(s, s1, (MEM_SIZE)(l+1), char);
}

int
Perl_putenv(char *a)
{
    /* Sometimes system's putenv conflicts with my_setenv() - this is system
       malloc vs Perl's free(). */
  dTHX;
  char *var;
  char *val = a;
  MEM_SIZE l;
  char buf[80];

  while (*val && *val != '=')
      val++;
  if (!*val)
      return -1;
  l = val - a;
  if (l < sizeof(buf))
      var = buf;
  else
      var = (char *)Perl_malloc(l + 1);
  Copy(a, var, l, char);
  var[l + 1] = 0;
  my_setenv(var, val+1);
  if (var != buf)
      Perl_mfree(var);
  return 0;
}

MEM_SIZE
Perl_malloced_size(void *p)
{
    union overhead * const ovp = (union overhead *)
        ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
    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) {
        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;
    }
#endif
    return BUCKET_SIZE_REAL(bucket);
}


MEM_SIZE
Perl_malloc_good_size(size_t wanted)
{
    return BUCKET_SIZE_REAL(adjust_size_and_find_bucket(&wanted));
}

#  ifdef BUCKETS_ROOT2
#    define MIN_EVEN_REPORT 6
#  else
#    define MIN_EVEN_REPORT MIN_BUCKET
#  endif 

int
Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
{
#ifdef DEBUGGING_MSTATS
        int i, j;
        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;

        buf->minbucket = MIN_BUCKET;
        MALLOC_LOCK;
        for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
                for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
                        ;
                if (i < buflen) {
                    buf->nfree[i] = j;
                    buf->ntotal[i] = nmalloc[i];