libguile/gc-malloc.c

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