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