mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-02 18:26:20 +02:00
7b4f4427f8
* libguile/trace.h (scm_from_ref, scm_to_ref): Helpers moved here; update all callers. * libguile/loader.c (scm_trace_loader_roots): * libguile/threads.c (scm_trace_thread_roots): * libguile/vm.c (scm_trace_vm_roots): Update for new pinned-roots prototype. * libguile/whippet-embedder.h (gc_extern_space_visit): Update for Whippet API changes.
506 lines
14 KiB
C
506 lines
14 KiB
C
/* Copyright 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/>. */
|
||
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include <assert.h>
|
||
#include <errno.h>
|
||
#include <fcntl.h>
|
||
#include <full-write.h>
|
||
#include <stdio.h>
|
||
#include <unistd.h>
|
||
|
||
#include "atomics-internal.h"
|
||
#include "extensions.h"
|
||
#include "gc-internal.h"
|
||
#include "gsubr.h"
|
||
#include "hash.h"
|
||
#include "numbers.h"
|
||
#include "ports.h"
|
||
#include "threads.h"
|
||
#include "trace.h"
|
||
#include "version.h"
|
||
|
||
#include <gc-ephemeron.h>
|
||
|
||
#include "ephemerons.h"
|
||
|
||
|
||
|
||
|
||
#define SCM_EPHEMERON_P(X) (SCM_HAS_TYP7 (X, scm_tc7_ephemeron))
|
||
|
||
struct gc_ephemeron*
|
||
scm_c_make_ephemeron (SCM key, SCM val)
|
||
{
|
||
struct scm_thread *thread = SCM_I_CURRENT_THREAD;
|
||
struct gc_ephemeron *ephemeron = gc_allocate_ephemeron (thread->mutator);
|
||
SCM_SET_CELL_WORD_0 (PTR2SCM (ephemeron), scm_tc7_ephemeron);
|
||
gc_ephemeron_init (thread->mutator, ephemeron, scm_to_ref (key),
|
||
scm_to_ref (val));
|
||
return ephemeron;
|
||
}
|
||
|
||
static struct gc_ephemeron*
|
||
scm_as_ephemeron (SCM x)
|
||
{
|
||
return (struct gc_ephemeron*) SCM_UNPACK_POINTER (x);
|
||
}
|
||
|
||
SCM
|
||
scm_from_ephemeron (struct gc_ephemeron *e)
|
||
{
|
||
return PTR2SCM (e);
|
||
}
|
||
|
||
struct gc_ephemeron*
|
||
scm_to_ephemeron (SCM e)
|
||
{
|
||
if (!SCM_EPHEMERON_P (e))
|
||
abort ();
|
||
return scm_as_ephemeron (e);
|
||
}
|
||
|
||
SCM
|
||
scm_c_ephemeron_key (struct gc_ephemeron *e)
|
||
{
|
||
struct gc_ref ret = gc_ephemeron_key (e);
|
||
return gc_ref_is_null (ret) ? SCM_BOOL_F : scm_from_ref (ret);
|
||
}
|
||
|
||
SCM
|
||
scm_c_ephemeron_value (struct gc_ephemeron *e)
|
||
{
|
||
struct gc_ref ret = gc_ephemeron_value (e);
|
||
return gc_ref_is_null (ret) ? SCM_BOOL_F : scm_from_ref (ret);
|
||
}
|
||
|
||
void
|
||
scm_c_ephemeron_mark_dead_x (struct gc_ephemeron *e)
|
||
{
|
||
gc_ephemeron_mark_dead (e);
|
||
}
|
||
|
||
SCM
|
||
scm_c_ephemeron_swap_x (struct gc_ephemeron *e, SCM new_val)
|
||
{
|
||
struct gc_ref ret =
|
||
gc_ephemeron_swap_value (SCM_I_CURRENT_THREAD->mutator, e,
|
||
scm_to_ref (new_val));
|
||
return gc_ref_is_null (ret) ? SCM_BOOL_F : scm_from_ref (ret);
|
||
}
|
||
|
||
struct gc_ephemeron*
|
||
scm_c_ephemeron_next (struct gc_ephemeron *e)
|
||
{
|
||
return gc_ephemeron_chain_next (e);
|
||
}
|
||
|
||
struct gc_ephemeron*
|
||
scm_c_ephemeron_load (struct gc_ephemeron **loc)
|
||
{
|
||
return gc_ephemeron_chain_head (loc);
|
||
}
|
||
|
||
void
|
||
scm_c_ephemeron_push (struct gc_ephemeron **loc, struct gc_ephemeron *e)
|
||
{
|
||
gc_ephemeron_chain_push (loc, e);
|
||
}
|
||
|
||
|
||
|
||
|
||
#define SCM_VALIDATE_EPHEMERON(pos, x) \
|
||
SCM_MAKE_VALIDATE_MSG (pos, x, EPHEMERON_P, "ephemeron")
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_p, "ephemeron?", 1, 0, 0,
|
||
(SCM x),
|
||
"Return @code{#t} if @var{x} is an ephemeron, or "
|
||
"@code{#f} otherwise.")
|
||
#define FUNC_NAME s_scm_ephemeron_p
|
||
{
|
||
return scm_from_bool (SCM_EPHEMERON_P (x));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_make_ephemeron, "make-ephemeron", 2, 0, 0,
|
||
(SCM key, SCM val),
|
||
"Make an ephemeron that will reference @var{val} as long "
|
||
"as @var{key} and the ephemeron itself are alive.")
|
||
#define FUNC_NAME s_scm_make_ephemeron
|
||
{
|
||
return PTR2SCM (scm_c_make_ephemeron (key, val));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_key, "ephemeron-key", 1, 0, 0,
|
||
(SCM ephemeron),
|
||
"Return the key for an ephemeron, or @code{#f} if the "
|
||
"ephemeron is dead.")
|
||
#define FUNC_NAME s_scm_ephemeron_key
|
||
{
|
||
SCM_VALIDATE_EPHEMERON (1, ephemeron);
|
||
return scm_c_ephemeron_key (scm_as_ephemeron (ephemeron));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_value, "ephemeron-value", 1, 0, 0,
|
||
(SCM ephemeron),
|
||
"Return the value for an ephemeron, or @code{#f} if the "
|
||
"ephemeron is dead.")
|
||
#define FUNC_NAME s_scm_ephemeron_value
|
||
{
|
||
SCM_VALIDATE_EPHEMERON (1, ephemeron);
|
||
return scm_c_ephemeron_value (scm_as_ephemeron (ephemeron));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_swap_x, "ephemeron-swap!", 2, 0, 0,
|
||
(SCM ephemeron, SCM new_val),
|
||
"Update the value for this ephemeron, and return the "
|
||
"previous value.")
|
||
#define FUNC_NAME s_scm_ephemeron_swap_x
|
||
{
|
||
SCM_VALIDATE_EPHEMERON (1, ephemeron);
|
||
return scm_c_ephemeron_swap_x (scm_as_ephemeron (ephemeron), new_val);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_mark_dead_x, "ephemeron-mark-dead!", 1, 0, 0,
|
||
(SCM ephemeron),
|
||
"Remove the key-value association for this ephemeron.")
|
||
#define FUNC_NAME s_scm_ephemeron_mark_dead_x
|
||
{
|
||
SCM_VALIDATE_EPHEMERON (1, ephemeron);
|
||
scm_c_ephemeron_mark_dead_x (scm_as_ephemeron (ephemeron));
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_next, "ephemeron-next", 1, 0, 0,
|
||
(SCM ephemeron),
|
||
"Return the next ephemeron in a chain, or @code{#f} if none.")
|
||
#define FUNC_NAME s_scm_ephemeron_next
|
||
{
|
||
SCM_VALIDATE_EPHEMERON (1, ephemeron);
|
||
struct gc_ephemeron *e = scm_c_ephemeron_next (scm_as_ephemeron (ephemeron));
|
||
return e ? PTR2SCM (e) : SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
int
|
||
scm_i_print_ephemeron (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
|
||
{
|
||
scm_puts ("#<ephemeron ", port);
|
||
scm_uintprint (SCM_UNPACK (exp), 16, port);
|
||
scm_puts (")>", port);
|
||
return 1;
|
||
}
|
||
|
||
|
||
|
||
|
||
#define SCM_EPHEMERON_TABLE_P(X) (SCM_HAS_TYP7 (X, scm_tc7_ephemeron_table))
|
||
#define SCM_VALIDATE_EPHEMERON_TABLE(pos, x) \
|
||
SCM_MAKE_VALIDATE_MSG (pos, x, EPHEMERON_TABLE_P, "ephemeron table")
|
||
|
||
static struct scm_ephemeron_table*
|
||
scm_as_ephemeron_table (SCM x)
|
||
{
|
||
return (struct scm_ephemeron_table*) SCM_UNPACK_POINTER (x);
|
||
}
|
||
|
||
SCM
|
||
scm_from_ephemeron_table (struct scm_ephemeron_table *et)
|
||
{
|
||
return PTR2SCM (et);
|
||
}
|
||
|
||
struct scm_ephemeron_table*
|
||
scm_to_ephemeron_table (SCM et)
|
||
{
|
||
if (!SCM_EPHEMERON_TABLE_P (et))
|
||
abort ();
|
||
return scm_as_ephemeron_table (et);
|
||
}
|
||
|
||
struct scm_ephemeron_table
|
||
{
|
||
scm_t_bits tag;
|
||
size_t size;
|
||
struct gc_ephemeron *contents[];
|
||
};
|
||
|
||
struct scm_ephemeron_table*
|
||
scm_c_make_ephemeron_table (size_t size)
|
||
{
|
||
size_t byte_size = sizeof (struct scm_ephemeron_table);
|
||
byte_size += sizeof (struct gc_ephemeron*) * size;
|
||
struct scm_ephemeron_table *table = scm_gc_malloc (byte_size, NULL);
|
||
table->tag = scm_tc7_ephemeron_table;
|
||
table->size = size;
|
||
return table;
|
||
}
|
||
|
||
size_t
|
||
scm_c_ephemeron_table_length (struct scm_ephemeron_table *et)
|
||
{
|
||
return et->size;
|
||
}
|
||
|
||
struct gc_ephemeron*
|
||
scm_c_ephemeron_table_ref (struct scm_ephemeron_table *et, size_t idx)
|
||
{
|
||
if (idx >= et->size)
|
||
abort();
|
||
|
||
return gc_ephemeron_chain_head (&et->contents[idx]);
|
||
}
|
||
|
||
void
|
||
scm_c_ephemeron_table_push_x (struct scm_ephemeron_table *et, size_t idx,
|
||
struct gc_ephemeron *e)
|
||
{
|
||
if (idx >= et->size)
|
||
abort();
|
||
|
||
gc_ephemeron_chain_push (&et->contents[idx], e);
|
||
}
|
||
|
||
struct gc_ephemeron*
|
||
scm_c_ephemeron_table_try_push_x (struct scm_ephemeron_table *et, size_t idx,
|
||
struct gc_ephemeron *e,
|
||
struct gc_ephemeron *prev)
|
||
{
|
||
if (idx >= et->size)
|
||
abort();
|
||
|
||
gc_ephemeron_chain_try_push (&et->contents[idx], e, &prev);
|
||
|
||
return prev;
|
||
}
|
||
|
||
static struct gc_ephemeron*
|
||
scm_c_ephemeron_table_clear_x (struct scm_ephemeron_table *et, size_t idx)
|
||
{
|
||
if (idx >= et->size)
|
||
abort();
|
||
|
||
return scm_atomic_swap_pointer ((void**) &et->contents[idx], NULL);
|
||
}
|
||
|
||
struct scm_ephemeron_table*
|
||
scm_c_ephemeron_table_copy (struct scm_ephemeron_table *et)
|
||
{
|
||
struct scm_ephemeron_table *ret = scm_c_make_ephemeron_table (et->size);
|
||
|
||
for (size_t idx = 0; idx < ret->size; idx++)
|
||
for (struct gc_ephemeron *e = scm_c_ephemeron_table_ref (et, idx);
|
||
e;
|
||
e = scm_c_ephemeron_next (e))
|
||
{
|
||
SCM key = scm_c_ephemeron_key (e);
|
||
SCM value = scm_c_ephemeron_value (e);
|
||
struct gc_ephemeron *copy = scm_c_make_ephemeron (key, value);
|
||
scm_c_ephemeron_table_push_x (ret, idx, copy);
|
||
}
|
||
|
||
return ret;
|
||
}
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_table_p, "ephemeron-table?", 1, 0, 0,
|
||
(SCM x),
|
||
"Return @code{#t} if @var{x} is an ephemeron table, or "
|
||
"@code{#f} otherwise.")
|
||
#define FUNC_NAME s_scm_ephemeron_table_p
|
||
{
|
||
return scm_from_bool (SCM_EPHEMERON_TABLE_P (x));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_make_ephemeron_table, "make-ephemeron-table", 1, 0, 0,
|
||
(SCM size),
|
||
"Make an ephemeron table of size @var{size}.")
|
||
#define FUNC_NAME s_scm_make_ephemeron_table
|
||
{
|
||
return PTR2SCM (scm_c_make_ephemeron_table (scm_to_size_t (size)));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_table_length, "ephemeron-table-length", 1, 0, 0,
|
||
(SCM et),
|
||
"Return the length of the ephemeron table @var{et}.")
|
||
#define FUNC_NAME s_scm_ephemeron_table_length
|
||
{
|
||
SCM_VALIDATE_EPHEMERON_TABLE (1, et);
|
||
|
||
return scm_from_size_t
|
||
(scm_c_ephemeron_table_length (scm_as_ephemeron_table (et)));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_table_ref, "ephemeron-table-ref", 2, 0, 0,
|
||
(SCM et, SCM idx),
|
||
"Return the ephemeron in slot @var{idx} of the ephemeron "
|
||
"table @var{et}, or @code{#f} if the slot is empty.")
|
||
#define FUNC_NAME s_scm_ephemeron_table_ref
|
||
{
|
||
SCM_VALIDATE_EPHEMERON_TABLE (1, et);
|
||
SCM_ASSERT_RANGE (2, idx,
|
||
scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size);
|
||
struct gc_ephemeron *ret =
|
||
scm_c_ephemeron_table_ref (scm_as_ephemeron_table (et),
|
||
scm_to_size_t (idx));
|
||
return ret ? PTR2SCM (ret) : SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_table_push_x, "ephemeron-table-push!", 3, 0, 0,
|
||
(SCM et, SCM idx, SCM e),
|
||
"Push the ephemeron @var{e} onto slot @var{idx} of the "
|
||
"ephemeron table @var{et}.")
|
||
#define FUNC_NAME s_scm_ephemeron_table_push_x
|
||
{
|
||
SCM_VALIDATE_EPHEMERON_TABLE (1, et);
|
||
SCM_ASSERT_RANGE (2, idx,
|
||
scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size);
|
||
SCM_VALIDATE_EPHEMERON (3, e);
|
||
scm_c_ephemeron_table_push_x (scm_as_ephemeron_table (et),
|
||
scm_to_size_t (idx), scm_as_ephemeron (e));
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_table_try_push_x, "ephemeron-table-try-push!",
|
||
4, 0, 0, (SCM et, SCM idx, SCM e, SCM tail),
|
||
"Push the ephemeron @var{e} onto slot @var{idx} of the "
|
||
"ephemeron table @var{et}, whose current value is "
|
||
"@var{tail}. On success, return @var{tail}. On failure, "
|
||
"return the value of slot @var{idx}.")
|
||
#define FUNC_NAME s_scm_ephemeron_table_try_push_x
|
||
{
|
||
SCM_VALIDATE_EPHEMERON_TABLE (1, et);
|
||
SCM_ASSERT_RANGE (2, idx,
|
||
scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size);
|
||
SCM_VALIDATE_EPHEMERON (3, e);
|
||
struct gc_ephemeron *expected = NULL;
|
||
if (!scm_is_eq (tail, SCM_BOOL_F))
|
||
{
|
||
SCM_VALIDATE_EPHEMERON (4, tail);
|
||
expected = scm_as_ephemeron (tail);
|
||
}
|
||
struct gc_ephemeron *res =
|
||
scm_c_ephemeron_table_try_push_x (scm_as_ephemeron_table (et),
|
||
scm_to_size_t (idx),
|
||
scm_as_ephemeron (e),
|
||
expected);
|
||
return res ? PTR2SCM (res) : SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE_STATIC (scm_ephemeron_table_clear_x, "ephemeron-table-clear!",
|
||
2, 0, 0, (SCM et, SCM idx),
|
||
"Clear the slot @var{idx} of the ephemeron table @var{et} "
|
||
"and return its previous value.")
|
||
#define FUNC_NAME s_scm_ephemeron_table_clear_x
|
||
{
|
||
SCM_VALIDATE_EPHEMERON_TABLE (1, et);
|
||
SCM_ASSERT_RANGE (2, idx,
|
||
scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size);
|
||
|
||
struct gc_ephemeron *prev =
|
||
scm_c_ephemeron_table_clear_x (scm_as_ephemeron_table (et),
|
||
scm_to_size_t (idx));
|
||
return prev ? PTR2SCM (prev) : SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
int
|
||
scm_i_print_ephemeron_table (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
|
||
{
|
||
scm_puts ("#<ephemeron-table ", port);
|
||
scm_uintprint (SCM_UNPACK (exp), 16, port);
|
||
scm_puts (")>", port);
|
||
return 1;
|
||
}
|
||
|
||
|
||
|
||
|
||
SCM
|
||
scm_c_ephemeron_hash_table_refq (struct scm_ephemeron_table *et, SCM key,
|
||
SCM default_value)
|
||
{
|
||
size_t idx = scm_ihashq (key, et->size);
|
||
|
||
for (struct gc_ephemeron *e = scm_c_ephemeron_table_ref (et, idx);
|
||
e;
|
||
e = scm_c_ephemeron_next (e))
|
||
if (scm_is_eq (key, scm_c_ephemeron_key (e)))
|
||
return scm_c_ephemeron_value (e);
|
||
|
||
return default_value;
|
||
}
|
||
|
||
void
|
||
scm_c_ephemeron_hash_table_setq_x (struct scm_ephemeron_table *et, SCM key,
|
||
SCM value)
|
||
{
|
||
size_t idx = scm_ihashq (key, et->size);
|
||
|
||
struct gc_ephemeron *prev = scm_c_ephemeron_table_ref (et, idx);
|
||
struct gc_ephemeron *chain;
|
||
do
|
||
{
|
||
chain = prev;
|
||
for (struct gc_ephemeron *e = chain; e; e = scm_c_ephemeron_next (e))
|
||
if (scm_is_eq (key, scm_c_ephemeron_key (e)))
|
||
{
|
||
scm_c_ephemeron_swap_x (e, value);
|
||
return;
|
||
}
|
||
struct gc_ephemeron *new_head = scm_c_make_ephemeron (key, value);
|
||
prev = scm_c_ephemeron_table_try_push_x (et, idx, new_head, chain);
|
||
} while (prev != chain);
|
||
}
|
||
|
||
|
||
|
||
|
||
static void
|
||
scm_init_ephemerons (void)
|
||
{
|
||
#ifndef SCM_MAGIC_SNARFER
|
||
#include "ephemerons.x"
|
||
#endif
|
||
}
|
||
|
||
void
|
||
scm_register_ephemerons (void)
|
||
{
|
||
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
|
||
"scm_init_ephemerons",
|
||
(scm_t_extension_init_func)scm_init_ephemerons,
|
||
NULL);
|
||
}
|