Set $GC_MARKERS to 1 when libgc 7.4.0 is used.
[bpt/guile.git] / libguile / gc.c
CommitLineData
0f595d7d 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006,
0320b1fc 2 * 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
a00c95d9 3 *
73be1d9e 4 * This library is free software; you can redistribute it and/or
53befeb7
NJ
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
a00c95d9 8 *
53befeb7
NJ
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
a00c95d9 13 *
73be1d9e
MV
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
53befeb7
NJ
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
73be1d9e 18 */
1bbd0b84 19
37ddcaf6
MD
20/* #define DEBUGINFO */
21
dbb605f5 22#ifdef HAVE_CONFIG_H
aa54a9b0
RB
23# include <config.h>
24#endif
56495472 25
e7bca227
LC
26#include "libguile/gen-scmconfig.h"
27
0f2d19dd 28#include <stdio.h>
e6e2e95a 29#include <errno.h>
783e7774 30#include <string.h>
34cf38c3 31#include <stdlib.h>
6360beb2 32#include <math.h>
e6e2e95a 33
3ec17f28
LC
34#ifdef __ia64__
35#include <ucontext.h>
36extern unsigned long * __libc_ia64_register_backing_store_base;
37#endif
38
a0599745 39#include "libguile/_scm.h"
0a7a7445 40#include "libguile/eval.h"
a0599745
MD
41#include "libguile/stime.h"
42#include "libguile/stackchk.h"
43#include "libguile/struct.h"
a0599745 44#include "libguile/smob.h"
2fa901a5 45#include "libguile/arrays.h"
a0599745
MD
46#include "libguile/async.h"
47#include "libguile/ports.h"
48#include "libguile/root.h"
87fc4596 49#include "libguile/simpos.h"
a0599745
MD
50#include "libguile/strings.h"
51#include "libguile/vectors.h"
686765af 52#include "libguile/hashtab.h"
ecf470a2 53#include "libguile/tags.h"
a0599745
MD
54
55#include "libguile/validate.h"
1be6b49c 56#include "libguile/deprecation.h"
a0599745 57#include "libguile/gc.h"
9de87eea 58#include "libguile/dynwind.h"
fce59c93 59
1c44468d 60#include "libguile/bdw-gc.h"
a82e7953 61
cc3546b0
AW
62/* For GC_set_start_callback. */
63#include <gc/gc_mark.h>
64
bc9d9bb2 65#ifdef GUILE_DEBUG_MALLOC
a0599745 66#include "libguile/debug-malloc.h"
bc9d9bb2
MD
67#endif
68
0f2d19dd 69#ifdef HAVE_UNISTD_H
95b88819 70#include <unistd.h>
0f2d19dd
JB
71#endif
72
064d2409
AW
73/* Size in bytes of the initial heap. This should be about the size of
74 result of 'guile -c "(display (assq-ref (gc-stats)
75 'heap-total-allocated))"'. */
76
77#define DEFAULT_INITIAL_HEAP_SIZE (128 * 1024 * SIZEOF_SCM_T_BITS)
78
eae33935 79/* Set this to != 0 if every cell that is accessed shall be checked:
61045190 80 */
eab1b259
HWN
81int scm_debug_cell_accesses_p = 0;
82int scm_expensive_debug_cell_accesses_p = 0;
406c7d90 83
e81d98ec
DH
84/* Set this to 0 if no additional gc's shall be performed, otherwise set it to
85 * the number of cell accesses after which a gc shall be called.
86 */
eab1b259 87int scm_debug_cells_gc_interval = 0;
e81d98ec 88
acbccb0c 89/* Hash table that keeps a reference to objects the user wants to protect from
fbe1cb7f
AW
90 garbage collection. */
91static SCM scm_protects;
e7efe8e7
AW
92
93
eab1b259
HWN
94#if (SCM_DEBUG_CELL_ACCESSES == 1)
95
96
97/*
98
99 Assert that the given object is a valid reference to a valid cell. This
100 test involves to determine whether the object is a cell pointer, whether
101 this pointer actually points into a heap segment and whether the cell
102 pointed to is not a free cell. Further, additional garbage collections may
103 get executed after a user defined number of cell accesses. This helps to
104 find places in the C code where references are dropped for extremely short
105 periods.
106
107*/
406c7d90 108void
eab1b259 109scm_i_expensive_validation_check (SCM cell)
406c7d90 110{
eab1b259
HWN
111 /* If desired, perform additional garbage collections after a user
112 * defined number of cell accesses.
113 */
114 if (scm_debug_cells_gc_interval)
115 {
116 static unsigned int counter = 0;
61045190 117
eab1b259
HWN
118 if (counter != 0)
119 {
120 --counter;
121 }
122 else
123 {
124 counter = scm_debug_cells_gc_interval;
b17e0ac3 125 scm_gc ();
eab1b259
HWN
126 }
127 }
128}
129
8c93b597
LC
130/* Whether cell validation is already running. */
131static int scm_i_cell_validation_already_running = 0;
132
eab1b259
HWN
133void
134scm_assert_cell_valid (SCM cell)
135{
136 if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
406c7d90 137 {
eab1b259 138 scm_i_cell_validation_already_running = 1; /* set to avoid recursion */
406c7d90 139
c8a1bdc4 140 /*
eab1b259
HWN
141 During GC, no user-code should be run, and the guile core
142 should use non-protected accessors.
143 */
c8a1bdc4 144 if (scm_gc_running_p)
eab1b259 145 return;
c8a1bdc4
HWN
146
147 /*
eab1b259
HWN
148 Only scm_in_heap_p and rescanning the heap is wildly
149 expensive.
150 */
151 if (scm_expensive_debug_cell_accesses_p)
152 scm_i_expensive_validation_check (cell);
b4246e5b 153
eab1b259 154 scm_i_cell_validation_already_running = 0; /* re-enable */
406c7d90
DH
155 }
156}
157
158
eab1b259 159
406c7d90
DH
160SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
161 (SCM flag),
1e6808ea 162 "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
eab1b259 163 "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
e81d98ec 164 "but no additional calls to garbage collection are issued.\n"
eab1b259 165 "If @var{flag} is a number, strict cell access checking is enabled,\n"
e81d98ec
DH
166 "with an additional garbage collection after the given\n"
167 "number of cell accesses.\n"
1e6808ea
MG
168 "This procedure only exists when the compile-time flag\n"
169 "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
406c7d90
DH
170#define FUNC_NAME s_scm_set_debug_cell_accesses_x
171{
7888309b 172 if (scm_is_false (flag))
eab1b259
HWN
173 {
174 scm_debug_cell_accesses_p = 0;
175 }
bc36d050 176 else if (scm_is_eq (flag, SCM_BOOL_T))
eab1b259
HWN
177 {
178 scm_debug_cells_gc_interval = 0;
179 scm_debug_cell_accesses_p = 1;
180 scm_expensive_debug_cell_accesses_p = 0;
181 }
e11e83f3 182 else
eab1b259 183 {
e11e83f3 184 scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX);
eab1b259
HWN
185 scm_debug_cell_accesses_p = 1;
186 scm_expensive_debug_cell_accesses_p = 1;
187 }
406c7d90
DH
188 return SCM_UNSPECIFIED;
189}
190#undef FUNC_NAME
0f2d19dd 191
ecf470a2 192
c8a1bdc4 193#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
0f2d19dd 194
c2247b78
AW
195
196\f
197
198static int needs_gc_after_nonlocal_exit = 0;
199
200/* Arrange to throw an exception on failed allocations. */
201static void*
202scm_oom_fn (size_t nbytes)
203{
204 needs_gc_after_nonlocal_exit = 1;
205 scm_report_out_of_memory ();
206 return NULL;
207}
208
209/* Called within GC -- cannot allocate GC memory. */
210static void
211scm_gc_warn_proc (char *fmt, GC_word arg)
212{
213 SCM port;
214 FILE *stream = NULL;
215
216 port = scm_current_warning_port ();
217 if (!SCM_OPPORTP (port))
218 return;
219
220 if (SCM_FPORTP (port))
221 {
222 int fd;
223 scm_force_output (port);
224 if (!SCM_OPPORTP (port))
225 return;
226 fd = dup (SCM_FPORT_FDES (port));
227 if (fd == -1)
228 perror ("Failed to dup warning port fd");
229 else
230 {
231 stream = fdopen (fd, "a");
232 if (!stream)
233 {
234 perror ("Failed to open stream for warning port");
235 close (fd);
236 }
237 }
238 }
239
240 fprintf (stream ? stream : stderr, fmt, arg);
241
242 if (stream)
243 fclose (stream);
244}
245
246void
247scm_gc_after_nonlocal_exit (void)
248{
249 if (needs_gc_after_nonlocal_exit)
250 {
251 needs_gc_after_nonlocal_exit = 0;
252 GC_gcollect_and_unmap ();
253 }
254}
255
256
0f2d19dd 257\f
14294ce0 258
26224b3f
LC
259/* Hooks. */
260scm_t_c_hook scm_before_gc_c_hook;
261scm_t_c_hook scm_before_mark_c_hook;
262scm_t_c_hook scm_before_sweep_c_hook;
263scm_t_c_hook scm_after_sweep_c_hook;
264scm_t_c_hook scm_after_gc_c_hook;
945fec60 265
0f2d19dd 266
0fbdbe6c
AW
267static void
268run_before_gc_c_hook (void)
269{
e1fbe716
AW
270 if (!SCM_I_CURRENT_THREAD)
271 /* GC while a thread is spinning up; punt. */
272 return;
273
0fbdbe6c
AW
274 scm_c_hook_run (&scm_before_gc_c_hook, NULL);
275}
276
277
0f2d19dd
JB
278/* GC Statistics Keeping
279 */
b74e86cf 280unsigned long scm_gc_ports_collected = 0;
00b6ef23
AW
281static long gc_time_taken = 0;
282static long gc_start_time = 0;
283
6360beb2
AW
284static unsigned long free_space_divisor;
285static unsigned long minimum_free_space_divisor;
286static double target_free_space_divisor;
b74e86cf 287
915b3f9f 288static unsigned long protected_obj_count = 0;
c2cbcc57 289
0f2d19dd 290
17ab1dc3 291SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
915b3f9f
LC
292SCM_SYMBOL (sym_heap_size, "heap-size");
293SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
294SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
17ab1dc3 295SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc");
7eec4c37 296SCM_SYMBOL (sym_protected_objects, "protected-objects");
17ab1dc3 297SCM_SYMBOL (sym_times, "gc-times");
cf2d30f6 298
d3dd80ab 299
0f2d19dd
JB
300/* {Scheme Interface to GC}
301 */
c2cbcc57 302extern int scm_gc_malloc_yield_percentage;
a00c95d9 303SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
1bbd0b84 304 (),
1e6808ea 305 "Return an association list of statistics about Guile's current\n"
c8a1bdc4 306 "use of storage.\n")
1bbd0b84 307#define FUNC_NAME s_scm_gc_stats
0f2d19dd 308{
0f2d19dd 309 SCM answer;
14294ce0 310 GC_word heap_size, free_bytes, unmapped_bytes, bytes_since_gc, total_bytes;
915b3f9f 311 size_t gc_times;
4c9419ac 312
14294ce0
AW
313 GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
314 &bytes_since_gc, &total_bytes);
0f595d7d 315 gc_times = GC_get_gc_no ();
fca43887 316
b9bd8526 317 answer =
00b6ef23 318 scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
915b3f9f
LC
319 scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
320 scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
321 scm_cons (sym_heap_total_allocated,
322 scm_from_size_t (total_bytes)),
17ab1dc3
AW
323 scm_cons (sym_heap_allocated_since_gc,
324 scm_from_size_t (bytes_since_gc)),
915b3f9f
LC
325 scm_cons (sym_protected_objects,
326 scm_from_ulong (protected_obj_count)),
327 scm_cons (sym_times, scm_from_size_t (gc_times)),
b9bd8526 328 SCM_UNDEFINED);
fca43887 329
c8a1bdc4 330 return answer;
0f2d19dd 331}
c8a1bdc4 332#undef FUNC_NAME
0f2d19dd 333
539b08a4 334
7f9ec18a
LC
335SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0,
336 (void),
337 "Dump information about the garbage collector's internal data "
338 "structures and memory usage to the standard output.")
339#define FUNC_NAME s_scm_gc_dump
340{
341 GC_dump ();
342
343 return SCM_UNSPECIFIED;
344}
345#undef FUNC_NAME
346
acf4331f 347
c8a1bdc4
HWN
348SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
349 (SCM obj),
350 "Return an integer that for the lifetime of @var{obj} is uniquely\n"
351 "returned by this function for @var{obj}")
352#define FUNC_NAME s_scm_object_address
c68296f8 353{
b9bd8526 354 return scm_from_ulong (SCM_UNPACK (obj));
c68296f8 355}
c8a1bdc4 356#undef FUNC_NAME
c68296f8 357
1be6b49c 358
915b3f9f
LC
359SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
360 (),
361 "Disables the garbage collector. Nested calls are permitted. "
362 "GC is re-enabled once @code{gc-enable} has been called the "
363 "same number of times @code{gc-disable} was called.")
364#define FUNC_NAME s_scm_gc_disable
365{
366 GC_disable ();
367 return SCM_UNSPECIFIED;
368}
369#undef FUNC_NAME
370
371SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
372 (),
373 "Enables the garbage collector.")
374#define FUNC_NAME s_scm_gc_enable
375{
376 GC_enable ();
377 return SCM_UNSPECIFIED;
378}
379#undef FUNC_NAME
380
381
c8a1bdc4
HWN
382SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
383 (),
384 "Scans all of SCM objects and reclaims for further use those that are\n"
385 "no longer accessible.")
386#define FUNC_NAME s_scm_gc
387{
b17e0ac3 388 scm_i_gc ("call");
f740445a
AW
389 /* If you're calling scm_gc(), you probably want synchronous
390 finalization. */
eaf99988 391 GC_invoke_finalizers ();
c8a1bdc4 392 return SCM_UNSPECIFIED;
9d47a1e6 393}
c8a1bdc4 394#undef FUNC_NAME
9d47a1e6 395
c8a1bdc4 396void
b17e0ac3 397scm_i_gc (const char *what)
c8a1bdc4 398{
26224b3f 399 GC_gcollect ();
eab1b259 400}
0f2d19dd 401
4c7016dc 402
0f2d19dd
JB
403\f
404/* {GC Protection Helper Functions}
405 */
406
407
5d2b97cd
DH
408/*
409 * If within a function you need to protect one or more scheme objects from
410 * garbage collection, pass them as parameters to one of the
411 * scm_remember_upto_here* functions below. These functions don't do
412 * anything, but since the compiler does not know that they are actually
413 * no-ops, it will generate code that calls these functions with the given
414 * parameters. Therefore, you can be sure that the compiler will keep those
415 * scheme values alive (on the stack or in a register) up to the point where
416 * scm_remember_upto_here* is called. In other words, place the call to
592996c9 417 * scm_remember_upto_here* _behind_ the last code in your function, that
5d2b97cd
DH
418 * depends on the scheme object to exist.
419 *
8c494e99
DH
420 * Example: We want to make sure that the string object str does not get
421 * garbage collected during the execution of 'some_function' in the code
422 * below, because otherwise the characters belonging to str would be freed and
5d2b97cd
DH
423 * 'some_function' might access freed memory. To make sure that the compiler
424 * keeps str alive on the stack or in a register such that it is visible to
425 * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
426 * call to 'some_function'. Note that this would not be necessary if str was
427 * used anyway after the call to 'some_function'.
eb01cb64 428 * char *chars = scm_i_string_chars (str);
5d2b97cd
DH
429 * some_function (chars);
430 * scm_remember_upto_here_1 (str); // str will be alive up to this point.
431 */
432
9e1569bd
KR
433/* Remove any macro versions of these while defining the functions.
434 Functions are always included in the library, for upward binary
435 compatibility and in case combinations of GCC and non-GCC are used. */
436#undef scm_remember_upto_here_1
437#undef scm_remember_upto_here_2
438
5d2b97cd 439void
e81d98ec 440scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
5d2b97cd
DH
441{
442 /* Empty. Protects a single object from garbage collection. */
443}
444
445void
e81d98ec 446scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
5d2b97cd
DH
447{
448 /* Empty. Protects two objects from garbage collection. */
449}
450
451void
e81d98ec 452scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
5d2b97cd
DH
453{
454 /* Empty. Protects any number of objects from garbage collection. */
455}
456
c209c88e 457/*
41b0806d
GB
458 These crazy functions prevent garbage collection
459 of arguments after the first argument by
460 ensuring they remain live throughout the
461 function because they are used in the last
462 line of the code block.
463 It'd be better to have a nice compiler hint to
464 aid the conservative stack-scanning GC. --03/09/00 gjb */
0f2d19dd
JB
465SCM
466scm_return_first (SCM elt, ...)
0f2d19dd
JB
467{
468 return elt;
469}
470
41b0806d
GB
471int
472scm_return_first_int (int i, ...)
473{
474 return i;
475}
476
0f2d19dd 477
0f2d19dd 478SCM
6e8d25a6 479scm_permanent_object (SCM obj)
0f2d19dd 480{
8e7b3e98 481 return (scm_gc_protect_object (obj));
0f2d19dd
JB
482}
483
484
7bd4fbe2
MD
485/* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
486 other references are dropped, until the object is unprotected by calling
6b1b030e 487 scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest,
7bd4fbe2
MD
488 i. e. it is possible to protect the same object several times, but it is
489 necessary to unprotect the object the same number of times to actually get
490 the object unprotected. It is an error to unprotect an object more often
491 than it has been protected before. The function scm_protect_object returns
492 OBJ.
493*/
494
495/* Implementation note: For every object X, there is a counter which
1f584400 496 scm_gc_protect_object (X) increments and scm_gc_unprotect_object (X) decrements.
7bd4fbe2 497*/
686765af 498
7eec4c37
HWN
499
500
ef290276 501SCM
6b1b030e 502scm_gc_protect_object (SCM obj)
ef290276 503{
686765af 504 SCM handle;
9d47a1e6 505
686765af 506 /* This critical section barrier will be replaced by a mutex. */
33b320ae
NJ
507 /* njrev: Indeed; if my comment above is correct, there is the same
508 critsec/mutex inconsistency here. */
9de87eea 509 SCM_CRITICAL_SECTION_START;
9d47a1e6 510
acbccb0c 511 handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
e11e83f3 512 SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
9d47a1e6 513
7eec4c37
HWN
514 protected_obj_count ++;
515
9de87eea 516 SCM_CRITICAL_SECTION_END;
9d47a1e6 517
ef290276
JB
518 return obj;
519}
520
521
522/* Remove any protection for OBJ established by a prior call to
dab7f566 523 scm_protect_object. This function returns OBJ.
ef290276 524
dab7f566 525 See scm_protect_object for more information. */
ef290276 526SCM
6b1b030e 527scm_gc_unprotect_object (SCM obj)
ef290276 528{
686765af 529 SCM handle;
9d47a1e6 530
686765af 531 /* This critical section barrier will be replaced by a mutex. */
33b320ae 532 /* njrev: and again. */
9de87eea 533 SCM_CRITICAL_SECTION_START;
9d47a1e6 534
0ff7e3ff
HWN
535 if (scm_gc_running_p)
536 {
537 fprintf (stderr, "scm_unprotect_object called during GC.\n");
538 abort ();
539 }
b17e0ac3 540
acbccb0c 541 handle = scm_hashq_get_handle (scm_protects, obj);
9d47a1e6 542
7888309b 543 if (scm_is_false (handle))
686765af 544 {
0f0f0899
MD
545 fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
546 abort ();
686765af 547 }
6a199940
DH
548 else
549 {
e11e83f3 550 SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
bc36d050 551 if (scm_is_eq (count, scm_from_int (0)))
acbccb0c 552 scm_hashq_remove_x (scm_protects, obj);
6a199940 553 else
1be6b49c 554 SCM_SETCDR (handle, count);
6a199940 555 }
7eec4c37 556 protected_obj_count --;
686765af 557
9de87eea 558 SCM_CRITICAL_SECTION_END;
ef290276
JB
559
560 return obj;
561}
562
6b1b030e
ML
563void
564scm_gc_register_root (SCM *p)
565{
8e7b3e98 566 /* Nothing. */
6b1b030e
ML
567}
568
569void
570scm_gc_unregister_root (SCM *p)
571{
8e7b3e98 572 /* Nothing. */
6b1b030e
ML
573}
574
575void
576scm_gc_register_roots (SCM *b, unsigned long n)
577{
578 SCM *p = b;
579 for (; p < b + n; ++p)
580 scm_gc_register_root (p);
581}
582
583void
584scm_gc_unregister_roots (SCM *b, unsigned long n)
585{
586 SCM *p = b;
587 for (; p < b + n; ++p)
588 scm_gc_unregister_root (p);
589}
590
0f2d19dd 591\f
a00c95d9 592
4c48ba06 593
c35738c1
MD
594void
595scm_storage_prehistory ()
596{
0f595d7d 597 GC_set_all_interior_pointers (0);
0f595d7d 598
6360beb2
AW
599 free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
600 minimum_free_space_divisor = free_space_divisor;
601 target_free_space_divisor = free_space_divisor;
602 GC_set_free_space_divisor (free_space_divisor);
eaf99988 603 GC_set_finalize_on_demand (1);
184327a6 604
3f69e638
LC
605#if (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR == 4 \
606 && GC_ALPHA_VERSION == 0)
607 /* BDW-GC 7.4.0 has a bug making it loop indefinitely when using more
608 than one marker thread: <https://github.com/ivmai/bdwgc/pull/30>.
609 Work around it by asking for one marker thread. */
610 setenv ("GC_MARKERS", "1", 1);
611#endif
612
a82e7953 613 GC_INIT ();
e7bca227 614
064d2409 615 GC_expand_hp (DEFAULT_INITIAL_HEAP_SIZE);
915b3f9f 616
184327a6
LC
617 /* We only need to register a displacement for those types for which the
618 higher bits of the type tag are used to store a pointer (that is, a
619 pointer to an 8-octet aligned region). For `scm_tc3_struct', this is
620 handled in `scm_alloc_struct ()'. */
621 GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
314b8716 622 /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
184327a6 623
915b3f9f 624 /* Sanity check. */
acbccb0c 625 if (!GC_is_visible (&scm_protects))
915b3f9f 626 abort ();
a82e7953 627
c35738c1
MD
628 scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
629 scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
630 scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
631 scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
632 scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
633}
85db4a2c 634
9de87eea 635scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
eb01cb64 636
562cd1b8
AW
637void
638scm_init_gc_protect_object ()
0f2d19dd 639{
acbccb0c 640 scm_protects = scm_c_make_hash_table (31);
4a4c9785 641
9de87eea
MV
642#if 0
643 /* We can't have a cleanup handler since we have no thread to run it
644 in. */
645
a18bcd0e 646#ifdef HAVE_ATEXIT
c45acc34 647 atexit (cleanup);
e52ceaac
MD
648#else
649#ifdef HAVE_ON_EXIT
650 on_exit (cleanup, 0);
651#endif
9de87eea
MV
652#endif
653
a18bcd0e 654#endif
0f2d19dd 655}
939794ce 656
0f2d19dd
JB
657\f
658
939794ce
DH
659SCM scm_after_gc_hook;
660
cc3546b0 661static SCM after_gc_async_cell;
939794ce 662
cc3546b0
AW
663/* The function after_gc_async_thunk causes the execution of the
664 * after-gc-hook. It is run after the gc, as soon as the asynchronous
665 * events are handled by the evaluator.
939794ce
DH
666 */
667static SCM
cc3546b0 668after_gc_async_thunk (void)
939794ce 669{
cc3546b0
AW
670 /* Fun, no? Hook-run *and* run-hook? */
671 scm_c_hook_run (&scm_after_gc_c_hook, NULL);
939794ce 672 scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
939794ce
DH
673 return SCM_UNSPECIFIED;
674}
675
676
cc3546b0
AW
677/* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
678 * at the end of the garbage collection. The only purpose of this
679 * function is to mark the after_gc_async (which will eventually lead to
680 * the execution of the after_gc_async_thunk).
939794ce
DH
681 */
682static void *
cc3546b0
AW
683queue_after_gc_hook (void * hook_data SCM_UNUSED,
684 void *fn_data SCM_UNUSED,
685 void *data SCM_UNUSED)
e81d98ec
DH
686{
687 /* If cell access debugging is enabled, the user may choose to perform
688 * additional garbage collections after an arbitrary number of cell
689 * accesses. We don't want the scheme level after-gc-hook to be performed
690 * for each of these garbage collections for the following reason: The
691 * execution of the after-gc-hook causes cell accesses itself. Thus, if the
692 * after-gc-hook was performed with every gc, and if the gc was performed
693 * after a very small number of cell accesses, then the number of cell
694 * accesses during the execution of the after-gc-hook will suffice to cause
695 * the execution of the next gc. Then, guile would keep executing the
696 * after-gc-hook over and over again, and would never come to do other
697 * things.
eae33935 698 *
e81d98ec
DH
699 * To overcome this problem, if cell access debugging with additional
700 * garbage collections is enabled, the after-gc-hook is never run by the
701 * garbage collecter. When running guile with cell access debugging and the
702 * execution of the after-gc-hook is desired, then it is necessary to run
703 * the hook explicitly from the user code. This has the effect, that from
704 * the scheme level point of view it seems that garbage collection is
705 * performed with a much lower frequency than it actually is. Obviously,
706 * this will not work for code that depends on a fixed one to one
707 * relationship between the execution counts of the C level garbage
708 * collection hooks and the execution count of the scheme level
709 * after-gc-hook.
710 */
9de87eea 711
e81d98ec 712#if (SCM_DEBUG_CELL_ACCESSES == 1)
eab1b259 713 if (scm_debug_cells_gc_interval == 0)
e81d98ec 714#endif
cc3546b0
AW
715 {
716 scm_i_thread *t = SCM_I_CURRENT_THREAD;
717
718 if (scm_is_false (SCM_CDR (after_gc_async_cell)))
719 {
720 SCM_SETCDR (after_gc_async_cell, t->active_asyncs);
721 t->active_asyncs = after_gc_async_cell;
722 t->pending_asyncs = 1;
723 }
724 }
e81d98ec 725
939794ce
DH
726 return NULL;
727}
728
00b6ef23
AW
729\f
730
731static void *
732start_gc_timer (void * hook_data SCM_UNUSED,
733 void *fn_data SCM_UNUSED,
734 void *data SCM_UNUSED)
735{
736 if (!gc_start_time)
737 gc_start_time = scm_c_get_internal_run_time ();
738
739 return NULL;
740}
741
742static void *
743accumulate_gc_timer (void * hook_data SCM_UNUSED,
744 void *fn_data SCM_UNUSED,
745 void *data SCM_UNUSED)
746{
747 if (gc_start_time)
6360beb2
AW
748 {
749 long now = scm_c_get_internal_run_time ();
00b6ef23
AW
750 gc_time_taken += now - gc_start_time;
751 gc_start_time = 0;
752 }
753
754 return NULL;
755}
756
553294d9 757static size_t bytes_until_gc = DEFAULT_INITIAL_HEAP_SIZE;
fd51e661
AW
758static scm_i_pthread_mutex_t bytes_until_gc_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
759
fd51e661
AW
760void
761scm_gc_register_allocation (size_t size)
762{
763 scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
764 if (bytes_until_gc - size > bytes_until_gc)
765 {
766 bytes_until_gc = GC_get_heap_size ();
767 scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
768 GC_gcollect ();
769 }
770 else
771 {
772 bytes_until_gc -= size;
773 scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
774 }
775}
776
00b6ef23
AW
777
778\f
0f2d19dd
JB
779void
780scm_init_gc ()
0f2d19dd 781{
a82e7953 782 /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'. */
d678e25c 783
f39448c5 784 scm_after_gc_hook = scm_make_hook (SCM_INUM0);
fde50407 785 scm_c_define ("after-gc-hook", scm_after_gc_hook);
939794ce 786
cc3546b0
AW
787 /* When the async is to run, the cdr of the gc_async pair gets set to
788 the asyncs queue of the current thread. */
789 after_gc_async_cell = scm_cons (scm_c_make_gsubr ("%after-gc-thunk", 0, 0, 0,
790 after_gc_async_thunk),
791 SCM_BOOL_F);
939794ce 792
cc3546b0 793 scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
00b6ef23
AW
794 scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
795 scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
66b229d5 796
c2247b78
AW
797 GC_set_oom_fn (scm_oom_fn);
798 GC_set_warn_proc (scm_gc_warn_proc);
cc3546b0 799 GC_set_start_callback (run_before_gc_c_hook);
939794ce 800
a0599745 801#include "libguile/gc.x"
0f2d19dd 802}
89e00824 803
c8a1bdc4
HWN
804
805void
806scm_gc_sweep (void)
807#define FUNC_NAME "scm_gc_sweep"
808{
26224b3f 809 /* FIXME */
cd169c5a 810 fprintf (stderr, "%s: doing nothing\n", FUNC_NAME);
c8a1bdc4 811}
c8a1bdc4
HWN
812#undef FUNC_NAME
813
89e00824
ML
814/*
815 Local Variables:
816 c-file-style: "gnu"
817 End:
818*/