wingo pushed a commit to branch wip-whippet
in repository guile.
commit 6389acf192df274de123b8a9ec97bbf6e4e27670
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Jun 11 15:39:58 2025 +0200
New internal functions to alloc subr closures
* libguile/gsubr.c (scm_allocate_subr_code):
(scm_make_subr_from_code): New functions.
(create_subr): Refactor in terms of new functions.
(scm_c_make_gsubr):
(scm_c_define_gsubr):
(scm_c_make_gsubr_with_generic):
(scm_c_define_gsubr_with_generic): Adapt.
---
libguile/gsubr-internal.h | 14 ++++++++++
libguile/gsubr.c | 66 +++++++++++++++++++++++++++--------------------
2 files changed, 52 insertions(+), 28 deletions(-)
diff --git a/libguile/gsubr-internal.h b/libguile/gsubr-internal.h
index f5777883c..f3303d41d 100644
--- a/libguile/gsubr-internal.h
+++ b/libguile/gsubr-internal.h
@@ -58,6 +58,20 @@ SCM_INTERNAL SCM scm_apply_subr (struct scm_thread *thread,
union scm_vm_stack_element *sp,
uint32_t subr_idx, ptrdiff_t nargs);
+enum scm_subr_flags
+ {
+ SCM_F_SUBR_THREAD = 1,
+ SCM_F_SUBR_CLOSURE = 2
+ };
+
+SCM_INTERNAL const uint32_t*
+scm_allocate_subr_code (SCM name,
+ unsigned int nreq, unsigned int nopt, unsigned int
rest,
+ void *fcn, uintptr_t subr_flags);
+SCM_INTERNAL struct scm_program*
+scm_make_subr_from_code (struct scm_thread *thread, const uint32_t *code,
+ scm_t_bits program_flags, size_t nfree);
+
SCM_INTERNAL void scm_init_gsubr (void);
#endif /* SCM_GSUBR_INTERNAL_H */
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 662f1bb92..855107a01 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -30,6 +30,7 @@
#include "foreign.h"
#include "frames.h"
+#include "gc-inline.h"
#include "instructions.h"
#include "jit.h"
#include "modules.h"
@@ -56,12 +57,6 @@ static const size_t expected_subr_count = 1500;
static scm_i_pthread_mutex_t admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-enum scm_subr_flags
- {
- SCM_F_SUBR_THREAD = 1,
- SCM_F_SUBR_CLOSURE = 2
- };
-
struct scm_subr_data
{
void *proc;
@@ -334,36 +329,51 @@ get_subr_stub_code (uint32_t subr_idx,
}
}
+const uint32_t*
+scm_allocate_subr_code (SCM name,
+ unsigned int nreq, unsigned int nopt, unsigned int
rest,
+ void *fcn, uintptr_t subr_flags)
+{
+ uint32_t idx = alloc_subr_idx (fcn, subr_flags);
+ record_subr_name (idx, name);
+ return get_subr_stub_code (idx, nreq, nopt, rest);
+}
+
+struct scm_program*
+scm_make_subr_from_code (struct scm_thread *thread, const uint32_t *code,
+ scm_t_bits program_flags, size_t nfree)
+{
+ size_t bytes = sizeof(struct scm_program) + nfree * sizeof (SCM);
+ struct scm_program *proc = scm_inline_gc_malloc (thread, bytes);
+ proc->tag_flags_and_free_variable_count =
+ scm_tc7_program | program_flags | (nfree << 16);
+ proc->code = code;
+ return proc;
+}
+
static SCM
-create_subr (int define, const char *name,
+create_subr (int define, const char *cname,
unsigned int nreq, unsigned int nopt, unsigned int rest,
- void *fcn, SCM *generic_loc, uintptr_t subr_flags)
+ void *fcn, SCM *generic_loc)
{
- SCM sname;
- uint32_t idx;
- scm_t_bits nfree = generic_loc ? 1 : 0;
-
- idx = alloc_subr_idx (fcn, subr_flags);
- sname = scm_from_utf8_symbol (name);
+ uintptr_t subr_flags = 0;
+ SCM name = cname ? scm_from_utf8_symbol (cname) : SCM_BOOL_F;
+ const uint32_t *code =
+ scm_allocate_subr_code (name, nreq, nopt, rest, fcn, subr_flags);
scm_t_bits program_flags = SCM_F_PROGRAM_IS_PRIMITIVE;
if (generic_loc)
program_flags |= SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC;
-
- scm_t_bits tag = scm_tc7_program | (nfree << 16) | program_flags;
-
+ scm_t_bits nfree = generic_loc ? 1 : 0;
struct scm_program *ret =
- scm_gc_malloc (sizeof (struct scm_program) + nfree * sizeof(SCM),
- "foreign procedure");
- ret->tag_flags_and_free_variable_count = tag;
- ret->code = get_subr_stub_code (idx, nreq, nopt, rest);
- record_subr_name (idx, sname);
+ scm_make_subr_from_code (SCM_I_CURRENT_THREAD, code, program_flags,
+ nfree);
+
if (generic_loc)
scm_program_free_variable_set_x (ret, 0,
scm_from_pointer (generic_loc, NULL));
-
if (define)
- scm_define (sname, scm_from_program (ret));
+ scm_define (name, scm_from_program (ret));
return scm_from_program (ret);
}
@@ -606,13 +616,13 @@ scm_apply_subr (struct scm_thread *t,
SCM
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
- return create_subr (0, name, req, opt, rst, fcn, NULL, 0);
+ return create_subr (0, name, req, opt, rst, fcn, NULL);
}
SCM
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
- return create_subr (1, name, req, opt, rst, fcn, NULL, 0);
+ return create_subr (1, name, req, opt, rst, fcn, NULL);
}
SCM
@@ -623,7 +633,7 @@ scm_c_make_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf)
{
- return create_subr (0, name, req, opt, rst, fcn, gf, 0);
+ return create_subr (0, name, req, opt, rst, fcn, gf);
}
SCM
@@ -634,7 +644,7 @@ scm_c_define_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf)
{
- return create_subr (1, name, req, opt, rst, fcn, gf, 0);
+ return create_subr (1, name, req, opt, rst, fcn, gf);
}
void
