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