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
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 <stdlib.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
scm_gc_init_malloc(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
101 /* Function for non-cell memory management.
102 */
103
104 void *
scm_realloc(void * mem,size_t size)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 *
scm_malloc(size_t sz)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 *
scm_calloc(size_t sz)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 *
scm_strndup(const char * str,size_t n)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 *
scm_strdup(const char * str)178 scm_strdup (const char *str)
179 {
180 return scm_strndup (str, strlen (str));
181 }
182
183 static void
decrease_mtrigger(size_t size,const char * what)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
increase_mtrigger(size_t size,const char * what)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
scm_gc_register_collectable_memory(void * mem,size_t size,const char * what)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
scm_gc_unregister_collectable_memory(void * mem,size_t size,const char * what)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 *
scm_gc_malloc(size_t size,const char * what)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 *
scm_gc_calloc(size_t size,const char * what)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 *
scm_gc_realloc(void * mem,size_t old_size,size_t new_size,const char * what)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
scm_gc_free(void * mem,size_t size,const char * what)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 *
scm_gc_strndup(const char * str,size_t n,const char * what)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 *
scm_gc_strdup(const char * str,const char * what)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 *
scm_must_malloc(size_t size,const char * what)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 *
scm_must_realloc(void * where,size_t old_size,size_t size,const char * what)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 *
scm_must_strndup(const char * str,size_t length)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 *
scm_must_strdup(const char * str)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
scm_must_free(void * obj)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
scm_done_malloc(long size)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
scm_done_free(long size)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 */
498