libguile/gc-malloc.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 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
  19 \f
  20 #ifdef 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
 109   SCM_SYSCALL (ptr = realloc (mem, size));
 110   if (ptr)
 111     return ptr;
 112
 113   scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 114   scm_gc_running_p = 1;
 115
 116   scm_i_gc ("realloc");
 117
 118   /*
 119    We don't want these sweep statistics to influence results for
 120    cell GC, so we don't collect statistics.
 121
 122    realloc () failed, so we're really desparate to free memory. Run a
 123    full sweep.
 124   */
 125   scm_i_sweep_all_segments ("realloc", NULL);
 126
 127   scm_gc_running_p = 0;
 128   scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 129
 130   SCM_SYSCALL (ptr = realloc (mem, size));
 131   if (ptr)
 132     return ptr;
 133
 134   scm_memory_error ("realloc");
 135 }
 136
 137 void *
 138 scm_malloc (size_t sz)
 139 {
 140   return scm_realloc (NULL, sz);
 141 }
 142
 143 /*
 144   Hmm. Should we use the C convention for arguments (i.e. N_ELTS,
 145   SIZEOF_ELT)? --hwn
 146  */
 147 void *
 148 scm_calloc (size_t sz)
 149 {
 150   void * ptr;
 151
 152   /*
 153     By default, try to use calloc, as it is likely more efficient than
 154     calling memset by hand.
 155    */
 156   SCM_SYSCALL (ptr = calloc (sz, 1));
 157   if (ptr)
 158     return ptr;
 159
 160   ptr = scm_realloc (NULL, sz);
 161   memset (ptr, 0x0, sz);
 162   return ptr;
 163 }
 164
 165
 166 char *
 167 scm_strndup (const char *str, size_t n)
 168 {
 169   char *dst = scm_malloc (n + 1);
 170   memcpy (dst, str, n);
 171   dst[n] = 0;
 172   return dst;
 173 }
 174
 175 char *
 176 scm_strdup (const char *str)
 177 {
 178   return scm_strndup (str, strlen (str));
 179 }
 180
 181 static void
 182 decrease_mtrigger (size_t size, const char * what)
 183 {
 184   scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
 185
 186   if (size > scm_mallocated)
 187     {
 188       fprintf (stderr, "`scm_mallocated' underflow.  This means that more "
 189                "memory was unregistered\n"
 190                "via `scm_gc_unregister_collectable_memory ()' than "
 191                "registered.\n");
 192       abort ();
 193     }
 194
 195   scm_mallocated -= size;
 196   scm_gc_malloc_collected += size;
 197   scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
 198 }
 199
 200 static void
 201 increase_mtrigger (size_t size, const char *what)
 202 {
 203   size_t mallocated = 0;
 204   int overflow = 0, triggered = 0;
 205
 206   scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
 207   if (ULONG_MAX - size < scm_mallocated)
 208     overflow = 1;
 209   else
 210     {
 211       scm_mallocated += size;
 212       mallocated = scm_mallocated;
 213       if (scm_mallocated > scm_mtrigger)
 214         triggered = 1;
 215     }
 216   scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
 217
 218   if (overflow)
 219     scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
 220
 221   /*
 222     A program that uses a lot of malloced collectable memory (vectors,
 223     strings), will use a lot of memory off the cell-heap; it needs to
 224     do GC more often (before cells are exhausted), otherwise swapping
 225     and malloc management will tie it down.
 226    */
 227   if (triggered)
 228     {
 229       unsigned long prev_alloced;
 230       float yield;
 231
 232       scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 233       scm_gc_running_p = 1;
 234
 235       prev_alloced = mallocated;
 236
 237       /* The GC will finish the pending sweep. For that reason, we
 238          don't execute a complete sweep after GC, although that might
 239          free some more memory.
 240       */
 241       scm_i_gc (what);
 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 = size ? scm_malloc (size) : NULL;
 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   if (mem)
 369     free (mem);
 370 }
 371
 372 char *
 373 scm_gc_strndup (const char *str, size_t n, const char *what)
 374 {
 375   char *dst = scm_gc_malloc (n+1, what);
 376   memcpy (dst, str, n);
 377   dst[n] = 0;
 378   return dst;
 379 }
 380
 381 char *
 382 scm_gc_strdup (const char *str, const char *what)
 383 {
 384   return scm_gc_strndup (str, strlen (str), what);
 385 }
 386
 387 #if SCM_ENABLE_DEPRECATED == 1
 388
 389 /* {Deprecated front end to malloc}
 390  *
 391  * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
 392  * scm_done_free
 393  *
 394  * These functions provide services comparable to malloc, realloc, and
 395  * free.  They should be used when allocating memory that will be under
 396  * control of the garbage collector, i.e., if the memory may be freed
 397  * during garbage collection.
 398  *
 399  * They are deprecated because they weren't really used the way
 400  * outlined above, and making sure to return the right amount from
 401  * smob free routines was sometimes difficult when dealing with nested
 402  * data structures.  We basically want everybody to review their code
 403  * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
 404  * instead.  In some cases, where scm_must_malloc has been used
 405  * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
 406  */
 407
 408 void *
 409 scm_must_malloc (size_t size, const char *what)
 410 {
 411   scm_c_issue_deprecation_warning
 412     ("scm_must_malloc is deprecated.  "
 413      "Use scm_gc_malloc and scm_gc_free instead.");
 414
 415   return scm_gc_malloc (size, what);
 416 }
 417
 418 void *
 419 scm_must_realloc (void *where,
 420                   size_t old_size,
 421                   size_t size,
 422                   const char *what)
 423 {
 424   scm_c_issue_deprecation_warning
 425     ("scm_must_realloc is deprecated.  "
 426      "Use scm_gc_realloc and scm_gc_free instead.");
 427
 428   return scm_gc_realloc (where, old_size, size, what);
 429 }
 430
 431 char *
 432 scm_must_strndup (const char *str, size_t length)
 433 {
 434   scm_c_issue_deprecation_warning
 435     ("scm_must_strndup is deprecated.  "
 436      "Use scm_gc_strndup and scm_gc_free instead.");
 437
 438   return scm_gc_strndup (str, length, "string");
 439 }
 440
 441 char *
 442 scm_must_strdup (const char *str)
 443 {
 444   scm_c_issue_deprecation_warning
 445     ("scm_must_strdup is deprecated.  "
 446      "Use scm_gc_strdup and scm_gc_free instead.");
 447
 448   return scm_gc_strdup (str, "string");
 449 }
 450
 451 void
 452 scm_must_free (void *obj)
 453 #define FUNC_NAME "scm_must_free"
 454 {
 455   scm_c_issue_deprecation_warning
 456     ("scm_must_free is deprecated.  "
 457      "Use scm_gc_malloc and scm_gc_free instead.");
 458
 459 #ifdef GUILE_DEBUG_MALLOC
 460   scm_malloc_unregister (obj);
 461 #endif
 462   if (obj)
 463     free (obj);
 464   else
 465     {
 466       fprintf (stderr,"freeing NULL pointer");
 467       abort ();
 468     }
 469 }
 470 #undef FUNC_NAME
 471
 472
 473 void
 474 scm_done_malloc (long size)
 475 {
 476   scm_c_issue_deprecation_warning
 477     ("scm_done_malloc is deprecated.  "
 478      "Use scm_gc_register_collectable_memory instead.");
 479
 480   if (size >= 0)
 481     scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
 482   else
 483     scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
 484 }
 485
 486 void
 487 scm_done_free (long size)
 488 {
 489   scm_c_issue_deprecation_warning
 490     ("scm_done_free is deprecated.  "
 491      "Use scm_gc_unregister_collectable_memory instead.");
 492
 493   if (size >= 0)
 494     scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
 495   else
 496     scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
 497 }
 498
 499 #endif /* SCM_ENABLE_DEPRECATED == 1 */