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 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 #include <string.h>
  46 #include <stdio.h>
  47
  48 #include "libguile/_scm.h"
  49 #include "libguile/alist.h"
  50 #include "libguile/strings.h"
  51
  52 #include "libguile/debug-malloc.h"
  53
  54 /*
  55  * The following code is a hack written quickly in order to solve a
  56  * memory leak problem.  No respect has been paid to maintainability
  57  * etc, but since it isn't a part of Guile proper, and probably
  58  * doesn't need maintenance, it has been contributed because of its
  59  * utility.
  60  *
  61  * It is intended to be maximally fast (so that the application runs
  62  * close to normal speed).
  63  */
  64
  65 typedef struct hash_entry {
  66   const void *key;
  67   const void *data;
  68 } hash_entry_t;
  69
  70 #define N_SEEK 8
  71
  72 static int malloc_type_size = 31;
  73 static hash_entry_t *malloc_type = 0;
  74 static int malloc_object_size = 8191;
  75 static hash_entry_t *malloc_object = 0;
  76
  77 #define TABLE(table) malloc_ ## table
  78 #define SIZE(table) malloc_ ## table ## _size
  79 #define HASH(table, key) \
  80   &TABLE (table)[((unsigned long) key >> 4UL) * 2654435761UL % SIZE (table)]
  81
  82 #define CREATE_HASH_ENTRY_AT(entry, table, h, k, done)  \
  83 {                                                       \
  84   int i;                                                \
  85   do                                                    \
  86     {                                                   \
  87       for (i = 0; i < N_SEEK; ++i)                      \
  88         if (h[i].key == 0)                              \
  89           goto done;                                    \
  90       grow (&TABLE (table), &SIZE (table));             \
  91       h = HASH (table, k);                              \
  92     }                                                   \
  93   while (1);                                            \
  94  done:                                                  \
  95   (entry) = &h[i];                                      \
  96 }
  97
  98 #define CREATE_HASH_ENTRY(table, k, d, done)            \
  99   do                                                    \
 100     {                                                   \
 101       hash_entry_t *h = HASH (table, k);                \
 102       hash_entry_t *entry;                              \
 103       CREATE_HASH_ENTRY_AT (entry, table, h, k, done);  \
 104       entry->key = (k);                                 \
 105       entry->data = (d);                                \
 106     }                                                   \
 107   while (0)
 108
 109 #define GET_CREATE_HASH_ENTRY(entry, table, k, done)            \
 110   do                                                            \
 111     {                                                           \
 112       hash_entry_t *h = HASH (table, k);                        \
 113       int i;                                                    \
 114       for (i = 0; i < N_SEEK; ++i)                              \
 115         if (h[i].key == (void *) (k))                           \
 116           goto done;                                            \
 117        CREATE_HASH_ENTRY_AT (entry, table, h, k, gche ## done); \
 118        entry->key = (k);                                        \
 119        entry->data = 0;                                         \
 120        break;                                                   \
 121      done:                                                      \
 122       (entry) = &h[i];                                          \
 123     }                                                           \
 124   while (0)
 125
 126 #ifdef MISSING_BZERO_DECL
 127 extern void bzero (void *, size_t);
 128 #endif
 129
 130 static void
 131 grow (hash_entry_t **table, int *size)
 132 {
 133   hash_entry_t *oldtable = *table;
 134   int oldsize = *size + N_SEEK;
 135   hash_entry_t *TABLE (new) = 0;
 136   int SIZE (new);
 137   int i, j;
 138   SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
 139  again:
 140   TABLE (new) = realloc (TABLE (new),
 141                          sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
 142   bzero (TABLE (new), sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
 143   for (i = 0; i < oldsize; ++i)
 144     if (oldtable[i].key)
 145       {
 146         hash_entry_t *h = HASH (new, oldtable[i].key);
 147         for (j = 0; j < N_SEEK; ++j)
 148           if (h[j].key == 0)
 149             {
 150               h[j] = oldtable[i];
 151               goto next;
 152             }
 153         SIZE (new) *= 2;
 154         goto again;
 155       next:
 156         ;
 157       }
 158   if (table == &malloc_type)
 159     {
 160       /* relocate malloc_object entries */
 161       for (i = 0; i < oldsize; ++i)
 162         if (oldtable[i].key)
 163           {
 164             hash_entry_t *h = HASH (new, oldtable[i].key);
 165             while (h->key != oldtable[i].key)
 166               ++h;
 167             oldtable[i].data = h;
 168           }
 169       for (i = 0; i < malloc_object_size + N_SEEK; ++i)
 170         if (malloc_object[i].key)
 171           malloc_object[i].data
 172             = ((hash_entry_t *) malloc_object[i].data)->data;
 173     }
 174   free (*table);
 175   *table = TABLE (new);
 176   *size = SIZE (new);
 177 }
 178
 179 void
 180 scm_malloc_register (void *obj, const char *what)
 181 {
 182   hash_entry_t *type;
 183   GET_CREATE_HASH_ENTRY (type, type, what, l1);
 184   type->data = (void *) ((int) type->data + 1);
 185   CREATE_HASH_ENTRY (object, obj, type, l2);
 186 }
 187
 188 void
 189 scm_malloc_unregister (void *obj)
 190 {
 191   hash_entry_t *object, *type;
 192   GET_CREATE_HASH_ENTRY (object, object, obj, l1);
 193   type = (hash_entry_t *) object->data;
 194   if (type == 0)
 195     {
 196       fprintf (stderr,
 197                "scm_must_free called on object not allocated with scm_must_malloc\n");
 198       abort ();
 199     }
 200   type->data = (void *) ((int) type->data - 1);
 201   object->key = 0;
 202 }
 203
 204 void
 205 scm_malloc_reregister (void *old, void *new, const char *newwhat)
 206 {
 207   hash_entry_t *object, *type;
 208   GET_CREATE_HASH_ENTRY (object, object, old, l1);
 209   type = (hash_entry_t *) object->data;
 210   if (type == 0)
 211     {
 212       fprintf (stderr,
 213                "scm_must_realloc called on object not allocated with scm_must_malloc\n");
 214       abort ();
 215     }
 216   if (strcmp ((char *) type->key, newwhat) != 0)
 217     {
 218       if (strcmp (newwhat, "vector-set-length!") != 0)
 219         {
 220           fprintf (stderr,
 221                    "scm_must_realloc called with arg %s, was %s\n",
 222                    newwhat,
 223                    (char *) type->key);
 224           abort ();
 225         }
 226     }
 227   if (new != old)
 228     {
 229       object->key = 0;
 230       CREATE_HASH_ENTRY (object, new, type, l2);
 231     }
 232 }
 233
 234 SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
 235             (),
 236             "Return an alist ((WHAT . N) ...) describing number of malloced objects.\n"
 237             "WHAT is the second argument to scm_must_malloc, N is the number of objects\n"
 238             "of that type currently allocated.")
 239 #define FUNC_NAME s_scm_malloc_stats
 240 {
 241   SCM res = SCM_EOL;
 242   int i;
 243   for (i = 0; i < malloc_type_size + N_SEEK; ++i)
 244     if (malloc_type[i].key)
 245       res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key),
 246                        SCM_MAKINUM ((int) malloc_type[i].data),
 247                        res);
 248   return res;
 249 }
 250 #undef FUNC_NAME
 251
 252 void
 253 scm_debug_malloc_prehistory ()
 254 {
 255   malloc_type = malloc (sizeof (hash_entry_t)
 256                         * (malloc_type_size + N_SEEK));
 257   bzero (malloc_type, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
 258   malloc_object = malloc (sizeof (hash_entry_t)
 259                           * (malloc_object_size + N_SEEK));
 260   bzero (malloc_object, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
 261 }
 262
 263 void
 264 scm_init_debug_malloc ()
 265 {
 266 #include "libguile/debug-malloc.x"
 267 }