libguile/gc-malloc.c

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