1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
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.
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.
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
30 extern unsigned long * __libc_ia64_register_backing_store_base
;
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"
49 #include "libguile/validate.h"
50 #include "libguile/deprecation.h"
51 #include "libguile/gc.h"
53 #include "libguile/private-gc.h"
55 #ifdef GUILE_DEBUG_MALLOC
56 #include "libguile/debug-malloc.h"
68 INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
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:
75 #define SCM_DEFAULT_INIT_MALLOC_LIMIT 200*1024
76 #define SCM_DEFAULT_MALLOC_MINYIELD 40
78 /* #define DEBUGINFO */
80 static int scm_i_minyield_malloc
;
83 scm_gc_init_malloc (void)
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
);
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;
96 scm_mtrigger
= SCM_DEFAULT_INIT_MALLOC_LIMIT
;
101 /* Function for non-cell memory management.
105 scm_realloc (void *mem
, size_t size
)
109 SCM_SYSCALL (ptr
= realloc (mem
, size
));
113 scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex
);
114 scm_gc_running_p
= 1;
116 scm_i_gc ("realloc");
119 We don't want these sweep statistics to influence results for
120 cell GC, so we don't collect statistics.
122 realloc () failed, so we're really desparate to free memory. Run a
125 scm_i_sweep_all_segments ("realloc", NULL
);
127 scm_gc_running_p
= 0;
128 scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex
);
130 SCM_SYSCALL (ptr
= realloc (mem
, size
));
134 scm_memory_error ("realloc");
138 scm_malloc (size_t sz
)
140 return scm_realloc (NULL
, sz
);
144 Hmm. Should we use the C convention for arguments (i.e. N_ELTS,
148 scm_calloc (size_t sz
)
153 By default, try to use calloc, as it is likely more efficient than
154 calling memset by hand.
156 SCM_SYSCALL (ptr
= calloc (sz
, 1));
160 ptr
= scm_realloc (NULL
, sz
);
161 memset (ptr
, 0x0, sz
);
167 scm_strndup (const char *str
, size_t n
)
169 char *dst
= scm_malloc (n
+ 1);
170 memcpy (dst
, str
, n
);
176 scm_strdup (const char *str
)
178 return scm_strndup (str
, strlen (str
));
182 decrease_mtrigger (size_t size
, const char * what
)
184 scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex
);
186 if (size
> scm_mallocated
)
188 fprintf (stderr
, "`scm_mallocated' underflow. This means that more "
189 "memory was unregistered\n"
190 "via `scm_gc_unregister_collectable_memory ()' than "
195 scm_mallocated
-= size
;
196 scm_gc_malloc_collected
+= size
;
197 scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex
);
201 increase_mtrigger (size_t size
, const char *what
)
203 size_t mallocated
= 0;
204 int overflow
= 0, triggered
= 0;
206 scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex
);
207 if (ULONG_MAX
- size
< scm_mallocated
)
211 scm_mallocated
+= size
;
212 mallocated
= scm_mallocated
;
213 if (scm_mallocated
> scm_mtrigger
)
216 scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex
);
219 scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
222 A program that uses a lot of malloced collectable memory (vectors,
223 strings), will use a lot of memory off the cell-heap; it needs to
224 do GC more often (before cells are exhausted), otherwise swapping
225 and malloc management will tie it down.
229 unsigned long prev_alloced
;
232 scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex
);
233 scm_gc_running_p
= 1;
235 prev_alloced
= mallocated
;
237 /* The GC will finish the pending sweep. For that reason, we
238 don't execute a complete sweep after GC, although that might
239 free some more memory.
243 yield
= (((float) prev_alloced
- (float) scm_mallocated
)
244 / (float) prev_alloced
);
246 scm_gc_malloc_yield_percentage
= (int) (100 * yield
);
249 fprintf (stderr
, "prev %lud , now %lud, yield %4.2lf, want %d",
253 scm_i_minyield_malloc
);
256 if (yield
< scm_i_minyield_malloc
/ 100.0)
259 We make the trigger a little larger, even; If you have a
260 program that builds up a lot of data in strings, then the
261 desired yield will never be satisfied.
263 Instead of getting bogged down, we let the mtrigger grow
266 float no_overflow_trigger
= scm_mallocated
* 110.0;
268 no_overflow_trigger
/= (float) (100.0 - scm_i_minyield_malloc
);
271 if (no_overflow_trigger
>= (float) ULONG_MAX
)
272 scm_mtrigger
= ULONG_MAX
;
274 scm_mtrigger
= (unsigned long) no_overflow_trigger
;
277 fprintf (stderr
, "Mtrigger sweep: ineffective. New trigger %d\n",
282 scm_gc_running_p
= 0;
283 scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex
);
288 scm_gc_register_collectable_memory (void *mem
, size_t size
, const char *what
)
290 increase_mtrigger (size
, what
);
291 #ifdef GUILE_DEBUG_MALLOC
293 scm_malloc_register (mem
, what
);
299 scm_gc_unregister_collectable_memory (void *mem
, size_t size
, const char *what
)
301 decrease_mtrigger (size
, what
);
302 #ifdef GUILE_DEBUG_MALLOC
304 scm_malloc_unregister (mem
);
309 scm_gc_malloc (size_t size
, const char *what
)
312 The straightforward implementation below has the problem
313 that it might call the GC twice, once in scm_malloc and then
314 again in scm_gc_register_collectable_memory. We don't really
315 want the second GC since it will not find new garbage.
317 Note: this is a theoretical peeve. In reality, malloc () never
318 returns NULL. Usually, memory is overcommitted, and when you try
319 to write it the program is killed with signal 11. --hwn
322 void *ptr
= size
? scm_malloc (size
) : NULL
;
323 scm_gc_register_collectable_memory (ptr
, size
, what
);
328 scm_gc_calloc (size_t size
, const char *what
)
330 void *ptr
= scm_gc_malloc (size
, what
);
331 memset (ptr
, 0x0, size
);
337 scm_gc_realloc (void *mem
, size_t old_size
, size_t new_size
, const char *what
)
341 /* XXX - see scm_gc_malloc. */
345 scm_realloc () may invalidate the block pointed to by WHERE, eg. by
346 unmapping it from memory or altering the contents. Since
347 increase_mtrigger () might trigger a GC that would scan
348 MEM, it is crucial that this call precedes realloc ().
351 decrease_mtrigger (old_size
, what
);
352 increase_mtrigger (new_size
, what
);
354 ptr
= scm_realloc (mem
, new_size
);
356 #ifdef GUILE_DEBUG_MALLOC
358 scm_malloc_reregister (mem
, ptr
, what
);
365 scm_gc_free (void *mem
, size_t size
, const char *what
)
367 scm_gc_unregister_collectable_memory (mem
, size
, what
);
373 scm_gc_strndup (const char *str
, size_t n
, const char *what
)
375 char *dst
= scm_gc_malloc (n
+1, what
);
376 memcpy (dst
, str
, n
);
382 scm_gc_strdup (const char *str
, const char *what
)
384 return scm_gc_strndup (str
, strlen (str
), what
);
387 #if SCM_ENABLE_DEPRECATED == 1
389 /* {Deprecated front end to malloc}
391 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
394 * These functions provide services comparable to malloc, realloc, and
395 * free. They should be used when allocating memory that will be under
396 * control of the garbage collector, i.e., if the memory may be freed
397 * during garbage collection.
399 * They are deprecated because they weren't really used the way
400 * outlined above, and making sure to return the right amount from
401 * smob free routines was sometimes difficult when dealing with nested
402 * data structures. We basically want everybody to review their code
403 * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
404 * instead. In some cases, where scm_must_malloc has been used
405 * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
409 scm_must_malloc (size_t size
, const char *what
)
411 scm_c_issue_deprecation_warning
412 ("scm_must_malloc is deprecated. "
413 "Use scm_gc_malloc and scm_gc_free instead.");
415 return scm_gc_malloc (size
, what
);
419 scm_must_realloc (void *where
,
424 scm_c_issue_deprecation_warning
425 ("scm_must_realloc is deprecated. "
426 "Use scm_gc_realloc and scm_gc_free instead.");
428 return scm_gc_realloc (where
, old_size
, size
, what
);
432 scm_must_strndup (const char *str
, size_t length
)
434 scm_c_issue_deprecation_warning
435 ("scm_must_strndup is deprecated. "
436 "Use scm_gc_strndup and scm_gc_free instead.");
438 return scm_gc_strndup (str
, length
, "string");
442 scm_must_strdup (const char *str
)
444 scm_c_issue_deprecation_warning
445 ("scm_must_strdup is deprecated. "
446 "Use scm_gc_strdup and scm_gc_free instead.");
448 return scm_gc_strdup (str
, "string");
452 scm_must_free (void *obj
)
453 #define FUNC_NAME "scm_must_free"
455 scm_c_issue_deprecation_warning
456 ("scm_must_free is deprecated. "
457 "Use scm_gc_malloc and scm_gc_free instead.");
459 #ifdef GUILE_DEBUG_MALLOC
460 scm_malloc_unregister (obj
);
466 fprintf (stderr
,"freeing NULL pointer");
474 scm_done_malloc (long size
)
476 scm_c_issue_deprecation_warning
477 ("scm_done_malloc is deprecated. "
478 "Use scm_gc_register_collectable_memory instead.");
481 scm_gc_register_collectable_memory (NULL
, size
, "foreign mallocs");
483 scm_gc_unregister_collectable_memory (NULL
, -size
, "foreign mallocs");
487 scm_done_free (long size
)
489 scm_c_issue_deprecation_warning
490 ("scm_done_free is deprecated. "
491 "Use scm_gc_unregister_collectable_memory instead.");
494 scm_gc_unregister_collectable_memory (NULL
, size
, "foreign mallocs");
496 scm_gc_register_collectable_memory (NULL
, -size
, "foreign mallocs");
499 #endif /* SCM_ENABLE_DEPRECATED == 1 */