libguile/debug-malloc.c

   1 /* Copyright (C) 2000 Free Software Foundation, Inc.
   2  *
   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.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18 #include <string.h>
  19 #include <stdio.h>
  20
  21 #include "libguile/_scm.h"
  22 #include "libguile/alist.h"
  23 #include "libguile/strings.h"
  24
  25 #include "libguile/debug-malloc.h"
  26
  27 /*
  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
  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;
  43 static int malloc_object_size = 8191;
  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
  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;
 103   SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
 104  again:
 105   TABLE (new) = realloc (TABLE (new),
 106                          sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
 107   memset (TABLE (new), 0, sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
 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,
 162                "scm_gc_free called on object not allocated with scm_gc_malloc\n");
 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;
 173
 174   if (old == NULL)
 175     scm_malloc_register (new, newwhat);
 176   else
 177     {
 178       GET_CREATE_HASH_ENTRY (object, object, old, l1);
 179       type = (hash_entry_t *) object->data;
 180       if (type == 0)
 181         {
 182           fprintf (stderr,
 183                    "scm_gc_realloc called on object not allocated "
 184                    "with scm_gc_malloc\n");
 185           abort ();
 186         }
 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         }
 203     }
 204 }
 205
 206 SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
 207             (),
 208             "Return an alist ((@var{what} . @var{n}) ...) describing number\n"
 209             "of malloced objects.\n"
 210             "@var{what} is the second argument to @code{scm_gc_malloc},\n"
 211             "@var{n} is the number of objects of that type currently\n"
 212             "allocated.")
 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),
 220                        scm_from_int ((int) malloc_type[i].data),
 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));
 231   memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
 232   malloc_object = malloc (sizeof (hash_entry_t)
 233                           * (malloc_object_size + N_SEEK));
 234   memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
 235 }
 236
 237 void
 238 scm_init_debug_malloc ()
 239 {
 240 #include "libguile/debug-malloc.x"
 241 }
 242