mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-05 17:20:18 +02:00
Code Activity

Avoid untagged traced allocation in make-struct/no-tail

Browse source 
* libguile/struct.c (scm_struct_init_1_default):
(scm_struct_init_1): New helpers.
(scm_struct_init_array): Use new helpers.
(scm_struct_init_list): New function.
(scm_make_struct_no_tail): Use scm_struct_init_list instead of mallocing.
This commit is contained in:
Andy Wingo 2025-06-20 09:27:47 +02:00
parent 4d15cb7e6d
commit ce2f7847e8
1 changed files with 51 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

84
libguile/struct.c
View file

@ -255,7 +255,25 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
static void
scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
scm_struct_init_1_default (SCM handle, size_t idx)
{
SCM_STRUCT_DATA_SET (handle, idx,
SCM_STRUCT_FIELD_IS_UNBOXED (handle, idx)
? 0
: SCM_UNPACK (SCM_BOOL_F));
}
static void
scm_struct_init_1 (SCM handle, size_t idx, scm_t_bits val)
{
SCM_STRUCT_DATA_SET (handle, idx,
SCM_STRUCT_FIELD_IS_UNBOXED (handle, idx)
? scm_to_uintptr_t (SCM_PACK (val))
: val);
}
static void
scm_struct_init_array (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
{
size_t n, n_fields, inits_idx = 0;
@ -264,23 +282,28 @@ scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
for (n = 0; n < n_fields; n++)
{
if (inits_idx == n_inits || scm_i_symbol_ref (layout, n*2+1) == 'h')
{
if (SCM_STRUCT_FIELD_IS_UNBOXED (handle, n))
SCM_STRUCT_DATA_SET (handle, n, 0);
scm_struct_init_1_default (handle, n);
else
SCM_STRUCT_SLOT_SET (handle, n, SCM_BOOL_F);
}
else
{
SCM_STRUCT_DATA_SET (handle, n,
SCM_STRUCT_FIELD_IS_UNBOXED (handle, n)
? scm_to_uintptr_t (SCM_PACK (inits[inits_idx]))
: inits[inits_idx]);
inits_idx++;
}
scm_struct_init_1 (handle, n, inits[inits_idx++]);
}
}
static void
scm_struct_init_list (SCM handle, SCM layout, SCM inits)
{
size_t n_fields = SCM_STRUCT_SIZE (handle);
for (size_t n = 0; n < n_fields; n++)
{
if (scm_is_null (inits) || scm_i_symbol_ref (layout, n*2+1) == 'h')
scm_struct_init_1_default (handle, n);
else
{
scm_struct_init_1 (handle, n, SCM_UNPACK (scm_car (inits)));
inits = scm_cdr (inits);
}
}
}
SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
(SCM x),
@ -350,7 +373,7 @@ scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
SCM_ASSERT (n_tail == 0, scm_from_size_t (n_tail), 2, FUNC_NAME);
obj = scm_i_alloc_struct (SCM_UNPACK (vtable), basic_size);
scm_struct_init (obj, SCM_VTABLE_LAYOUT (vtable), n_init, init);
scm_struct_init_array (obj, SCM_VTABLE_LAYOUT (vtable), n_init, init);
/* If we're making a vtable, validate its layout and inherit
flags. However we allow for separation of allocation and
@ -407,7 +430,7 @@ SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
SCM_ASSERT (SCM_VTABLE_SIZE (vtable) == c_nfields, nfields, 2, FUNC_NAME);
ret = scm_i_alloc_struct (SCM_UNPACK (vtable), c_nfields);
scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, NULL);
scm_struct_init_array (ret, SCM_VTABLE_LAYOUT (vtable), 0, NULL);
return ret;
}
@ -464,28 +487,23 @@ SCM_DEFINE (scm_make_struct_no_tail, "make-struct/no-tail", 1, 0, 1,
"initialized to 0.")
#define FUNC_NAME s_scm_make_struct_no_tail
{
size_t i, n_init;
long ilen;
scm_t_bits *v;
SCM_VALIDATE_VTABLE (1, vtable);
ilen = scm_ilength (init);
if (ilen < 0)
if (scm_ilength (init) < 0)
SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
n_init = (size_t)ilen;
SCM obj = scm_i_alloc_struct (SCM_UNPACK (vtable), SCM_VTABLE_SIZE (vtable));
scm_struct_init_list (obj, SCM_VTABLE_LAYOUT (vtable), init);
/* best to use alloca, but init could be big, so hack to avoid a possible
stack overflow */
if (n_init < 64)
v = alloca (n_init * sizeof(scm_t_bits));
else
v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
/* If we're making a vtable, validate its layout and inherit
flags. However we allow for separation of allocation and
initialization, to humor GOOPS, so only validate if the layout was
passed as an initarg. */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
&& scm_is_true (SCM_VTABLE_LAYOUT (obj)))
scm_i_struct_inherit_vtable_magic (vtable, obj);
for (i = 0; i < n_init; i++, init = SCM_CDR (init))
v[i] = SCM_UNPACK (SCM_CAR (init));
return scm_c_make_structv (vtable, 0, n_init, v);
return obj;
}
#undef FUNC_NAME