[bpt/guile.git] / libguile / debug-malloc.c

/* Copyright (C) 2000 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include <string.h>
#include <stdio.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)

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));
  memset (TABLE (new), 0, 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_gc_free called on object not allocated with scm_gc_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;

  if (old == NULL)
    scm_malloc_register (new, newwhat);
  else
    {
      GET_CREATE_HASH_ENTRY (object, object, old, l1);
      type = (hash_entry_t *) object->data;
      if (type == 0)
	{
	  fprintf (stderr,
		   "scm_gc_realloc called on object not allocated "
		   "with scm_gc_malloc\n");
	  abort ();
	}
      if (strcmp ((char *) type->key, newwhat) != 0)
	{
	  if (strcmp (newwhat, "vector-set-length!") != 0)
	    {
	      fprintf (stderr,
		       "scm_gc_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_gc_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_from_int ((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));
  memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
  malloc_object = malloc (sizeof (hash_entry_t)
			  * (malloc_object_size + N_SEEK));
  memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
}

void
scm_init_debug_malloc ()
{
#include "libguile/debug-malloc.x"
}
Commit	Line	Data
f1322139 MD	1	/* Copyright (C) 2000 Free Software Foundation, Inc.
f1322139 MD	2	*
73be1d9e MV	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public
	5	* License as published by the Free Software Foundation; either
	6	* version 2.1 of the License, or (at your option) any later version.
f1322139	7	*
73be1d9e	8	* This library is distributed in the hope that it will be useful,
f1322139	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	11	* Lesser General Public License for more details.
f1322139	12	*
73be1d9e MV	13	* You should have received a copy of the GNU Lesser General Public
73be1d9e MV	14	* License along with this library; if not, write to the Free Software
92205699	15	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
73be1d9e	16	*/
f1322139	17
f1322139	18	#include <string.h>
67e8151b	19	#include <stdio.h>
f1322139	20
a0599745 MD	21	#include "libguile/_scm.h"
	22	#include "libguile/alist.h"
	23	#include "libguile/strings.h"
f1322139	24
0e850825	25	#include "libguile/debug-malloc.h"
f1322139 MD	26
f1322139 MD	27	/*
eb422a4c MD	28	* The following code is a hack which I wrote quickly in order to
	29	* solve a memory leak problem. Since I wanted to have the
	30	* application running at close to normal speed, I prioritized speed
	31	* over maintainability. /mdj
f1322139 MD	32	*/
	33
	34	typedef struct hash_entry {
	35	const void *key;
	36	const void *data;
	37	} hash_entry_t;
	38
	39	#define N_SEEK 8
	40
	41	static int malloc_type_size = 31;
	42	static hash_entry_t *malloc_type = 0;
0e850825	43	static int malloc_object_size = 8191;
f1322139 MD	44	static hash_entry_t *malloc_object = 0;
	45
	46	#define TABLE(table) malloc_ ## table
	47	#define SIZE(table) malloc_ ## table ## _size
	48	#define HASH(table, key) \
	49	&TABLE (table)[((unsigned long) key >> 4UL) * 2654435761UL % SIZE (table)]
	50
	51	#define CREATE_HASH_ENTRY_AT(entry, table, h, k, done) \
	52	{ \
	53	int i; \
	54	do \
	55	{ \
	56	for (i = 0; i < N_SEEK; ++i) \
	57	if (h[i].key == 0) \
	58	goto done; \
	59	grow (&TABLE (table), &SIZE (table)); \
	60	h = HASH (table, k); \
	61	} \
	62	while (1); \
	63	done: \
	64	(entry) = &h[i]; \
	65	}
	66
	67	#define CREATE_HASH_ENTRY(table, k, d, done) \
	68	do \
	69	{ \
	70	hash_entry_t *h = HASH (table, k); \
	71	hash_entry_t *entry; \
	72	CREATE_HASH_ENTRY_AT (entry, table, h, k, done); \
	73	entry->key = (k); \
	74	entry->data = (d); \
	75	} \
	76	while (0)
	77
	78	#define GET_CREATE_HASH_ENTRY(entry, table, k, done) \
	79	do \
	80	{ \
	81	hash_entry_t *h = HASH (table, k); \
	82	int i; \
	83	for (i = 0; i < N_SEEK; ++i) \
	84	if (h[i].key == (void *) (k)) \
	85	goto done; \
	86	CREATE_HASH_ENTRY_AT (entry, table, h, k, gche ## done); \
	87	entry->key = (k); \
	88	entry->data = 0; \
	89	break; \
	90	done: \
	91	(entry) = &h[i]; \
	92	} \
	93	while (0)
	94
f1322139 MD	95	static void
	96	grow (hash_entry_t *table, int size)
	97	{
	98	hash_entry_t oldtable = table;
	99	int oldsize = *size + N_SEEK;
	100	hash_entry_t *TABLE (new) = 0;
	101	int SIZE (new);
	102	int i, j;
0e850825	103	SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
f1322139 MD	104	again:
	105	TABLE (new) = realloc (TABLE (new),
	106	sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
f22ed5a0	107	memset (TABLE (new), 0, sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
f1322139 MD	108	for (i = 0; i < oldsize; ++i)
	109	if (oldtable[i].key)
	110	{
	111	hash_entry_t *h = HASH (new, oldtable[i].key);
	112	for (j = 0; j < N_SEEK; ++j)
	113	if (h[j].key == 0)
	114	{
	115	h[j] = oldtable[i];
	116	goto next;
	117	}
	118	SIZE (new) *= 2;
	119	goto again;
	120	next:
	121	;
	122	}
	123	if (table == &malloc_type)
	124	{
	125	/* relocate malloc_object entries */
	126	for (i = 0; i < oldsize; ++i)
	127	if (oldtable[i].key)
	128	{
	129	hash_entry_t *h = HASH (new, oldtable[i].key);
	130	while (h->key != oldtable[i].key)
	131	++h;
	132	oldtable[i].data = h;
	133	}
	134	for (i = 0; i < malloc_object_size + N_SEEK; ++i)
	135	if (malloc_object[i].key)
	136	malloc_object[i].data
	137	= ((hash_entry_t *) malloc_object[i].data)->data;
	138	}
	139	free (*table);
	140	*table = TABLE (new);
	141	*size = SIZE (new);
	142	}
	143
	144	void
	145	scm_malloc_register (void obj, const char what)
	146	{
	147	hash_entry_t *type;
	148	GET_CREATE_HASH_ENTRY (type, type, what, l1);
	149	type->data = (void *) ((int) type->data + 1);
	150	CREATE_HASH_ENTRY (object, obj, type, l2);
	151	}
	152
	153	void
	154	scm_malloc_unregister (void *obj)
	155	{
	156	hash_entry_t object, type;
	157	GET_CREATE_HASH_ENTRY (object, object, obj, l1);
	158	type = (hash_entry_t *) object->data;
	159	if (type == 0)
	160	{
	161	fprintf (stderr,
4c9419ac	162	"scm_gc_free called on object not allocated with scm_gc_malloc\n");
f1322139 MD	163	abort ();
	164	}
	165	type->data = (void *) ((int) type->data - 1);
	166	object->key = 0;
	167	}
	168
	169	void
	170	scm_malloc_reregister (void old, void new, const char *newwhat)
	171	{
	172	hash_entry_t object, type;
4c9419ac MV	173
	174	if (old == NULL)
	175	scm_malloc_register (new, newwhat);
	176	else
f1322139	177	{
4c9419ac MV	178	GET_CREATE_HASH_ENTRY (object, object, old, l1);
	179	type = (hash_entry_t *) object->data;
	180	if (type == 0)
f1322139 MD	181	{
f1322139 MD	182	fprintf (stderr,
4c9419ac MV	183	"scm_gc_realloc called on object not allocated "
4c9419ac MV	184	"with scm_gc_malloc\n");
f1322139 MD	185	abort ();
f1322139 MD	186	}
4c9419ac MV	187	if (strcmp ((char *) type->key, newwhat) != 0)
	188	{
	189	if (strcmp (newwhat, "vector-set-length!") != 0)
	190	{
	191	fprintf (stderr,
	192	"scm_gc_realloc called with arg %s, was %s\n",
	193	newwhat,
	194	(char *) type->key);
	195	abort ();
	196	}
	197	}
	198	if (new != old)
	199	{
	200	object->key = 0;
	201	CREATE_HASH_ENTRY (object, new, type, l2);
	202	}
f1322139 MD	203	}
	204	}
	205
	206	SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
	207	(),
6836c87b MG	208	"Return an alist ((@var{what} . @var{n}) ...) describing number\n"
6836c87b MG	209	"of malloced objects.\n"
4c9419ac	210	"@var{what} is the second argument to @code{scm_gc_malloc},\n"
6836c87b MG	211	"@var{n} is the number of objects of that type currently\n"
6836c87b MG	212	"allocated.")
f1322139 MD	213	#define FUNC_NAME s_scm_malloc_stats
	214	{
	215	SCM res = SCM_EOL;
	216	int i;
	217	for (i = 0; i < malloc_type_size + N_SEEK; ++i)
	218	if (malloc_type[i].key)
	219	res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key),
e11e83f3	220	scm_from_int ((int) malloc_type[i].data),
f1322139 MD	221	res);
	222	return res;
	223	}
	224	#undef FUNC_NAME
	225
	226	void
	227	scm_debug_malloc_prehistory ()
	228	{
	229	malloc_type = malloc (sizeof (hash_entry_t)
	230	* (malloc_type_size + N_SEEK));
f22ed5a0	231	memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
f1322139 MD	232	malloc_object = malloc (sizeof (hash_entry_t)
f1322139 MD	233	* (malloc_object_size + N_SEEK));
f22ed5a0	234	memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
f1322139 MD	235	}
	236
	237	void
	238	scm_init_debug_malloc ()
	239	{
0e850825	240	#include "libguile/debug-malloc.x"
f1322139	241	}
8dc9439f	242