libguile/debug-malloc.c

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