mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
264 lines
7.5 KiB
C
264 lines
7.5 KiB
C
/* Copyright (C) 2000 Free Software Foundation, Inc.
|
|
*
|
|
* This program is free software; you can redistribute it and/or modify
|
|
* it under the terms of the GNU General Public License as published by
|
|
* the Free Software Foundation; either version 2, or (at your option)
|
|
* any later version.
|
|
*
|
|
* This program is distributed in the hope that it will be useful,
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
* GNU General Public License for more details.
|
|
*
|
|
* You should have received a copy of the GNU General Public License
|
|
* along with this software; see the file COPYING. If not, write to
|
|
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
|
* Boston, MA 02111-1307 USA
|
|
*
|
|
* As a special exception, the Free Software Foundation gives permission
|
|
* for additional uses of the text contained in its release of GUILE.
|
|
*
|
|
* The exception is that, if you link the GUILE library with other files
|
|
* to produce an executable, this does not by itself cause the
|
|
* resulting executable to be covered by the GNU General Public License.
|
|
* Your use of that executable is in no way restricted on account of
|
|
* linking the GUILE library code into it.
|
|
*
|
|
* This exception does not however invalidate any other reasons why
|
|
* the executable file might be covered by the GNU General Public License.
|
|
*
|
|
* This exception applies only to the code released by the
|
|
* Free Software Foundation under the name GUILE. If you copy
|
|
* code from other Free Software Foundation releases into a copy of
|
|
* GUILE, as the General Public License permits, the exception does
|
|
* not apply to the code that you add in this way. To avoid misleading
|
|
* anyone as to the status of such modified files, you must delete
|
|
* this exception notice from them.
|
|
*
|
|
* If you write modifications of your own for GUILE, it is your choice
|
|
* whether to permit this exception to apply to your modifications.
|
|
* If you do not wish that, delete this exception notice. */
|
|
|
|
#include <string.h>
|
|
|
|
#include "libguile/_scm.h"
|
|
#include "libguile/alist.h"
|
|
#include "libguile/strings.h"
|
|
|
|
#include "libguile/debug-malloc.h"
|
|
|
|
/*
|
|
* The following code is a hack which I wrote quickly in order to
|
|
* solve a memory leak problem. Since I wanted to have the
|
|
* application running at close to normal speed, I prioritized speed
|
|
* over maintainability. /mdj
|
|
*/
|
|
|
|
typedef struct hash_entry {
|
|
const void *key;
|
|
const void *data;
|
|
} hash_entry_t;
|
|
|
|
#define N_SEEK 8
|
|
|
|
static int malloc_type_size = 31;
|
|
static hash_entry_t *malloc_type = 0;
|
|
static int malloc_object_size = 8191;
|
|
static hash_entry_t *malloc_object = 0;
|
|
|
|
#define TABLE(table) malloc_ ## table
|
|
#define SIZE(table) malloc_ ## table ## _size
|
|
#define HASH(table, key) \
|
|
&TABLE (table)[((unsigned long) key >> 4UL) * 2654435761UL % SIZE (table)]
|
|
|
|
#define CREATE_HASH_ENTRY_AT(entry, table, h, k, done) \
|
|
{ \
|
|
int i; \
|
|
do \
|
|
{ \
|
|
for (i = 0; i < N_SEEK; ++i) \
|
|
if (h[i].key == 0) \
|
|
goto done; \
|
|
grow (&TABLE (table), &SIZE (table)); \
|
|
h = HASH (table, k); \
|
|
} \
|
|
while (1); \
|
|
done: \
|
|
(entry) = &h[i]; \
|
|
}
|
|
|
|
#define CREATE_HASH_ENTRY(table, k, d, done) \
|
|
do \
|
|
{ \
|
|
hash_entry_t *h = HASH (table, k); \
|
|
hash_entry_t *entry; \
|
|
CREATE_HASH_ENTRY_AT (entry, table, h, k, done); \
|
|
entry->key = (k); \
|
|
entry->data = (d); \
|
|
} \
|
|
while (0)
|
|
|
|
#define GET_CREATE_HASH_ENTRY(entry, table, k, done) \
|
|
do \
|
|
{ \
|
|
hash_entry_t *h = HASH (table, k); \
|
|
int i; \
|
|
for (i = 0; i < N_SEEK; ++i) \
|
|
if (h[i].key == (void *) (k)) \
|
|
goto done; \
|
|
CREATE_HASH_ENTRY_AT (entry, table, h, k, gche ## done); \
|
|
entry->key = (k); \
|
|
entry->data = 0; \
|
|
break; \
|
|
done: \
|
|
(entry) = &h[i]; \
|
|
} \
|
|
while (0)
|
|
|
|
#ifdef MISSING_BZERO_DECL
|
|
extern void bzero (void *, size_t);
|
|
#endif
|
|
|
|
static void
|
|
grow (hash_entry_t **table, int *size)
|
|
{
|
|
hash_entry_t *oldtable = *table;
|
|
int oldsize = *size + N_SEEK;
|
|
hash_entry_t *TABLE (new) = 0;
|
|
int SIZE (new);
|
|
int i, j;
|
|
SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
|
|
again:
|
|
TABLE (new) = realloc (TABLE (new),
|
|
sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
|
|
bzero (TABLE (new), sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
|
|
for (i = 0; i < oldsize; ++i)
|
|
if (oldtable[i].key)
|
|
{
|
|
hash_entry_t *h = HASH (new, oldtable[i].key);
|
|
for (j = 0; j < N_SEEK; ++j)
|
|
if (h[j].key == 0)
|
|
{
|
|
h[j] = oldtable[i];
|
|
goto next;
|
|
}
|
|
SIZE (new) *= 2;
|
|
goto again;
|
|
next:
|
|
;
|
|
}
|
|
if (table == &malloc_type)
|
|
{
|
|
/* relocate malloc_object entries */
|
|
for (i = 0; i < oldsize; ++i)
|
|
if (oldtable[i].key)
|
|
{
|
|
hash_entry_t *h = HASH (new, oldtable[i].key);
|
|
while (h->key != oldtable[i].key)
|
|
++h;
|
|
oldtable[i].data = h;
|
|
}
|
|
for (i = 0; i < malloc_object_size + N_SEEK; ++i)
|
|
if (malloc_object[i].key)
|
|
malloc_object[i].data
|
|
= ((hash_entry_t *) malloc_object[i].data)->data;
|
|
}
|
|
free (*table);
|
|
*table = TABLE (new);
|
|
*size = SIZE (new);
|
|
}
|
|
|
|
void
|
|
scm_malloc_register (void *obj, const char *what)
|
|
{
|
|
hash_entry_t *type;
|
|
GET_CREATE_HASH_ENTRY (type, type, what, l1);
|
|
type->data = (void *) ((int) type->data + 1);
|
|
CREATE_HASH_ENTRY (object, obj, type, l2);
|
|
}
|
|
|
|
void
|
|
scm_malloc_unregister (void *obj)
|
|
{
|
|
hash_entry_t *object, *type;
|
|
GET_CREATE_HASH_ENTRY (object, object, obj, l1);
|
|
type = (hash_entry_t *) object->data;
|
|
if (type == 0)
|
|
{
|
|
fprintf (stderr,
|
|
"scm_must_free called on object not allocated with scm_must_malloc\n");
|
|
abort ();
|
|
}
|
|
type->data = (void *) ((int) type->data - 1);
|
|
object->key = 0;
|
|
}
|
|
|
|
void
|
|
scm_malloc_reregister (void *old, void *new, const char *newwhat)
|
|
{
|
|
hash_entry_t *object, *type;
|
|
GET_CREATE_HASH_ENTRY (object, object, old, l1);
|
|
type = (hash_entry_t *) object->data;
|
|
if (type == 0)
|
|
{
|
|
fprintf (stderr,
|
|
"scm_must_realloc called on object not allocated with scm_must_malloc\n");
|
|
abort ();
|
|
}
|
|
if (strcmp ((char *) type->key, newwhat) != 0)
|
|
{
|
|
if (strcmp (newwhat, "vector-set-length!") != 0)
|
|
{
|
|
fprintf (stderr,
|
|
"scm_must_realloc called with arg %s, was %s\n",
|
|
newwhat,
|
|
(char *) type->key);
|
|
abort ();
|
|
}
|
|
}
|
|
if (new != old)
|
|
{
|
|
object->key = 0;
|
|
CREATE_HASH_ENTRY (object, new, type, l2);
|
|
}
|
|
}
|
|
|
|
SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
|
|
(),
|
|
"Return an alist ((@var{what} . @var{n}) ...) describing number\n"
|
|
"of malloced objects.\n"
|
|
"@var{what} is the second argument to @code{scm_must_malloc},\n"
|
|
"@var{n} is the number of objects of that type currently\n"
|
|
"allocated.")
|
|
#define FUNC_NAME s_scm_malloc_stats
|
|
{
|
|
SCM res = SCM_EOL;
|
|
int i;
|
|
for (i = 0; i < malloc_type_size + N_SEEK; ++i)
|
|
if (malloc_type[i].key)
|
|
res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key),
|
|
SCM_MAKINUM ((int) malloc_type[i].data),
|
|
res);
|
|
return res;
|
|
}
|
|
#undef FUNC_NAME
|
|
|
|
void
|
|
scm_debug_malloc_prehistory ()
|
|
{
|
|
malloc_type = malloc (sizeof (hash_entry_t)
|
|
* (malloc_type_size + N_SEEK));
|
|
bzero (malloc_type, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
|
|
malloc_object = malloc (sizeof (hash_entry_t)
|
|
* (malloc_object_size + N_SEEK));
|
|
bzero (malloc_object, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
|
|
}
|
|
|
|
void
|
|
scm_init_debug_malloc ()
|
|
{
|
|
#ifndef SCM_MAGIC_SNARFER
|
|
#include "libguile/debug-malloc.x"
|
|
#endif
|
|
}
|
|
|