libguile/gc-malloc.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 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
  19 \f
  20 #if HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25 #include <errno.h>
  26 #include <string.h>
  27
  28 #ifdef __ia64__
  29 #include <ucontext.h>
  30 extern unsigned long * __libc_ia64_register_backing_store_base;
  31 #endif
  32
  33 #include "libguile/_scm.h"
  34 #include "libguile/eval.h"
  35 #include "libguile/stime.h"
  36 #include "libguile/stackchk.h"
  37 #include "libguile/struct.h"
  38 #include "libguile/smob.h"
  39 #include "libguile/unif.h"
  40 #include "libguile/async.h"
  41 #include "libguile/ports.h"
  42 #include "libguile/root.h"
  43 #include "libguile/strings.h"
  44 #include "libguile/vectors.h"
  45 #include "libguile/weaks.h"
  46 #include "libguile/hashtab.h"
  47 #include "libguile/tags.h"
  48
  49 #include "libguile/validate.h"
  50 #include "libguile/deprecation.h"
  51 #include "libguile/gc.h"
  52
  53 #include "libguile/private-gc.h"
  54
  55 #ifdef GUILE_DEBUG_MALLOC
  56 #include "libguile/debug-malloc.h"
  57 #endif
  58
  59 #ifdef HAVE_MALLOC_H
  60 #include <malloc.h>
  61 #endif
  62
  63 #ifdef HAVE_UNISTD_H
  64 #include <unistd.h>
  65 #endif
  66
  67 /*
  68   INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
  69   trigger a GC.
  70
  71   After startup (at the guile> prompt), we have approximately 100k of
  72   alloced memory, which won't go away on GC. Let's set the init such
  73   that we get a nice yield on the next allocation:
  74 */
  75 #define SCM_DEFAULT_INIT_MALLOC_LIMIT 200*1024
  76 #define SCM_DEFAULT_MALLOC_MINYIELD 40
  77
  78 /* #define DEBUGINFO */
  79
  80 static int scm_i_minyield_malloc;
  81
  82 void
  83 scm_gc_init_malloc (void)
  84 {
  85   scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
  86                                  SCM_DEFAULT_INIT_MALLOC_LIMIT);
  87   scm_i_minyield_malloc =  scm_getenv_int ("GUILE_MIN_YIELD_MALLOC",
  88                                            SCM_DEFAULT_MALLOC_MINYIELD);
  89
  90   if (scm_i_minyield_malloc >= 100)
  91     scm_i_minyield_malloc = 99;
  92   if (scm_i_minyield_malloc < 1)
  93     scm_i_minyield_malloc = 1;
  94
  95   if (scm_mtrigger < 0)
  96     scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT;
  97 }
  98
  99
 100 \f
 101 /* Function for non-cell memory management.
 102  */
 103
 104 void *
 105 scm_realloc (void *mem, size_t size)
 106 {
 107   void *ptr;
 108   scm_t_sweep_statistics sweep_stats;
 109
 110   SCM_SYSCALL (ptr = realloc (mem, size));
 111   if (ptr)
 112     return ptr;
 113
 114   scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 115   scm_gc_running_p = 1;
 116
 117   scm_i_sweep_all_segments ("realloc", &sweep_stats);
 118
 119   SCM_SYSCALL (ptr = realloc (mem, size));
 120   if (ptr)
 121     {
 122       scm_gc_running_p = 0;
 123       scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 124       return ptr;
 125     }
 126
 127   scm_i_gc ("realloc");
 128   scm_i_sweep_all_segments ("realloc", &sweep_stats);
 129
 130   scm_gc_running_p = 0;
 131   scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 132
 133   SCM_SYSCALL (ptr = realloc (mem, size));
 134   if (ptr)
 135     return ptr;
 136
 137   scm_memory_error ("realloc");
 138 }
 139
 140 void *
 141 scm_malloc (size_t sz)
 142 {
 143   return scm_realloc (NULL, sz);
 144 }
 145
 146 /*
 147   Hmm. Should we use the C convention for arguments (i.e. N_ELTS,
 148   SIZEOF_ELT)? --hwn
 149  */
 150 void *
 151 scm_calloc (size_t sz)
 152 {
 153   void * ptr;
 154
 155   /*
 156     By default, try to use calloc, as it is likely more efficient than
 157     calling memset by hand.
 158    */
 159   SCM_SYSCALL (ptr = calloc (sz, 1));
 160   if (ptr)
 161     return ptr;
 162
 163   ptr = scm_realloc (NULL, sz);
 164   memset (ptr, 0x0, sz);
 165   return ptr;
 166 }
 167
 168
 169 char *
 170 scm_strndup (const char *str, size_t n)
 171 {
 172   char *dst = scm_malloc (n + 1);
 173   memcpy (dst, str, n);
 174   dst[n] = 0;
 175   return dst;
 176 }
 177
 178 char *
 179 scm_strdup (const char *str)
 180 {
 181   return scm_strndup (str, strlen (str));
 182 }
 183
 184 static void
 185 decrease_mtrigger (size_t size, const char * what)
 186 {
 187   scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
 188
 189   if (size > scm_mallocated)
 190     {
 191       fprintf (stderr, "`scm_mallocated' underflow.  This means that more "
 192                "memory was unregistered\n"
 193                "via `scm_gc_unregister_collectable_memory ()' than "
 194                "registered.\n");
 195       abort ();
 196     }
 197
 198   scm_mallocated -= size;
 199   scm_gc_malloc_collected += size;
 200   scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
 201 }
 202
 203 static void
 204 increase_mtrigger (size_t size, const char *what)
 205 {
 206   size_t mallocated = 0;
 207   int overflow = 0, triggered = 0;
 208
 209   scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
 210   if (ULONG_MAX - size < scm_mallocated)
 211     overflow = 1;
 212   else
 213     {
 214       scm_mallocated += size;
 215       mallocated = scm_mallocated;
 216       if (scm_mallocated > scm_mtrigger)
 217         triggered = 1;
 218     }
 219   scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
 220
 221   if (overflow)
 222     scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
 223
 224   /*
 225     A program that uses a lot of malloced collectable memory (vectors,
 226     strings), will use a lot of memory off the cell-heap; it needs to
 227     do GC more often (before cells are exhausted), otherwise swapping
 228     and malloc management will tie it down.
 229    */
 230   if (triggered)
 231     {
 232       unsigned long prev_alloced;
 233       float yield;
 234       scm_t_sweep_statistics sweep_stats;
 235
 236       scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 237       scm_gc_running_p = 1;
 238
 239       prev_alloced  = mallocated;
 240       scm_i_gc (what);
 241       scm_i_sweep_all_segments ("mtrigger", &sweep_stats);
 242
 243       yield = (((float) prev_alloced - (float) scm_mallocated)
 244                / (float) prev_alloced);
 245
 246       scm_gc_malloc_yield_percentage = (int) (100  * yield);
 247
 248 #ifdef DEBUGINFO
 249       fprintf (stderr,  "prev %lud , now %lud, yield %4.2lf, want %d",
 250                prev_alloced,
 251                scm_mallocated,
 252                100.0 * yield,
 253                scm_i_minyield_malloc);
 254 #endif
 255
 256       if (yield < scm_i_minyield_malloc /  100.0)
 257         {
 258           /*
 259             We make the trigger a little larger, even; If you have a
 260             program that builds up a lot of data in strings, then the
 261             desired yield will never be satisfied.
 262
 263             Instead of getting bogged down, we let the mtrigger grow
 264             strongly with it.
 265            */
 266           float no_overflow_trigger = scm_mallocated * 110.0;
 267
 268           no_overflow_trigger /= (float)  (100.0 - scm_i_minyield_malloc);
 269
 270
 271           if (no_overflow_trigger >= (float) ULONG_MAX)
 272             scm_mtrigger = ULONG_MAX;
 273           else
 274             scm_mtrigger =  (unsigned long) no_overflow_trigger;
 275
 276 #ifdef DEBUGINFO
 277           fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
 278                    scm_mtrigger);
 279 #endif
 280         }
 281
 282       scm_gc_running_p = 0;
 283       scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 284     }
 285 }
 286
 287 void
 288 scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
 289 {
 290   increase_mtrigger (size, what);
 291 #ifdef GUILE_DEBUG_MALLOC
 292   if (mem)
 293     scm_malloc_register (mem, what);
 294 #endif
 295 }
 296
 297
 298 void
 299 scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
 300 {
 301   decrease_mtrigger (size, what);
 302 #ifdef GUILE_DEBUG_MALLOC
 303   if (mem)
 304     scm_malloc_unregister (mem);
 305 #endif
 306 }
 307
 308 void *
 309 scm_gc_malloc (size_t size, const char *what)
 310 {
 311   /*
 312     The straightforward implementation below has the problem
 313      that it might call the GC twice, once in scm_malloc and then
 314      again in scm_gc_register_collectable_memory.  We don't really
 315      want the second GC since it will not find new garbage.
 316
 317      Note: this is a theoretical peeve. In reality, malloc() never
 318      returns NULL. Usually, memory is overcommitted, and when you try
 319      to write it the program is killed with signal 11. --hwn
 320   */
 321
 322   void *ptr = scm_malloc (size);
 323   scm_gc_register_collectable_memory (ptr, size, what);
 324   return ptr;
 325 }
 326
 327 void *
 328 scm_gc_calloc (size_t size, const char *what)
 329 {
 330   void *ptr = scm_gc_malloc (size, what);
 331   memset (ptr, 0x0, size);
 332   return ptr;
 333 }
 334
 335
 336 void *
 337 scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
 338 {
 339   void *ptr;
 340
 341   /* XXX - see scm_gc_malloc. */
 342
 343
 344   /*
 345   scm_realloc() may invalidate the block pointed to by WHERE, eg. by
 346   unmapping it from memory or altering the contents.  Since
 347   increase_mtrigger() might trigger a GC that would scan
 348   MEM, it is crucial that this call precedes realloc().
 349   */
 350
 351   decrease_mtrigger (old_size, what);
 352   increase_mtrigger (new_size, what);
 353
 354   ptr = scm_realloc (mem, new_size);
 355
 356 #ifdef GUILE_DEBUG_MALLOC
 357   if (mem)
 358     scm_malloc_reregister (mem, ptr, what);
 359 #endif
 360
 361   return ptr;
 362 }
 363
 364 void
 365 scm_gc_free (void *mem, size_t size, const char *what)
 366 {
 367   scm_gc_unregister_collectable_memory (mem, size, what);
 368   free (mem);
 369 }
 370
 371 char *
 372 scm_gc_strndup (const char *str, size_t n, const char *what)
 373 {
 374   char *dst = scm_gc_malloc (n+1, what);
 375   memcpy (dst, str, n);
 376   dst[n] = 0;
 377   return dst;
 378 }
 379
 380 char *
 381 scm_gc_strdup (const char *str, const char *what)
 382 {
 383   return scm_gc_strndup (str, strlen (str), what);
 384 }
 385
 386 #if SCM_ENABLE_DEPRECATED == 1
 387
 388 /* {Deprecated front end to malloc}
 389  *
 390  * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
 391  * scm_done_free
 392  *
 393  * These functions provide services comparable to malloc, realloc, and
 394  * free.  They should be used when allocating memory that will be under
 395  * control of the garbage collector, i.e., if the memory may be freed
 396  * during garbage collection.
 397  *
 398  * They are deprecated because they weren't really used the way
 399  * outlined above, and making sure to return the right amount from
 400  * smob free routines was sometimes difficult when dealing with nested
 401  * data structures.  We basically want everybody to review their code
 402  * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
 403  * instead.  In some cases, where scm_must_malloc has been used
 404  * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
 405  */
 406
 407 void *
 408 scm_must_malloc (size_t size, const char *what)
 409 {
 410   scm_c_issue_deprecation_warning
 411     ("scm_must_malloc is deprecated.  "
 412      "Use scm_gc_malloc and scm_gc_free instead.");
 413
 414   return scm_gc_malloc (size, what);
 415 }
 416
 417 void *
 418 scm_must_realloc (void *where,
 419                   size_t old_size,
 420                   size_t size,
 421                   const char *what)
 422 {
 423   scm_c_issue_deprecation_warning
 424     ("scm_must_realloc is deprecated.  "
 425      "Use scm_gc_realloc and scm_gc_free instead.");
 426
 427   return scm_gc_realloc (where, old_size, size, what);
 428 }
 429
 430 char *
 431 scm_must_strndup (const char *str, size_t length)
 432 {
 433   scm_c_issue_deprecation_warning
 434     ("scm_must_strndup is deprecated.  "
 435      "Use scm_gc_strndup and scm_gc_free instead.");
 436
 437   return scm_gc_strndup (str, length, "string");
 438 }
 439
 440 char *
 441 scm_must_strdup (const char *str)
 442 {
 443   scm_c_issue_deprecation_warning
 444     ("scm_must_strdup is deprecated.  "
 445      "Use scm_gc_strdup and scm_gc_free instead.");
 446
 447   return scm_gc_strdup (str, "string");
 448 }
 449
 450 void
 451 scm_must_free (void *obj)
 452 #define FUNC_NAME "scm_must_free"
 453 {
 454   scm_c_issue_deprecation_warning
 455     ("scm_must_free is deprecated.  "
 456      "Use scm_gc_malloc and scm_gc_free instead.");
 457
 458 #ifdef GUILE_DEBUG_MALLOC
 459   scm_malloc_unregister (obj);
 460 #endif
 461   if (obj)
 462     free (obj);
 463   else
 464     {
 465       fprintf (stderr,"freeing NULL pointer");
 466       abort ();
 467     }
 468 }
 469 #undef FUNC_NAME
 470
 471
 472 void
 473 scm_done_malloc (long size)
 474 {
 475   scm_c_issue_deprecation_warning
 476     ("scm_done_malloc is deprecated.  "
 477      "Use scm_gc_register_collectable_memory instead.");
 478
 479   if (size >= 0)
 480     scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
 481   else
 482     scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
 483 }
 484
 485 void
 486 scm_done_free (long size)
 487 {
 488   scm_c_issue_deprecation_warning
 489     ("scm_done_free is deprecated.  "
 490      "Use scm_gc_unregister_collectable_memory instead.");
 491
 492   if (size >= 0)
 493     scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
 494   else
 495     scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
 496 }
 497
 498 #endif /* SCM_ENABLE_DEPRECATED == 1 */