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 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/unif.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   int 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 (mtrigger < 0)
  97     scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT;
  98   else
  99     scm_mtrigger = mtrigger;
 100 }
 101
 102
 103 \f
 104 /* Function for non-cell memory management.
 105  */
 106
 107 void *
 108 scm_realloc (void *mem, size_t size)
 109 {
 110   void *ptr;
 111
 112   SCM_SYSCALL (ptr = realloc (mem, size));
 113   if (ptr)
 114     return ptr;
 115
 116   scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 117   scm_gc_running_p = 1;
 118
 119   scm_i_gc ("realloc");
 120
 121   /*
 122    We don't want these sweep statistics to influence results for
 123    cell GC, so we don't collect statistics.
 124
 125    realloc () failed, so we're really desparate to free memory. Run a
 126    full sweep.
 127   */
 128   scm_i_sweep_all_segments ("realloc", NULL);
 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
 235       scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 236       scm_gc_running_p = 1;
 237
 238       prev_alloced = mallocated;
 239
 240       /* The GC will finish the pending sweep. For that reason, we
 241          don't execute a complete sweep after GC, although that might
 242          free some more memory.
 243       */
 244       scm_i_gc (what);
 245
 246       yield = (((float) prev_alloced - (float) scm_mallocated)
 247                / (float) prev_alloced);
 248
 249       scm_gc_malloc_yield_percentage = (int) (100 * yield);
 250
 251 #ifdef DEBUGINFO
 252       fprintf (stderr,  "prev %lud , now %lud, yield %4.2lf, want %d",
 253                prev_alloced,
 254                scm_mallocated,
 255                100.0 * yield,
 256                scm_i_minyield_malloc);
 257 #endif
 258
 259       if (yield < scm_i_minyield_malloc /  100.0)
 260         {
 261           /*
 262             We make the trigger a little larger, even; If you have a
 263             program that builds up a lot of data in strings, then the
 264             desired yield will never be satisfied.
 265
 266             Instead of getting bogged down, we let the mtrigger grow
 267             strongly with it.
 268            */
 269           float no_overflow_trigger = scm_mallocated * 110.0;
 270
 271           no_overflow_trigger /= (float)  (100.0 - scm_i_minyield_malloc);
 272
 273
 274           if (no_overflow_trigger >= (float) ULONG_MAX)
 275             scm_mtrigger = ULONG_MAX;
 276           else
 277             scm_mtrigger = (unsigned long) no_overflow_trigger;
 278
 279 #ifdef DEBUGINFO
 280           fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
 281                    scm_mtrigger);
 282 #endif
 283         }
 284
 285       scm_gc_running_p = 0;
 286       scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 287     }
 288 }
 289
 290 void
 291 scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
 292 {
 293   increase_mtrigger (size, what);
 294 #ifdef GUILE_DEBUG_MALLOC
 295   if (mem)
 296     scm_malloc_register (mem, what);
 297 #endif
 298 }
 299
 300
 301 void
 302 scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
 303 {
 304   decrease_mtrigger (size, what);
 305 #ifdef GUILE_DEBUG_MALLOC
 306   if (mem)
 307     scm_malloc_unregister (mem);
 308 #endif
 309 }
 310
 311 void *
 312 scm_gc_malloc (size_t size, const char *what)
 313 {
 314   /*
 315     The straightforward implementation below has the problem
 316      that it might call the GC twice, once in scm_malloc and then
 317      again in scm_gc_register_collectable_memory.  We don't really
 318      want the second GC since it will not find new garbage.
 319
 320      Note: this is a theoretical peeve. In reality, malloc () never
 321      returns NULL. Usually, memory is overcommitted, and when you try
 322      to write it the program is killed with signal 11. --hwn
 323   */
 324
 325   void *ptr = size ? scm_malloc (size) : NULL;
 326   scm_gc_register_collectable_memory (ptr, size, what);
 327   return ptr;
 328 }
 329
 330 void *
 331 scm_gc_calloc (size_t size, const char *what)
 332 {
 333   void *ptr = scm_gc_malloc (size, what);
 334   memset (ptr, 0x0, size);
 335   return ptr;
 336 }
 337
 338
 339 void *
 340 scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
 341 {
 342   void *ptr;
 343
 344   /* XXX - see scm_gc_malloc. */
 345
 346
 347   /*
 348   scm_realloc () may invalidate the block pointed to by WHERE, eg. by
 349   unmapping it from memory or altering the contents.  Since
 350   increase_mtrigger () might trigger a GC that would scan
 351   MEM, it is crucial that this call precedes realloc ().
 352   */
 353
 354   decrease_mtrigger (old_size, what);
 355   increase_mtrigger (new_size, what);
 356
 357   ptr = scm_realloc (mem, new_size);
 358
 359 #ifdef GUILE_DEBUG_MALLOC
 360   if (mem)
 361     scm_malloc_reregister (mem, ptr, what);
 362 #endif
 363
 364   return ptr;
 365 }
 366
 367 void
 368 scm_gc_free (void *mem, size_t size, const char *what)
 369 {
 370   scm_gc_unregister_collectable_memory (mem, size, what);
 371   if (mem)
 372     free (mem);
 373 }
 374
 375 char *
 376 scm_gc_strndup (const char *str, size_t n, const char *what)
 377 {
 378   char *dst = scm_gc_malloc (n+1, what);
 379   memcpy (dst, str, n);
 380   dst[n] = 0;
 381   return dst;
 382 }
 383
 384 char *
 385 scm_gc_strdup (const char *str, const char *what)
 386 {
 387   return scm_gc_strndup (str, strlen (str), what);
 388 }
 389
 390 #if SCM_ENABLE_DEPRECATED == 1
 391
 392 /* {Deprecated front end to malloc}
 393  *
 394  * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
 395  * scm_done_free
 396  *
 397  * These functions provide services comparable to malloc, realloc, and
 398  * free.  They should be used when allocating memory that will be under
 399  * control of the garbage collector, i.e., if the memory may be freed
 400  * during garbage collection.
 401  *
 402  * They are deprecated because they weren't really used the way
 403  * outlined above, and making sure to return the right amount from
 404  * smob free routines was sometimes difficult when dealing with nested
 405  * data structures.  We basically want everybody to review their code
 406  * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
 407  * instead.  In some cases, where scm_must_malloc has been used
 408  * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
 409  */
 410
 411 void *
 412 scm_must_malloc (size_t size, const char *what)
 413 {
 414   scm_c_issue_deprecation_warning
 415     ("scm_must_malloc is deprecated.  "
 416      "Use scm_gc_malloc and scm_gc_free instead.");
 417
 418   return scm_gc_malloc (size, what);
 419 }
 420
 421 void *
 422 scm_must_realloc (void *where,
 423                   size_t old_size,
 424                   size_t size,
 425                   const char *what)
 426 {
 427   scm_c_issue_deprecation_warning
 428     ("scm_must_realloc is deprecated.  "
 429      "Use scm_gc_realloc and scm_gc_free instead.");
 430
 431   return scm_gc_realloc (where, old_size, size, what);
 432 }
 433
 434 char *
 435 scm_must_strndup (const char *str, size_t length)
 436 {
 437   scm_c_issue_deprecation_warning
 438     ("scm_must_strndup is deprecated.  "
 439      "Use scm_gc_strndup and scm_gc_free instead.");
 440
 441   return scm_gc_strndup (str, length, "string");
 442 }
 443
 444 char *
 445 scm_must_strdup (const char *str)
 446 {
 447   scm_c_issue_deprecation_warning
 448     ("scm_must_strdup is deprecated.  "
 449      "Use scm_gc_strdup and scm_gc_free instead.");
 450
 451   return scm_gc_strdup (str, "string");
 452 }
 453
 454 void
 455 scm_must_free (void *obj)
 456 #define FUNC_NAME "scm_must_free"
 457 {
 458   scm_c_issue_deprecation_warning
 459     ("scm_must_free is deprecated.  "
 460      "Use scm_gc_malloc and scm_gc_free instead.");
 461
 462 #ifdef GUILE_DEBUG_MALLOC
 463   scm_malloc_unregister (obj);
 464 #endif
 465   if (obj)
 466     free (obj);
 467   else
 468     {
 469       fprintf (stderr,"freeing NULL pointer");
 470       abort ();
 471     }
 472 }
 473 #undef FUNC_NAME
 474
 475
 476 void
 477 scm_done_malloc (long size)
 478 {
 479   scm_c_issue_deprecation_warning
 480     ("scm_done_malloc is deprecated.  "
 481      "Use scm_gc_register_collectable_memory instead.");
 482
 483   if (size >= 0)
 484     scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
 485   else
 486     scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
 487 }
 488
 489 void
 490 scm_done_free (long size)
 491 {
 492   scm_c_issue_deprecation_warning
 493     ("scm_done_free is deprecated.  "
 494      "Use scm_gc_unregister_collectable_memory instead.");
 495
 496   if (size >= 0)
 497     scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
 498   else
 499     scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
 500 }
 501
 502 #endif /* SCM_ENABLE_DEPRECATED == 1 */