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 #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 = 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 */