mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 04:15:36 +02:00
Remove SMOB mark functions
Oh yeah! They are almost impossible to use correctly as-is, have mostly disappeared in practice (I am aware of only two users), have the wrong interface for moving collectors, and current usage has cemented smobs as conservatively-marked objects. In order to move forward with Whippet, they have to go! * libguile/deprecated.h (SCM_SMOB_MARK, SCM_GLOBAL_SMOB_MARK, scm_mark0) (scm_markcdr, scm_free0, scm_set_smob_mark, scm_gc_mark): Remove these, leaving defines to indicate that users should talk to guile-devel to figure out what to do. * libguile/smob.h: Remove interfaces relating to mark functions. (scm_new_double_smob, scm_new_smob): Make not inline * libguile/smob.c: Remove mark functions from here. (scm_new_smob): Out-of-line-only definition. (scm_smob_prehistory): Don't create a new GC kind for smobs. * test-suite/standalone/test-smob-mark-race.c: * test-suite/standalone/test-smob-mark.c: Remove. * test-suite/standalone/Makefile.am: Update.
This commit is contained in:
Andy Wingo
parent
2bfc66554e
commit
0e8c6b6727
6 changed files with 26 additions and 457 deletions
|
|
@ -24,6 +24,14 @@
|
|||
|
||||
#if (SCM_ENABLE_DEPRECATED == 1)
|
||||
|
||||
#define SCM_SMOB_MARK SCM_SMOB_MARK__Gone__Contact_guile_devel_for_alternatives
|
||||
#define SCM_GLOBAL_SMOB_MARK SCM_GLOBAL_SMOB_MARK__Gone__Contact_guile_devel_for_alternatives
|
||||
#define scm_mark0 scm_mark0__Gone__Contact_guile_devel_for_alternatives
|
||||
#define scm_markcdr scm_markcdr__Gone__Contact_guile_devel_for_alternatives
|
||||
#define scm_free0 scm_free0__Gone__Contact_guile_devel_for_alternatives
|
||||
#define scm_set_smob_mark scm_set_smob_mark__Gone__Contact_guile_devel_for_alternatives
|
||||
#define scm_gc_mark scm_gc_mark__Gone__Contact_guile_devel_for_alternatives
|
||||
|
||||
SCM_DEPRECATED SCM scm_make_guardian (void);
|
||||
|
||||
#define SCM_I_WVECTP(x) (scm_is_weak_vector (x))
|
||||
|
|
|
|||
201
libguile/smob.c
201
libguile/smob.c
|
|
@ -41,8 +41,6 @@
|
|||
|
||||
#include "smob.h"
|
||||
|
||||
#include <gc/gc_mark.h>
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -64,43 +62,6 @@ scm_assert_smob_type (scm_t_bits tag, SCM val)
|
|||
scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
|
||||
}
|
||||
|
||||
/* {Mark}
|
||||
*/
|
||||
|
||||
/* This function is vestigial. It used to be the mark function's
|
||||
responsibility to set the mark bit on the smob or port, but now the
|
||||
generic marking routine in gc.c takes care of that, and a zero
|
||||
pointer for a mark function means "don't bother". So you never
|
||||
need scm_mark0.
|
||||
|
||||
However, we leave it here because it's harmless to call it, and
|
||||
people out there have smob code that uses it, and there's no reason
|
||||
to make their links fail. */
|
||||
|
||||
SCM
|
||||
scm_mark0 (SCM ptr SCM_UNUSED)
|
||||
{
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
SCM
|
||||
/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
|
||||
be used for real pairs. */
|
||||
scm_markcdr (SCM ptr)
|
||||
{
|
||||
return SCM_CELL_OBJECT_1 (ptr);
|
||||
}
|
||||
|
||||
|
||||
/* {Free}
|
||||
*/
|
||||
|
||||
size_t
|
||||
scm_free0 (SCM ptr SCM_UNUSED)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* {Print}
|
||||
*/
|
||||
|
|
@ -230,12 +191,6 @@ scm_make_smob_type (char const *name, size_t size)
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
void
|
||||
scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
|
||||
{
|
||||
|
|
@ -280,101 +235,6 @@ scm_make_smob (scm_t_bits tc)
|
|||
}
|
||||
|
||||
|
||||
|
||||
/* Marking SMOBs using user-supplied mark procedures. */
|
||||
|
||||
|
||||
/* The GC kind used for SMOB types that provide a custom mark procedure. */
|
||||
static int smob_gc_kind;
|
||||
|
||||
/* Mark stack pointer and limit, used by `scm_gc_mark'. */
|
||||
static scm_i_pthread_key_t current_mark_stack_pointer;
|
||||
static scm_i_pthread_key_t current_mark_stack_limit;
|
||||
|
||||
|
||||
/* The generic SMOB mark procedure that gets called for SMOBs allocated
|
||||
with smob_gc_kind. */
|
||||
static struct GC_ms_entry *
|
||||
smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
|
||||
struct GC_ms_entry *mark_stack_limit, GC_word env)
|
||||
{
|
||||
register SCM cell;
|
||||
register scm_t_bits tc, smobnum;
|
||||
|
||||
cell = SCM_PACK_POINTER (addr);
|
||||
|
||||
if (SCM_TYP7 (cell) != scm_tc7_smob)
|
||||
/* It is likely that the GC passed us a pointer to a free-list element
|
||||
which we must ignore (see warning in `gc/gc_mark.h'). */
|
||||
return mark_stack_ptr;
|
||||
|
||||
tc = SCM_CELL_WORD_0 (cell);
|
||||
smobnum = SCM_TC2SMOBNUM (tc);
|
||||
|
||||
if (smobnum >= scm_numsmob)
|
||||
/* The first word looks corrupt. */
|
||||
abort ();
|
||||
|
||||
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
|
||||
mark_stack_ptr,
|
||||
mark_stack_limit, NULL);
|
||||
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
|
||||
mark_stack_ptr,
|
||||
mark_stack_limit, NULL);
|
||||
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
|
||||
mark_stack_ptr,
|
||||
mark_stack_limit, NULL);
|
||||
|
||||
if (scm_smobs[smobnum].mark)
|
||||
{
|
||||
SCM obj;
|
||||
|
||||
scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
|
||||
scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
|
||||
|
||||
/* Invoke the SMOB's mark procedure, which will in turn invoke
|
||||
`scm_gc_mark', which may modify `current_mark_stack_pointer'. */
|
||||
obj = scm_smobs[smobnum].mark (cell);
|
||||
|
||||
mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
|
||||
|
||||
if (SCM_HEAP_OBJECT_P (obj))
|
||||
/* Mark the returned object. */
|
||||
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
|
||||
mark_stack_ptr,
|
||||
mark_stack_limit, NULL);
|
||||
|
||||
scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
|
||||
scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
|
||||
}
|
||||
|
||||
return mark_stack_ptr;
|
||||
|
||||
}
|
||||
|
||||
/* Mark object O. We assume that this function is only called during the mark
|
||||
phase, i.e., from within `smob_mark' or one of its descendants. */
|
||||
void
|
||||
scm_gc_mark (SCM o)
|
||||
{
|
||||
if (SCM_HEAP_OBJECT_P (o))
|
||||
{
|
||||
void *mark_stack_ptr, *mark_stack_limit;
|
||||
|
||||
mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
|
||||
mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
|
||||
|
||||
if (mark_stack_ptr == NULL)
|
||||
/* The function was not called from a mark procedure. */
|
||||
abort ();
|
||||
|
||||
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
|
||||
mark_stack_ptr, mark_stack_limit,
|
||||
NULL);
|
||||
scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* Finalize SMOB by calling its SMOB type's free function, if any. */
|
||||
void
|
||||
|
|
@ -386,11 +246,7 @@ scm_i_finalize_smob (struct scm_thread *thread, SCM smob)
|
|||
|
||||
/* Frob the object's type in place, re-setting it to be the "finalized
|
||||
smob" type. This will prevent other routines from accessing its
|
||||
internals in a way that assumes that the smob data is valid. This
|
||||
is notably the case for SMOB's own "mark" procedure, if any; as the
|
||||
finalizer is invoked by the mutator, it's possible for a GC to
|
||||
occur while it's running, in which case the object is alive and yet
|
||||
its data is invalid. */
|
||||
internals in a way that assumes that the smob data is valid. */
|
||||
scm_t_bits finalized_word = first_word & ~(scm_t_bits) 0xff00;
|
||||
scm_atomic_set_bits (first_word_loc, finalized_word);
|
||||
|
||||
|
|
@ -403,54 +259,28 @@ scm_i_finalize_smob (struct scm_thread *thread, SCM smob)
|
|||
free_smob (smob);
|
||||
}
|
||||
|
||||
/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
|
||||
provide a custom mark procedure and it will be honored. */
|
||||
/* Return a SMOB with typecode TC. */
|
||||
SCM
|
||||
scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
|
||||
scm_new_smob (scm_t_bits tc, scm_t_bits data)
|
||||
{
|
||||
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
|
||||
SCM ret;
|
||||
SCM ret = scm_cell (tc, data);
|
||||
|
||||
/* Use the smob_gc_kind if needed to allow the mark procedure to
|
||||
run. Since the marker only deals with double cells, that case
|
||||
allocates a double cell. We leave words 2 and 3 to there initial
|
||||
values, which is 0. */
|
||||
if (scm_smobs [smobnum].mark)
|
||||
ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
|
||||
else
|
||||
ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
|
||||
|
||||
SCM_SET_CELL_WORD_1 (ret, data);
|
||||
SCM_SET_CELL_WORD_0 (ret, tc);
|
||||
|
||||
if (scm_smobs[smobnum].free)
|
||||
if (SCM_UNLIKELY (scm_smobs[smobnum].free))
|
||||
scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret);
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
|
||||
provide a custom mark procedure and it will be honored. */
|
||||
/* Return a SMOB with typecode TC. */
|
||||
SCM
|
||||
scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
|
||||
scm_t_bits data2, scm_t_bits data3)
|
||||
scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
|
||||
scm_t_bits data2, scm_t_bits data3)
|
||||
{
|
||||
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
|
||||
SCM ret;
|
||||
SCM ret = scm_double_cell (tc, data1, data2, data3);
|
||||
|
||||
/* Use the smob_gc_kind if needed to allow the mark procedure to
|
||||
run. */
|
||||
if (scm_smobs [smobnum].mark)
|
||||
ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
|
||||
else
|
||||
ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
|
||||
|
||||
SCM_SET_CELL_WORD_3 (ret, data3);
|
||||
SCM_SET_CELL_WORD_2 (ret, data2);
|
||||
SCM_SET_CELL_WORD_1 (ret, data1);
|
||||
SCM_SET_CELL_WORD_0 (ret, tc);
|
||||
|
||||
if (scm_smobs[smobnum].free)
|
||||
if (SCM_UNLIKELY (scm_smobs[smobnum].free))
|
||||
scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret);
|
||||
|
||||
return ret;
|
||||
|
|
@ -475,22 +305,11 @@ scm_smob_prehistory ()
|
|||
long i;
|
||||
scm_t_bits finalized_smob_tc16;
|
||||
|
||||
scm_i_pthread_key_create (¤t_mark_stack_pointer, NULL);
|
||||
scm_i_pthread_key_create (¤t_mark_stack_limit, NULL);
|
||||
|
||||
smob_gc_kind = GC_new_kind (GC_new_free_list (),
|
||||
GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
|
||||
0,
|
||||
/* Clear new objects. As of version 7.1, libgc
|
||||
doesn't seem to support passing 0 here. */
|
||||
1);
|
||||
|
||||
scm_numsmob = 0;
|
||||
for (i = 0; i < MAX_SMOB_COUNT; ++i)
|
||||
{
|
||||
scm_smobs[i].name = 0;
|
||||
scm_smobs[i].size = 0;
|
||||
scm_smobs[i].mark = 0;
|
||||
scm_smobs[i].free = 0;
|
||||
scm_smobs[i].print = scm_smob_print;
|
||||
scm_smobs[i].equalp = 0;
|
||||
|
|
|
|||
|
|
@ -22,11 +22,10 @@
|
|||
|
||||
|
||||
|
||||
#include <libguile/error.h>
|
||||
#include <libguile/gc.h>
|
||||
#include "libguile/inline.h"
|
||||
#include "libguile/error.h"
|
||||
#include "libguile/gc.h"
|
||||
#include "libguile/print.h"
|
||||
#include <libguile/snarf.h>
|
||||
#include "libguile/snarf.h"
|
||||
|
||||
|
||||
|
||||
|
|
@ -36,7 +35,6 @@ typedef struct scm_smob_descriptor
|
|||
{
|
||||
char const *name;
|
||||
size_t size;
|
||||
SCM (*mark) (SCM);
|
||||
size_t (*free) (SCM);
|
||||
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
|
||||
SCM (*equalp) (SCM, SCM);
|
||||
|
|
@ -78,14 +76,6 @@ SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
|
|||
SCM_SNARF_HERE(scm_t_bits tag) \
|
||||
SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
|
||||
|
||||
#define SCM_SMOB_MARK(tag, c_name, arg) \
|
||||
SCM_SNARF_HERE(static SCM c_name(SCM arg)) \
|
||||
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
|
||||
|
||||
#define SCM_GLOBAL_SMOB_MARK(tag, c_name, arg) \
|
||||
SCM_SNARF_HERE(SCM c_name(SCM arg)) \
|
||||
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
|
||||
|
||||
#define SCM_SMOB_FREE(tag, c_name, arg) \
|
||||
SCM_SNARF_HERE(static size_t c_name(SCM arg)) \
|
||||
SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)
|
||||
|
|
@ -121,39 +111,9 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
|
|||
|
||||
|
||||
|
||||
SCM_API SCM scm_i_new_smob (scm_t_bits tc, scm_t_bits);
|
||||
SCM_API SCM scm_i_new_double_smob (scm_t_bits tc, scm_t_bits,
|
||||
scm_t_bits, scm_t_bits);
|
||||
|
||||
|
||||
SCM_INLINE SCM scm_new_smob (scm_t_bits tc, scm_t_bits);
|
||||
SCM_INLINE SCM scm_new_double_smob (scm_t_bits tc, scm_t_bits,
|
||||
scm_t_bits, scm_t_bits);
|
||||
|
||||
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
|
||||
SCM_INLINE_IMPLEMENTATION SCM
|
||||
scm_new_smob (scm_t_bits tc, scm_t_bits data)
|
||||
{
|
||||
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
|
||||
|
||||
if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
|
||||
return scm_i_new_smob (tc, data);
|
||||
else
|
||||
return scm_cell (tc, data);
|
||||
}
|
||||
|
||||
SCM_INLINE_IMPLEMENTATION SCM
|
||||
scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
|
||||
scm_t_bits data2, scm_t_bits data3)
|
||||
{
|
||||
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
|
||||
|
||||
if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
|
||||
return scm_i_new_double_smob (tc, data1, data2, data3);
|
||||
else
|
||||
return scm_double_cell (tc, data1, data2, data3);
|
||||
}
|
||||
#endif
|
||||
SCM_API SCM scm_new_smob (scm_t_bits tc, scm_t_bits);
|
||||
SCM_API SCM scm_new_double_smob (scm_t_bits tc, scm_t_bits,
|
||||
scm_t_bits, scm_t_bits);
|
||||
|
||||
#define SCM_NEWSMOB(z, tc, data) \
|
||||
z = scm_new_smob ((tc), (scm_t_bits)(data))
|
||||
|
|
@ -222,22 +182,18 @@ scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
|
|||
|
||||
|
||||
|
||||
SCM_API SCM scm_mark0 (SCM ptr);
|
||||
SCM_API SCM scm_markcdr (SCM ptr);
|
||||
SCM_API size_t scm_free0 (SCM ptr);
|
||||
SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
|
||||
|
||||
/* The following set of functions is the standard way to create new
|
||||
* SMOB types.
|
||||
*
|
||||
* Create a type tag using `scm_make_smob_type', accept default values
|
||||
* for mark, free, print and/or equalp functions, or set your own
|
||||
* for free, print and/or equalp functions, or set your own
|
||||
* values using `scm_set_smob_xxx'.
|
||||
*/
|
||||
|
||||
SCM_API scm_t_bits scm_make_smob_type (char const *name, size_t size);
|
||||
|
||||
SCM_API void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM));
|
||||
SCM_API void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM));
|
||||
SCM_API void scm_set_smob_print (scm_t_bits tc,
|
||||
int (*print) (SCM, SCM, scm_print_state*));
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
## Process this file with automake to produce Makefile.in.
|
||||
##
|
||||
## Copyright 2003-2014, 2020-2024 Free Software Foundation, Inc.
|
||||
## Copyright 2003-2014, 2020-2025 Free Software Foundation, Inc.
|
||||
##
|
||||
## This file is part of GUILE.
|
||||
##
|
||||
|
|
@ -292,18 +292,6 @@ EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c
|
|||
|
||||
endif
|
||||
|
||||
test_smob_mark_SOURCES = test-smob-mark.c
|
||||
test_smob_mark_CFLAGS = ${test_cflags}
|
||||
test_smob_mark_LDADD = $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la
|
||||
check_PROGRAMS += test-smob-mark
|
||||
TESTS += test-smob-mark
|
||||
|
||||
test_smob_mark_race_SOURCES = test-smob-mark-race.c
|
||||
test_smob_mark_race_CFLAGS = ${test_cflags}
|
||||
test_smob_mark_race_LDADD = $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la
|
||||
check_PROGRAMS += test-smob-mark-race
|
||||
TESTS += test-smob-mark-race
|
||||
|
||||
check_SCRIPTS += test-stack-overflow
|
||||
TESTS += test-stack-overflow
|
||||
|
||||
|
|
|
|||
|
|
@ -1,66 +0,0 @@
|
|||
/* Copyright 2016
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
This file is part of Guile.
|
||||
|
||||
Guile is free software: you can redistribute it and/or modify it
|
||||
under the terms of the GNU Lesser General Public License as published
|
||||
by the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
Guile is distributed in the hope that it will be useful, but WITHOUT
|
||||
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with Guile. If not, see
|
||||
<https://www.gnu.org/licenses/>. */
|
||||
|
||||
#if HAVE_CONFIG_H
|
||||
#include <config.h>
|
||||
#endif
|
||||
|
||||
#undef NDEBUG
|
||||
|
||||
#include <libguile.h>
|
||||
#include <assert.h>
|
||||
|
||||
static SCM
|
||||
mark_smob (SCM smob)
|
||||
{
|
||||
assert (SCM_SMOB_DATA (smob) == 1);
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
static size_t
|
||||
finalize_smob (SCM smob)
|
||||
{
|
||||
assert (SCM_SMOB_DATA (smob) == 1);
|
||||
SCM_SET_SMOB_DATA (smob, 0);
|
||||
/* Allocate a bit in the hopes of triggering a new GC, making the
|
||||
marker race with the finalizer. */
|
||||
scm_cons (SCM_BOOL_F, SCM_BOOL_F);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static void
|
||||
tests (void *data, int argc, char **argv)
|
||||
{
|
||||
scm_t_bits tc16;
|
||||
int i;
|
||||
|
||||
tc16 = scm_make_smob_type ("smob with finalizer", 0);
|
||||
scm_set_smob_mark (tc16, mark_smob);
|
||||
scm_set_smob_free (tc16, finalize_smob);
|
||||
|
||||
for (i = 0; i < 1000 * 1000; i++)
|
||||
scm_new_smob (tc16, 1);
|
||||
}
|
||||
|
||||
int
|
||||
main (int argc, char *argv[])
|
||||
{
|
||||
scm_boot_guile (argc, argv, tests, NULL);
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -1,136 +0,0 @@
|
|||
/* Copyright 2013-2014,2018,2025
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
This file is part of Guile.
|
||||
|
||||
Guile is free software: you can redistribute it and/or modify it
|
||||
under the terms of the GNU Lesser General Public License as published
|
||||
by the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
Guile is distributed in the hope that it will be useful, but WITHOUT
|
||||
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with Guile. If not, see
|
||||
<https://www.gnu.org/licenses/>. */
|
||||
|
||||
#if HAVE_CONFIG_H
|
||||
#include <config.h>
|
||||
#endif
|
||||
|
||||
#undef NDEBUG
|
||||
|
||||
#include <assert.h>
|
||||
#include <libguile.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#define SMOBS_COUNT (10000)
|
||||
|
||||
struct x_tag
|
||||
{
|
||||
SCM scm_value;
|
||||
int c_value;
|
||||
};
|
||||
|
||||
typedef struct x_tag x_t;
|
||||
|
||||
unsigned int mark_call_count = 0;
|
||||
|
||||
static scm_t_bits x_tag;
|
||||
static SCM make_x (void);
|
||||
static SCM mark_x (SCM x);
|
||||
static int print_x (SCM x, SCM port, scm_print_state * pstate);
|
||||
static size_t free_x (SCM x);
|
||||
static void init_smob_type (void);
|
||||
static void test_scm_smob_mark (void);
|
||||
|
||||
static SCM
|
||||
make_x ()
|
||||
{
|
||||
static int i = 0;
|
||||
SCM s_x;
|
||||
x_t *c_x;
|
||||
|
||||
i++;
|
||||
c_x = (x_t *) scm_malloc (sizeof (x_t));
|
||||
c_x->scm_value = scm_from_int (i);
|
||||
c_x->c_value = i;
|
||||
SCM_NEWSMOB (s_x, x_tag, c_x);
|
||||
return s_x;
|
||||
}
|
||||
|
||||
static SCM
|
||||
mark_x (SCM x)
|
||||
{
|
||||
x_t *c_x;
|
||||
c_x = (x_t *) SCM_SMOB_DATA (x);
|
||||
scm_gc_mark (c_x->scm_value);
|
||||
mark_call_count++;
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
static size_t
|
||||
free_x (SCM x)
|
||||
{
|
||||
x_t *c_x;
|
||||
c_x = (x_t *) SCM_SMOB_DATA (x);
|
||||
free (c_x);
|
||||
c_x = NULL;
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
print_x (SCM x, SCM port, scm_print_state * pstate SCM_UNUSED)
|
||||
{
|
||||
x_t *c_x = (x_t *) SCM_SMOB_DATA (x);
|
||||
scm_puts ("#<x ", port);
|
||||
if (c_x == (x_t *) NULL)
|
||||
scm_puts ("(freed)", port);
|
||||
else
|
||||
scm_write (c_x->scm_value, port);
|
||||
scm_puts (">", port);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
static void
|
||||
test_scm_smob_mark ()
|
||||
{
|
||||
int i;
|
||||
mark_call_count = 0;
|
||||
for (i = 0; i < SMOBS_COUNT; i++)
|
||||
make_x ();
|
||||
scm_gc ();
|
||||
if (mark_call_count < SMOBS_COUNT)
|
||||
{
|
||||
fprintf (stderr, "FAIL: SMOB mark function called for each SMOB\n");
|
||||
exit (EXIT_FAILURE);
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
init_smob_type ()
|
||||
{
|
||||
x_tag = scm_make_smob_type ("x", sizeof (x_t));
|
||||
scm_set_smob_free (x_tag, free_x);
|
||||
scm_set_smob_print (x_tag, print_x);
|
||||
scm_set_smob_mark (x_tag, mark_x);
|
||||
}
|
||||
|
||||
static void
|
||||
tests (void *data, int argc, char **argv)
|
||||
{
|
||||
init_smob_type ();
|
||||
test_scm_smob_mark ();
|
||||
}
|
||||
|
||||
int
|
||||
main (int argc, char *argv[])
|
||||
{
|
||||
scm_boot_guile (argc, argv, tests, NULL);
|
||||
return 0;
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue