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