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