libguile/gc-malloc.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 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
 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_sweep_all_segments ("realloc");
 117
 118   SCM_SYSCALL (ptr = realloc (mem, size));
 119   if (ptr)
 120     {
 121       scm_gc_running_p = 0;
 122       scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 123       return ptr;
 124     }
 125
 126   scm_i_gc ("realloc");
 127   scm_i_sweep_all_segments ("realloc");
 128
 129   scm_gc_running_p = 0;
 130   scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 131
 132   SCM_SYSCALL (ptr = realloc (mem, size));
 133   if (ptr)
 134     return ptr;
 135
 136   scm_memory_error ("realloc");
 137 }
 138
 139 void *
 140 scm_malloc (size_t sz)
 141 {
 142   return scm_realloc (NULL, sz);
 143 }
 144
 145 /*
 146   Hmm. Should we use the C convention for arguments (i.e. N_ELTS,
 147   SIZEOF_ELT)? --hwn
 148  */
 149 void *
 150 scm_calloc (size_t sz)
 151 {
 152   void * ptr;
 153
 154   /*
 155     By default, try to use calloc, as it is likely more efficient than
 156     calling memset by hand.
 157    */
 158   SCM_SYSCALL (ptr = calloc (sz, 1));
 159   if (ptr)
 160     return ptr;
 161
 162   ptr = scm_realloc (NULL, sz);
 163   memset (ptr, 0x0, sz);
 164   return ptr;
 165 }
 166
 167
 168 char *
 169 scm_strndup (const char *str, size_t n)
 170 {
 171   char *dst = scm_malloc (n + 1);
 172   memcpy (dst, str, n);
 173   dst[n] = 0;
 174   return dst;
 175 }
 176
 177 char *
 178 scm_strdup (const char *str)
 179 {
 180   return scm_strndup (str, strlen (str));
 181 }
 182
 183 static void
 184 decrease_mtrigger (size_t size, const char * what)
 185 {
 186   scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
 187   scm_mallocated -= size;
 188   scm_gc_malloc_collected += size;
 189   scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
 190 }
 191
 192 static void
 193 increase_mtrigger (size_t size, const char *what)
 194 {
 195   size_t mallocated = 0;
 196   int overflow = 0, triggered = 0;
 197
 198   scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
 199   if (ULONG_MAX - size < scm_mallocated)
 200     overflow = 1;
 201   else
 202     {
 203       scm_mallocated += size;
 204       mallocated = scm_mallocated;
 205       if (scm_mallocated > scm_mtrigger)
 206         triggered = 1;
 207     }
 208   scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
 209
 210   if (overflow)
 211     scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
 212
 213   /*
 214     A program that uses a lot of malloced collectable memory (vectors,
 215     strings), will use a lot of memory off the cell-heap; it needs to
 216     do GC more often (before cells are exhausted), otherwise swapping
 217     and malloc management will tie it down.
 218    */
 219   if (triggered)
 220     {
 221       unsigned long prev_alloced;
 222       float yield;
 223
 224       scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
 225       scm_gc_running_p = 1;
 226
 227       prev_alloced  = mallocated;
 228       scm_i_gc (what);
 229       scm_i_sweep_all_segments ("mtrigger");
 230
 231       yield = (((float) prev_alloced - (float) scm_mallocated)
 232                / (float) prev_alloced);
 233
 234       scm_gc_malloc_yield_percentage = (int) (100  * yield);
 235
 236 #ifdef DEBUGINFO
 237       fprintf (stderr,  "prev %lud , now %lud, yield %4.2lf, want %d",
 238                prev_alloced,
 239                scm_mallocated,
 240                100.0 * yield,
 241                scm_i_minyield_malloc);
 242 #endif
 243
 244       if (yield < scm_i_minyield_malloc /  100.0)
 245         {
 246           /*
 247             We make the trigger a little larger, even; If you have a
 248             program that builds up a lot of data in strings, then the
 249             desired yield will never be satisfied.
 250
 251             Instead of getting bogged down, we let the mtrigger grow
 252             strongly with it.
 253            */
 254           float no_overflow_trigger = scm_mallocated * 110.0;
 255
 256           no_overflow_trigger /= (float)  (100.0 - scm_i_minyield_malloc);
 257
 258
 259           if (no_overflow_trigger >= (float) ULONG_MAX)
 260             scm_mtrigger = ULONG_MAX;
 261           else
 262             scm_mtrigger =  (unsigned long) no_overflow_trigger;
 263
 264 #ifdef DEBUGINFO
 265           fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
 266                    scm_mtrigger);
 267 #endif
 268         }
 269
 270       scm_gc_running_p = 0;
 271       scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
 272     }
 273 }
 274
 275 void
 276 scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
 277 {
 278   increase_mtrigger (size, what);
 279 #ifdef GUILE_DEBUG_MALLOC
 280   if (mem)
 281     scm_malloc_register (mem, what);
 282 #endif
 283 }
 284
 285
 286 void
 287 scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
 288 {
 289   decrease_mtrigger (size, what);
 290 #ifdef GUILE_DEBUG_MALLOC
 291   if (mem)
 292     scm_malloc_unregister (mem);
 293 #endif
 294 }
 295
 296 void *
 297 scm_gc_malloc (size_t size, const char *what)
 298 {
 299   /*
 300     The straightforward implementation below has the problem
 301      that it might call the GC twice, once in scm_malloc and then
 302      again in scm_gc_register_collectable_memory.  We don't really
 303      want the second GC since it will not find new garbage.
 304
 305      Note: this is a theoretical peeve. In reality, malloc() never
 306      returns NULL. Usually, memory is overcommitted, and when you try
 307      to write it the program is killed with signal 11. --hwn
 308   */
 309
 310   void *ptr = scm_malloc (size);
 311   scm_gc_register_collectable_memory (ptr, size, what);
 312   return ptr;
 313 }
 314
 315 void *
 316 scm_gc_calloc (size_t size, const char *what)
 317 {
 318   void *ptr = scm_gc_malloc (size, what);
 319   memset (ptr, 0x0, size);
 320   return ptr;
 321 }
 322
 323
 324 void *
 325 scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
 326 {
 327   void *ptr;
 328
 329   /* XXX - see scm_gc_malloc. */
 330
 331
 332   /*
 333   scm_realloc() may invalidate the block pointed to by WHERE, eg. by
 334   unmapping it from memory or altering the contents.  Since
 335   increase_mtrigger() might trigger a GC that would scan
 336   MEM, it is crucial that this call precedes realloc().
 337   */
 338
 339   decrease_mtrigger (old_size, what);
 340   increase_mtrigger (new_size, what);
 341
 342   ptr = scm_realloc (mem, new_size);
 343
 344 #ifdef GUILE_DEBUG_MALLOC
 345   if (mem)
 346     scm_malloc_reregister (mem, ptr, what);
 347 #endif
 348
 349   return ptr;
 350 }
 351
 352 void
 353 scm_gc_free (void *mem, size_t size, const char *what)
 354 {
 355   scm_gc_unregister_collectable_memory (mem, size, what);
 356   free (mem);
 357 }
 358
 359 char *
 360 scm_gc_strndup (const char *str, size_t n, const char *what)
 361 {
 362   char *dst = scm_gc_malloc (n+1, what);
 363   memcpy (dst, str, n);
 364   dst[n] = 0;
 365   return dst;
 366 }
 367
 368 char *
 369 scm_gc_strdup (const char *str, const char *what)
 370 {
 371   return scm_gc_strndup (str, strlen (str), what);
 372 }
 373
 374 #if SCM_ENABLE_DEPRECATED == 1
 375
 376 /* {Deprecated front end to malloc}
 377  *
 378  * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
 379  * scm_done_free
 380  *
 381  * These functions provide services comparable to malloc, realloc, and
 382  * free.  They should be used when allocating memory that will be under
 383  * control of the garbage collector, i.e., if the memory may be freed
 384  * during garbage collection.
 385  *
 386  * They are deprecated because they weren't really used the way
 387  * outlined above, and making sure to return the right amount from
 388  * smob free routines was sometimes difficult when dealing with nested
 389  * data structures.  We basically want everybody to review their code
 390  * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
 391  * instead.  In some cases, where scm_must_malloc has been used
 392  * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
 393  */
 394
 395 void *
 396 scm_must_malloc (size_t size, const char *what)
 397 {
 398   scm_c_issue_deprecation_warning
 399     ("scm_must_malloc is deprecated.  "
 400      "Use scm_gc_malloc and scm_gc_free instead.");
 401
 402   return scm_gc_malloc (size, what);
 403 }
 404
 405 void *
 406 scm_must_realloc (void *where,
 407                   size_t old_size,
 408                   size_t size,
 409                   const char *what)
 410 {
 411   scm_c_issue_deprecation_warning
 412     ("scm_must_realloc is deprecated.  "
 413      "Use scm_gc_realloc and scm_gc_free instead.");
 414
 415   return scm_gc_realloc (where, old_size, size, what);
 416 }
 417
 418 char *
 419 scm_must_strndup (const char *str, size_t length)
 420 {
 421   scm_c_issue_deprecation_warning
 422     ("scm_must_strndup is deprecated.  "
 423      "Use scm_gc_strndup and scm_gc_free instead.");
 424
 425   return scm_gc_strndup (str, length, "string");
 426 }
 427
 428 char *
 429 scm_must_strdup (const char *str)
 430 {
 431   scm_c_issue_deprecation_warning
 432     ("scm_must_strdup is deprecated.  "
 433      "Use scm_gc_strdup and scm_gc_free instead.");
 434
 435   return scm_gc_strdup (str, "string");
 436 }
 437
 438 void
 439 scm_must_free (void *obj)
 440 #define FUNC_NAME "scm_must_free"
 441 {
 442   scm_c_issue_deprecation_warning
 443     ("scm_must_free is deprecated.  "
 444      "Use scm_gc_malloc and scm_gc_free instead.");
 445
 446 #ifdef GUILE_DEBUG_MALLOC
 447   scm_malloc_unregister (obj);
 448 #endif
 449   if (obj)
 450     free (obj);
 451   else
 452     {
 453       fprintf (stderr,"freeing NULL pointer");
 454       abort ();
 455     }
 456 }
 457 #undef FUNC_NAME
 458
 459
 460 void
 461 scm_done_malloc (long size)
 462 {
 463   scm_c_issue_deprecation_warning
 464     ("scm_done_malloc is deprecated.  "
 465      "Use scm_gc_register_collectable_memory instead.");
 466
 467   if (size >= 0)
 468     scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
 469   else
 470     scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
 471 }
 472
 473 void
 474 scm_done_free (long size)
 475 {
 476   scm_c_issue_deprecation_warning
 477     ("scm_done_free is deprecated.  "
 478      "Use scm_gc_unregister_collectable_memory instead.");
 479
 480   if (size >= 0)
 481     scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
 482   else
 483     scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
 484 }
 485
 486 #endif /* SCM_ENABLE_DEPRECATED == 1 */