wingo pushed a commit to branch wip-whippet
in repository guile.
commit 5c5b8674554faf44df36b65907b9ba3c108b0087
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Jun 11 21:59:58 2025 +0200
Turn boot closures into subrs
* libguile/eval.c: Instead of applicable smobs, boot closures are subrs.
This gives better JIT and no shuffling in the VM.
(is_boot_closure):
(boot_closure_code):
(boot_closure_env):
(boot_closure_body):
(boot_closure_num_required_args):
(boot_closure_is_fixed):
(boot_closure_has_rest_args):
(boot_closure_is_rest): Inline functions instead of macros.
(eval): Create boot closures as programs, not smobs.
(prepare_boot_closure_env_for_apply):
(prepare_boot_closure_env_for_eval): Adapt to lower-casing of boot
closure inline functions.
(apply_boot_closure): Rename from boot_closure_apply.
(boot_closure_print): Remove.
(scm_init_eval): Update.
---
libguile/eval.c | 173 +++++++++++++++++++++++++++++++++-----------------------
1 file changed, 103 insertions(+), 70 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index 32e76fe3f..a93c5a41f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -40,7 +40,7 @@
#include "frames.h"
#include "fluids.h"
#include "goops.h"
-#include "gsubr.h"
+#include "gsubr-internal.h"
#include "hash.h"
#include "hashtab.h"
#include "keywords.h"
@@ -55,7 +55,6 @@
#include "private-options.h"
#include "procprop.h"
#include "programs.h"
-#include "smob.h"
#include "stackchk.h"
#include "strings.h"
#include "symbols.h"
@@ -71,6 +70,21 @@
+#define CAR(x) SCM_CAR(x)
+#define CDR(x) SCM_CDR(x)
+#define CAAR(x) SCM_CAAR(x)
+#define CADR(x) SCM_CADR(x)
+#define CDAR(x) SCM_CDAR(x)
+#define CDDR(x) SCM_CDDR(x)
+#define CADDR(x) SCM_CADDR(x)
+#define CDDDR(x) SCM_CDDDR(x)
+
+#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
+#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
+#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
+
+
+
/* We have three levels of EVAL here:
- eval (exp, env)
@@ -104,20 +118,59 @@
eval.scm is in the house, closures are standard VM closures.
*/
-static scm_t_bits scm_tc16_boot_closure;
-#define RETURN_BOOT_CLOSURE(code, env) \
- SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK
(env))
-#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
-#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
-#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
-#define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
-#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR
(BOOT_CLOSURE_CODE (x))))
-#define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))))
+static const uint32_t *apply_boot_closure_code;
+
+static inline int
+is_boot_closure (SCM obj)
+{
+ return scm_is_program (obj) &&
+ scm_program_code (scm_to_program (obj)) == apply_boot_closure_code;
+}
+
+static inline SCM
+boot_closure_code (SCM clo)
+{
+ return scm_program_free_variable_ref (scm_to_program (clo), 0);
+}
+
+static inline SCM
+boot_closure_env (SCM clo)
+{
+ return scm_program_free_variable_ref (scm_to_program (clo), 1);
+}
+
+static inline SCM
+boot_closure_body (SCM clo)
+{
+ return CAR (boot_closure_code (clo));
+}
+
+static inline int
+boot_closure_num_required_args (SCM clo)
+{
+ return SCM_I_INUM (CADDR (boot_closure_code (clo)));
+}
+
+static inline int
+boot_closure_is_fixed (SCM clo)
+{
+ return scm_is_null (CDDDR (boot_closure_code (clo)));
+}
+
/* NB: One may only call the following accessors if the closure is not FIXED.
*/
-#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR
(BOOT_CLOSURE_CODE (x))))
-#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE
(x))))
-/* NB: One may only call the following accessors if the closure is not REST. */
-#define BOOT_CLOSURE_IS_FULL(x) (1)
+static inline int
+boot_closure_has_rest_args (SCM clo)
+{
+ return scm_is_true (CADDR (SCM_CDR (boot_closure_code (clo))));
+}
+
+static inline int
+boot_closure_is_rest (SCM clo)
+{
+ return scm_is_null (SCM_CDR (CDDDR (boot_closure_code (clo))));
+}
+
+/* NB: One may only call the following accessor if the closure is not REST. */
#define
BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
do { SCM fu = fu_; \
body = CAR (fu); fu = CDDR (fu); \
@@ -140,6 +193,7 @@ static scm_t_bits scm_tc16_boot_closure;
} \
} \
} while (0)
+
static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
SCM *out_body, SCM *out_env);
static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
@@ -147,19 +201,6 @@ static void prepare_boot_closure_env_for_eval (SCM proc,
unsigned int argc,
SCM *inout_env);
-#define CAR(x) SCM_CAR(x)
-#define CDR(x) SCM_CDR(x)
-#define CAAR(x) SCM_CAAR(x)
-#define CADR(x) SCM_CADR(x)
-#define CDAR(x) SCM_CDAR(x)
-#define CDDR(x) SCM_CDDR(x)
-#define CADDR(x) SCM_CADDR(x)
-#define CDDDR(x) SCM_CDDDR(x)
-
-#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
-#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
-#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
-
static SCM
make_env (int n, SCM init, SCM next)
{
@@ -286,7 +327,16 @@ eval (SCM x, SCM env)
}
case SCM_M_LAMBDA:
- RETURN_BOOT_CLOSURE (mx, env);
+ {
+ struct scm_program *ret =
+ scm_make_subr_from_code (SCM_I_CURRENT_THREAD,
+ apply_boot_closure_code,
+ SCM_F_PROGRAM_IS_PRIMITIVE,
+ 2);
+ scm_program_free_variable_set_x (ret, 0, mx);
+ scm_program_free_variable_set_x (ret, 1, env);
+ return scm_from_program (ret);
+ }
case SCM_M_CAPTURE_ENV:
{
@@ -325,7 +375,7 @@ eval (SCM x, SCM env)
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
- if (BOOT_CLOSURE_P (proc))
+ if (is_boot_closure (proc))
{
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
@@ -339,7 +389,7 @@ eval (SCM x, SCM env)
argc = scm_ilength (CDR (mx));
mx = CDR (mx);
- if (BOOT_CLOSURE_P (proc))
+ if (is_boot_closure (proc))
{
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
@@ -733,13 +783,13 @@ static void
prepare_boot_closure_env_for_apply (SCM proc, SCM args,
SCM *out_body, SCM *out_env)
{
- int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM env = BOOT_CLOSURE_ENV (proc);
+ int nreq = boot_closure_num_required_args (proc);
+ SCM env = boot_closure_env (proc);
int i;
- if (BOOT_CLOSURE_IS_FIXED (proc)
- || (BOOT_CLOSURE_IS_REST (proc)
- && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
+ if (boot_closure_is_fixed (proc)
+ || (boot_closure_is_rest (proc)
+ && !boot_closure_has_rest_args (proc)))
{
if (SCM_UNLIKELY (scm_ilength (args) != nreq))
scm_wrong_num_args (proc);
@@ -747,10 +797,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
env = make_env (nreq, SCM_UNDEFINED, env);
for (i = 0; i < nreq; args = CDR (args), i++)
env_set (env, 0, i, CAR (args));
- *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_body = boot_closure_body (proc);
*out_env = env;
}
- else if (BOOT_CLOSURE_IS_REST (proc))
+ else if (boot_closure_is_rest (proc))
{
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
scm_wrong_num_args (proc);
@@ -760,14 +810,14 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
env_set (env, 0, i, CAR (args));
env_set (env, 0, i++, args);
- *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_body = boot_closure_body (proc);
*out_env = env;
}
else
{
int i, argc, nreq, nopt, ninits, nenv;
SCM body, rest, kw, unbound, alt;
- SCM mx = BOOT_CLOSURE_CODE (proc);
+ SCM mx = boot_closure_code (proc);
loop:
BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
@@ -896,11 +946,11 @@ static void
prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
SCM exps, SCM *out_body, SCM *inout_env)
{
- int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = BOOT_CLOSURE_ENV (proc);
- if ((BOOT_CLOSURE_IS_FIXED (proc)
- || (BOOT_CLOSURE_IS_REST (proc)
- && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
+ int nreq = boot_closure_num_required_args (proc);
+ SCM new_env = boot_closure_env (proc);
+ if ((boot_closure_is_fixed (proc)
+ || (boot_closure_is_rest (proc)
+ && !boot_closure_has_rest_args (proc)))
&& nreq == argc)
{
int i;
@@ -909,11 +959,11 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int
argc,
for (i = 0; i < nreq; exps = CDR (exps), i++)
env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
- *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_body = boot_closure_body (proc);
*inout_env = new_env;
}
- else if (!BOOT_CLOSURE_IS_FIXED (proc) &&
- BOOT_CLOSURE_IS_REST (proc) && argc >= nreq)
+ else if (!boot_closure_is_fixed (proc) &&
+ boot_closure_is_rest (proc) && argc >= nreq)
{
SCM rest;
int i;
@@ -925,7 +975,7 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int
argc,
rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
- *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_body = boot_closure_body (proc);
*inout_env = new_env;
}
else
@@ -939,30 +989,13 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int
argc,
}
static SCM
-boot_closure_apply (SCM closure, SCM args)
+apply_boot_closure (SCM closure, SCM args)
{
SCM body, env;
prepare_boot_closure_env_for_apply (closure, args, &body, &env);
return eval (body, env);
}
-static int
-boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
-{
- SCM args;
- scm_puts ("#<boot-closure ", port);
- scm_uintprint (SCM_UNPACK (closure), 16, port);
- scm_putc (' ', port);
- args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS
(closure)),
- scm_from_latin1_symbol ("_"));
- if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
- args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
- /* FIXME: optionals and rests */
- scm_display (args, port);
- scm_putc ('>', port);
- return 1;
-}
-
void
scm_init_eval ()
{
@@ -970,9 +1003,9 @@ scm_init_eval ()
f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
- scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
- scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
- scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
+ apply_boot_closure_code =
+ scm_allocate_subr_code (scm_from_utf8_symbol ("boot-closure"), 0, 0, 1,
+ apply_boot_closure, SCM_F_SUBR_CLOSURE);
primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
scm_c_primitive_eval);
