libguile/debug-malloc.c

   1 /* Copyright (C) 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 #include <string.h>
  43 #include <stdio.h>
  44
  45 #include "libguile/_scm.h"
  46 #include "libguile/alist.h"
  47 #include "libguile/strings.h"
  48
  49 #include "libguile/debug-malloc.h"
  50
  51 /*
  52  * The following code is a hack which I wrote quickly in order to
  53  * solve a memory leak problem.  Since I wanted to have the
  54  * application running at close to normal speed, I prioritized speed
  55  * over maintainability.  /mdj
  56  */
  57
  58 typedef struct hash_entry {
  59   const void *key;
  60   const void *data;
  61 } hash_entry_t;
  62
  63 #define N_SEEK 8
  64
  65 static int malloc_type_size = 31;
  66 static hash_entry_t *malloc_type = 0;
  67 static int malloc_object_size = 8191;
  68 static hash_entry_t *malloc_object = 0;
  69
  70 #define TABLE(table) malloc_ ## table
  71 #define SIZE(table) malloc_ ## table ## _size
  72 #define HASH(table, key) \
  73   &TABLE (table)[((unsigned long) key >> 4UL) * 2654435761UL % SIZE (table)]
  74
  75 #define CREATE_HASH_ENTRY_AT(entry, table, h, k, done)  \
  76 {                                                       \
  77   int i;                                                \
  78   do                                                    \
  79     {                                                   \
  80       for (i = 0; i < N_SEEK; ++i)                      \
  81         if (h[i].key == 0)                              \
  82           goto done;                                    \
  83       grow (&TABLE (table), &SIZE (table));             \
  84       h = HASH (table, k);                              \
  85     }                                                   \
  86   while (1);                                            \
  87  done:                                                  \
  88   (entry) = &h[i];                                      \
  89 }
  90
  91 #define CREATE_HASH_ENTRY(table, k, d, done)            \
  92   do                                                    \
  93     {                                                   \
  94       hash_entry_t *h = HASH (table, k);                \
  95       hash_entry_t *entry;                              \
  96       CREATE_HASH_ENTRY_AT (entry, table, h, k, done);  \
  97       entry->key = (k);                                 \
  98       entry->data = (d);                                \
  99     }                                                   \
 100   while (0)
 101
 102 #define GET_CREATE_HASH_ENTRY(entry, table, k, done)            \
 103   do                                                            \
 104     {                                                           \
 105       hash_entry_t *h = HASH (table, k);                        \
 106       int i;                                                    \
 107       for (i = 0; i < N_SEEK; ++i)                              \
 108         if (h[i].key == (void *) (k))                           \
 109           goto done;                                            \
 110        CREATE_HASH_ENTRY_AT (entry, table, h, k, gche ## done); \
 111        entry->key = (k);                                        \
 112        entry->data = 0;                                         \
 113        break;                                                   \
 114      done:                                                      \
 115       (entry) = &h[i];                                          \
 116     }                                                           \
 117   while (0)
 118
 119 #ifdef MISSING_BZERO_DECL
 120 extern void bzero (void *, size_t);
 121 #endif
 122
 123 static void
 124 grow (hash_entry_t **table, int *size)
 125 {
 126   hash_entry_t *oldtable = *table;
 127   int oldsize = *size + N_SEEK;
 128   hash_entry_t *TABLE (new) = 0;
 129   int SIZE (new);
 130   int i, j;
 131   SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
 132  again:
 133   TABLE (new) = realloc (TABLE (new),
 134                          sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
 135   bzero (TABLE (new), sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
 136   for (i = 0; i < oldsize; ++i)
 137     if (oldtable[i].key)
 138       {
 139         hash_entry_t *h = HASH (new, oldtable[i].key);
 140         for (j = 0; j < N_SEEK; ++j)
 141           if (h[j].key == 0)
 142             {
 143               h[j] = oldtable[i];
 144               goto next;
 145             }
 146         SIZE (new) *= 2;
 147         goto again;
 148       next:
 149         ;
 150       }
 151   if (table == &malloc_type)
 152     {
 153       /* relocate malloc_object entries */
 154       for (i = 0; i < oldsize; ++i)
 155         if (oldtable[i].key)
 156           {
 157             hash_entry_t *h = HASH (new, oldtable[i].key);
 158             while (h->key != oldtable[i].key)
 159               ++h;
 160             oldtable[i].data = h;
 161           }
 162       for (i = 0; i < malloc_object_size + N_SEEK; ++i)
 163         if (malloc_object[i].key)
 164           malloc_object[i].data
 165             = ((hash_entry_t *) malloc_object[i].data)->data;
 166     }
 167   free (*table);
 168   *table = TABLE (new);
 169   *size = SIZE (new);
 170 }
 171
 172 void
 173 scm_malloc_register (void *obj, const char *what)
 174 {
 175   hash_entry_t *type;
 176   GET_CREATE_HASH_ENTRY (type, type, what, l1);
 177   type->data = (void *) ((int) type->data + 1);
 178   CREATE_HASH_ENTRY (object, obj, type, l2);
 179 }
 180
 181 void
 182 scm_malloc_unregister (void *obj)
 183 {
 184   hash_entry_t *object, *type;
 185   GET_CREATE_HASH_ENTRY (object, object, obj, l1);
 186   type = (hash_entry_t *) object->data;
 187   if (type == 0)
 188     {
 189       fprintf (stderr,
 190                "scm_must_free called on object not allocated with scm_must_malloc\n");
 191       abort ();
 192     }
 193   type->data = (void *) ((int) type->data - 1);
 194   object->key = 0;
 195 }
 196
 197 void
 198 scm_malloc_reregister (void *old, void *new, const char *newwhat)
 199 {
 200   hash_entry_t *object, *type;
 201   GET_CREATE_HASH_ENTRY (object, object, old, l1);
 202   type = (hash_entry_t *) object->data;
 203   if (type == 0)
 204     {
 205       fprintf (stderr,
 206                "scm_must_realloc called on object not allocated with scm_must_malloc\n");
 207       abort ();
 208     }
 209   if (strcmp ((char *) type->key, newwhat) != 0)
 210     {
 211       if (strcmp (newwhat, "vector-set-length!") != 0)
 212         {
 213           fprintf (stderr,
 214                    "scm_must_realloc called with arg %s, was %s\n",
 215                    newwhat,
 216                    (char *) type->key);
 217           abort ();
 218         }
 219     }
 220   if (new != old)
 221     {
 222       object->key = 0;
 223       CREATE_HASH_ENTRY (object, new, type, l2);
 224     }
 225 }
 226
 227 SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
 228             (),
 229             "Return an alist ((WHAT . N) ...) describing number of malloced objects.\n"
 230             "WHAT is the second argument to scm_must_malloc, N is the number of objects\n"
 231             "of that type currently allocated.")
 232 #define FUNC_NAME s_scm_malloc_stats
 233 {
 234   SCM res = SCM_EOL;
 235   int i;
 236   for (i = 0; i < malloc_type_size + N_SEEK; ++i)
 237     if (malloc_type[i].key)
 238       res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key),
 239                        SCM_MAKINUM ((int) malloc_type[i].data),
 240                        res);
 241   return res;
 242 }
 243 #undef FUNC_NAME
 244
 245 void
 246 scm_debug_malloc_prehistory ()
 247 {
 248   malloc_type = malloc (sizeof (hash_entry_t)
 249                         * (malloc_type_size + N_SEEK));
 250   bzero (malloc_type, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
 251   malloc_object = malloc (sizeof (hash_entry_t)
 252                           * (malloc_object_size + N_SEEK));
 253   bzero (malloc_object, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
 254 }
 255
 256 void
 257 scm_init_debug_malloc ()
 258 {
 259 #ifndef SCM_MAGIC_SNARFER
 260 #include "libguile/debug-malloc.x"
 261 #endif
 262 }
 263