wingo pushed a commit to branch wip-whippet
in repository guile.
commit 464ec999dee68f886f27d0e1b5a1f5d4f8555764
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Fri May 30 12:40:52 2025 +0200
Make programs.h private
This header file turns out to only have internal details. Users that
need introspection can use Scheme.
* libguile/programs.h (SCM_PROGRAM_P, SCM_PROGRAM_CODE)
(SCM_PROGRAM_FREE_VARIABLES, SCM_PROGRAM_FREE_VARIABLE_REF)
(SCM_PROGRAM_FREE_VARIABLE_SET, SCM_PROGRAM_NUM_FREE_VARIABLES)
(SCM_VALIDATE_PROGRAM, SCM_F_PROGRAM_IS_BOOT, SCM_F_PROGRAM_IS_PRIMITIVE)
(SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC, SCM_F_PROGRAM_IS_CONTINUATION)
(SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION, SCM_F_PROGRAM_IS_FOREIGN)
(SCM_PROGRAM_IS_BOOT, SCM_PROGRAM_IS_PRIMITIVE)
(SCM_PROGRAM_IS_PRIMITIVE_GENERIC, SCM_PROGRAM_IS_CONTINUATION)
(SCM_PROGRAM_IS_PARTIAL_CONTINUATION, SCM_PROGRAM_IS_FOREIGN): Remove
these macros, as we are making this whole API private.
(struct scm_program, scm_is_program, scm_to_program, scm_from_program)
(scm_program_flags, scm_program_is_boot, scm_program_is_primitive)
(scm_program_is_primitive_generic, scm_program_is_continuation)
(scm_program_is_partial_continuation, scm_program_is_foreign)
(scm_program_code, scm_program_free_variable_count)
(scm_program_free_variable_ref, scm_program_free_variable_set_x)
(scm_i_make_program): New inline functions.
* libguile/Makefile.am (noinst_HEADERS): Add programs.h; no longer
installed. It was never directly included from libguile.h.
* libguile/continuations.c:
* libguile/continuations.h:
* libguile/control.c:
* libguile/foreign.c:
* libguile/frames.c:
* libguile/frames.h:
* libguile/goops.c:
* libguile/gsubr.c:
* libguile/gsubr.h:
* libguile/intrinsics.h:
* libguile/procprop.c:
* libguile/procs.c:
* libguile/programs.c:
* libguile/stacks.c:
* libguile/vm-engine.c:
* libguile/vm.c:
* libguile/vm.h: Adapt all users.
---
libguile/Makefile.am | 2 +-
libguile/continuations.c | 17 ++++---
libguile/continuations.h | 4 --
libguile/control.c | 15 +++---
libguile/foreign.c | 16 +++---
libguile/frames.c | 1 +
libguile/frames.h | 1 -
libguile/goops.c | 12 ++---
libguile/gsubr.c | 57 ++++++++++++++++-----
libguile/gsubr.h | 22 ++++-----
libguile/intrinsics.h | 2 +-
libguile/procprop.c | 8 +--
libguile/procs.c | 4 +-
libguile/programs.c | 39 ++++++++++-----
libguile/programs.h | 126 ++++++++++++++++++++++++++++++++++++-----------
libguile/stacks.c | 59 +++++++++++++---------
libguile/vm-engine.c | 22 +++++----
libguile/vm.c | 24 +++++----
libguile/vm.h | 1 -
19 files changed, 289 insertions(+), 143 deletions(-)
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 929c0ba63..8b5f7a238 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -530,6 +530,7 @@ noinst_HEADERS = custom-ports.h
\
gc-internal.h \
posix-w32.h \
private-options.h \
+ programs.h \
ports-internal.h \
syntax.h \
trace.h \
@@ -658,7 +659,6 @@ modinclude_HEADERS = \
print.h \
procprop.h \
procs.h \
- programs.h \
promises.h \
pthread-threads.h \
r6rs-ports.h \
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 074fc748e..847d6bf70 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -46,6 +46,7 @@
#include "numbers.h"
#include "pairs.h"
#include "ports.h"
+#include "programs.h"
#include "smob.h"
#include "stackchk.h"
#include "stacks.h"
@@ -99,15 +100,18 @@ struct goto_continuation_code goto_continuation_code = {
static SCM
make_continuation_trampoline (SCM contregs)
{
- SCM ret;
scm_t_bits nfree = 1;
scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION;
+ scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
- SCM_SET_CELL_WORD_1 (ret, goto_continuation_code.code);
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, contregs);
+ 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 = goto_continuation_code.code;
+ ret->free_variables[0] = contregs;
- return ret;
+ return scm_from_program (ret);
}
@@ -218,7 +222,8 @@ scm_i_continuation_to_frame (SCM continuation, struct
scm_frame *frame)
SCM contregs;
scm_t_contregs *cont;
- contregs = SCM_PROGRAM_FREE_VARIABLE_REF (continuation, 0);
+ struct scm_program *program = scm_to_program (continuation);
+ contregs = scm_program_free_variable_ref (program, 0);
cont = SCM_CONTREGS (contregs);
if (cont->vm_cont)
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 260ce7d90..298b1d032 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -28,14 +28,10 @@
#include "libguile/setjump-win.h"
#endif
-#include "libguile/programs.h"
#include "libguile/throw.h"
-#define SCM_CONTINUATIONP(x) \
- (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x))
-
/* a continuation SCM is a non-immediate pointing to a heap cell with:
word 0: bits 0-15: smob type tag: scm_tc16_continuation.
bits 16-31: unused.
diff --git a/libguile/control.c b/libguile/control.c
index 5e24bb706..a128a3973 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -1,4 +1,4 @@
-/* Copyright 2010-2013,2018
+/* Copyright 2010-2013,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -95,13 +95,16 @@ scm_i_make_composable_continuation (SCM vmcont)
{
scm_t_bits nfree = 1;
scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
- SCM ret;
+ scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
- SCM_SET_CELL_WORD_1 (ret, compose_continuation_code.code);
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vmcont);
+ 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 = compose_continuation_code.code;
+ ret->free_variables[0] = vmcont;
- return ret;
+ return scm_from_program (ret);
}
SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 1760ac53d..ee6fc28b3 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -49,6 +49,7 @@
#include "numbers.h"
#include "pairs.h"
#include "ports.h"
+#include "programs.h"
#include "stacks.h"
#include "symbols.h"
#include "threads.h"
@@ -943,18 +944,21 @@ static SCM
cif_to_procedure (SCM cif, SCM func_ptr, int with_errno)
{
ffi_cif *c_cif;
- SCM ret;
scm_t_bits nfree = 2;
scm_t_bits flags = SCM_F_PROGRAM_IS_FOREIGN;
+ scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
- SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs, with_errno));
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif);
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr);
+ 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_foreign_stub_code (c_cif->nargs, with_errno);
+ ret->free_variables[0] = cif;
+ ret->free_variables[1] = func_ptr;
- return ret;
+ return scm_from_program (ret);
}
/* Set *LOC to the foreign representation of X with TYPE. */
diff --git a/libguile/frames.c b/libguile/frames.c
index 63e7505ae..879164a25 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -33,6 +33,7 @@
#include "numbers.h"
#include "pairs.h"
#include "ports.h"
+#include "programs.h"
#include "symbols.h"
#include "threads.h"
#include "variable.h"
diff --git a/libguile/frames.h b/libguile/frames.h
index db35893f6..8bf76b470 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -23,7 +23,6 @@
#include <string.h>
#include <libguile/gc.h>
-#include "programs.h"
/* Stack frames
diff --git a/libguile/goops.c b/libguile/goops.c
index 975c3dd29..d5fffd04d 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -282,8 +282,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_fraction;
}
case scm_tc7_program:
- if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
- && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
+ if (scm_program_is_primitive_generic (scm_to_program (x))
+ && SCM_UNPACK (*scm_subr_generic (x)))
return class_primitive_generic;
else
return class_procedure;
@@ -578,7 +578,7 @@ SCM_DEFINE (scm_enable_primitive_generic_x,
"enable-primitive-generic!", 0, 0, 1
{
SCM subr = SCM_CAR (subrs);
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
- SCM_SET_SUBR_GENERIC (subr,
+ scm_set_subr_generic (subr,
scm_make (scm_list_3 (class_generic,
k_name,
SCM_SUBR_NAME (subr))));
@@ -595,7 +595,7 @@ SCM_DEFINE (scm_set_primitive_generic_x,
"set-primitive-generic!", 2, 0, 0,
{
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
- SCM_SET_SUBR_GENERIC (subr, generic);
+ scm_set_subr_generic (subr, generic);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -607,9 +607,9 @@ SCM_DEFINE (scm_primitive_generic_generic,
"primitive-generic-generic", 1, 0, 0,
{
if (SCM_PRIMITIVE_GENERIC_P (subr))
{
- if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
+ if (!SCM_UNPACK (*scm_subr_generic (subr)))
scm_enable_primitive_generic_x (scm_list_1 (subr));
- return *SCM_SUBR_GENERIC (subr);
+ return *scm_subr_generic (subr);
}
SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
}
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index a33cbb9c4..7a69523d4 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2001,2006,2008-2011,2013,2015,2018-2019
+/* Copyright 1995-2001,2006,2008-2011,2013,2015,2018-2019,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -336,7 +336,7 @@ create_subr (int define, const char *name,
unsigned int nreq, unsigned int nopt, unsigned int rest,
void *fcn, SCM *generic_loc)
{
- SCM ret, sname;
+ SCM sname;
uint32_t idx;
scm_t_bits flags;
scm_t_bits nfree = generic_loc ? 1 : 0;
@@ -347,17 +347,50 @@ create_subr (int define, const char *name,
flags = SCM_F_PROGRAM_IS_PRIMITIVE;
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
- SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (idx, nreq, nopt, rest));
+ scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
+
+ 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);
if (generic_loc)
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0,
- scm_from_pointer (generic_loc, NULL));
+ scm_program_free_variable_set_x (ret, 0,
+ scm_from_pointer (generic_loc, NULL));
if (define)
- scm_define (sname, ret);
+ scm_define (sname, scm_from_program (ret));
- return ret;
+ return scm_from_program (ret);
+}
+
+int
+scm_is_primitive (SCM x)
+{
+ return scm_is_program (x) && scm_program_is_primitive (scm_to_program (x));
+}
+
+int
+scm_is_primitive_generic (SCM x)
+{
+ return scm_is_program (x) &&
+ scm_program_is_primitive_generic (scm_to_program (x));
+}
+
+SCM*
+scm_subr_generic (SCM subr)
+{
+ if (!scm_is_primitive_generic (subr))
+ abort ();
+ struct scm_program *p = scm_to_program (subr);
+ return (SCM*) SCM_POINTER_VALUE (scm_program_free_variable_ref (p, 0));
+}
+
+void
+scm_set_subr_generic (SCM subr, SCM g)
+{
+ *scm_subr_generic (subr) = g;
}
int
@@ -429,9 +462,9 @@ primitive_subr_idx (const uint32_t *code)
}
uintptr_t
-scm_i_primitive_call_ip (SCM subr)
+scm_i_primitive_call_ip (struct scm_program *subr)
{
- return primitive_call_ip (SCM_PROGRAM_CODE (subr));
+ return primitive_call_ip (scm_program_code (subr));
}
SCM
@@ -454,14 +487,14 @@ scm_subr_function_by_index (uint32_t idx)
scm_t_subr
scm_subr_function (SCM subr)
{
- uint32_t idx = primitive_subr_idx (SCM_PROGRAM_CODE (subr));
+ uint32_t idx = primitive_subr_idx (scm_program_code (scm_to_program (subr)));
return scm_subr_function_by_index (idx);
}
SCM
scm_subr_name (SCM subr)
{
- return scm_i_primitive_name (SCM_PROGRAM_CODE (subr));
+ return scm_i_primitive_name (scm_program_code (scm_to_program (subr)));
}
SCM
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 462286c48..d6217d52e 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -1,7 +1,7 @@
#ifndef SCM_GSUBR_H
#define SCM_GSUBR_H
-/* Copyright 1995-1996,1998,2000-2001,2006,2008,2009-2011,2013,2015,2018
+/* Copyright 1995-1996,1998,2000-2001,2006,2008,2009-2011,2013,2015,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -34,31 +34,31 @@
/* Max number of args to the C procedure backing a gsubr */
#define SCM_GSUBR_MAX 10
-#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
-
-#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) &&
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
+#define SCM_PRIMITIVE_P(x) (scm_is_primitive (x))
+#define SCM_PRIMITIVE_GENERIC_P(x) (scm_is_primitive_generic (x))
#define SCM_SUBRF(x) scm_subr_function (x)
#define SCM_SUBR_NAME(x) scm_subr_name (x)
-#define SCM_SUBR_GENERIC(x) \
- ((SCM *) SCM_POINTER_VALUE (SCM_PROGRAM_FREE_VARIABLE_REF (x, 0)))
-
-#define SCM_SET_SUBR_GENERIC(x, g) \
- (*SCM_SUBR_GENERIC (x) = (g))
-
+struct scm_program;
+
SCM_INTERNAL uint32_t *
scm_i_alloc_primitive_code_with_instrumentation (size_t uint32_count,
uint32_t **write_ptr);
SCM_INTERNAL int scm_i_primitive_code_p (const uint32_t *code);
-SCM_INTERNAL uintptr_t scm_i_primitive_call_ip (SCM subr);
+SCM_INTERNAL uintptr_t scm_i_primitive_call_ip (struct scm_program *subr);
SCM_INTERNAL SCM scm_i_primitive_name (const uint32_t *code);
+SCM_INTERNAL int scm_is_primitive (SCM x);
+SCM_INTERNAL int scm_is_primitive_generic (SCM x);
+
SCM_API scm_t_subr scm_subr_function (SCM subr);
SCM_INTERNAL scm_t_subr scm_subr_function_by_index (uint32_t subr_idx);
SCM_API SCM scm_subr_name (SCM subr);
+SCM_INTERNAL SCM* scm_subr_generic (SCM x);
+SCM_INTERNAL void scm_set_subr_generic (SCM x, SCM g);
SCM_INTERNAL SCM scm_apply_subr (union scm_vm_stack_element *sp,
uint32_t subr_idx, ptrdiff_t nargs);
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 5194ff4c4..f380bda43 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -92,7 +92,7 @@ typedef void (*scm_t_thread_u8_scm_sp_vra_mra_intrinsic)
(scm_thread*,
const union
scm_vm_stack_element*,
uint32_t*, uint8_t*);
typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, uint8_t*);
-typedef uint32_t* (*scm_t_vra_from_thread_intrinsic) (scm_thread*);
+typedef const uint32_t* (*scm_t_vra_from_thread_intrinsic) (scm_thread*);
typedef uint8_t* (*scm_t_mra_from_thread_scm_intrinsic) (scm_thread*, SCM);
typedef uint8_t* (*scm_t_mra_from_thread_mra_intrinsic) (scm_thread*,
uint8_t*);
typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index a86de57ed..51a7a1d0f 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -67,7 +67,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
return 1;
}
- while (!SCM_PROGRAM_P (proc))
+ while (!scm_is_program (proc))
{
if (SCM_STRUCTP (proc))
{
@@ -153,7 +153,7 @@ SCM_DEFINE (scm_procedure_properties,
"procedure-properties", 1, 0, 0,
if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props)))
return scm_cdr (user_props);
- if (SCM_PROGRAM_P (proc))
+ if (scm_is_program (proc))
ret = scm_i_program_properties (proc);
else
ret = SCM_EOL;
@@ -265,7 +265,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
return SCM_BOOL_F;
}
- if (SCM_PROGRAM_P (proc))
+ if (scm_is_program (proc))
return scm_i_program_name (proc);
else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
@@ -302,7 +302,7 @@ SCM_DEFINE (scm_procedure_documentation,
"procedure-documentation", 1, 0, 0,
return SCM_BOOL_F;
}
- if (SCM_PROGRAM_P (proc))
+ if (scm_is_program (proc))
return scm_i_program_documentation (proc);
else
return SCM_BOOL_F;
diff --git a/libguile/procs.c b/libguile/procs.c
index 6a2860e6a..c9eafcab4 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-1997,1999-2001,2006,2008-2013,2017-2018,2020
+/* Copyright 1995-1997,1999-2001,2006,2008-2013,2017-2018,2020,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -49,7 +49,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
"Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p
{
- return scm_from_bool (SCM_PROGRAM_P (obj)
+ return scm_from_bool (scm_is_program (obj)
|| (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
|| (SCM_HAS_TYP7 (obj, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (obj)));
diff --git a/libguile/programs.c b/libguile/programs.c
index eb814f802..75c8f74c0 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -40,6 +40,13 @@
#include "programs.h"
+
+
+
+#define SCM_PROGRAM_P(x) (scm_is_program (x))
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+
+
static SCM write_program = SCM_BOOL_F;
@@ -49,8 +56,9 @@ SCM_DEFINE_STATIC (program_code, "program-code", 1, 0, 0,
#define FUNC_NAME s_program_code
{
SCM_VALIDATE_PROGRAM (1, program);
+ struct scm_program *p = scm_to_program (program);
- return scm_from_uintptr_t ((uintptr_t) SCM_PROGRAM_CODE (program));
+ return scm_from_uintptr_t ((uintptr_t) scm_program_code (p));
}
#undef FUNC_NAME
@@ -60,7 +68,7 @@ scm_i_program_name (SCM program)
static SCM program_name = SCM_BOOL_F;
if (SCM_PRIMITIVE_P (program))
- return scm_i_primitive_name (SCM_PROGRAM_CODE (program));
+ return scm_i_primitive_name (scm_to_program (program)->code);
if (scm_is_false (program_name) && scm_module_system_booted_p)
program_name =
@@ -113,14 +121,15 @@ scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate)
write_program = scm_c_private_variable ("system vm program",
"write-program");
- if (SCM_PROGRAM_IS_CONTINUATION (program))
+ struct scm_program *p = scm_to_program (program);
+ if (scm_program_is_continuation (p))
{
/* twingliness */
scm_puts ("#<continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc ('>', port);
}
- else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
+ else if (scm_program_is_partial_continuation (p))
{
/* twingliness */
scm_puts ("#<partial-continuation ", port);
@@ -132,7 +141,7 @@ scm_i_program_print (SCM program, SCM port, scm_print_state
*pstate)
scm_puts ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc (' ', port);
- scm_uintprint ((uintptr_t) SCM_PROGRAM_CODE (program), 16, port);
+ scm_uintprint ((uintptr_t) p->code, 16, port);
scm_putc ('>', port);
}
else
@@ -153,7 +162,7 @@ SCM_DEFINE_STATIC (program_p, "program?", 1, 0, 0,
"")
#define FUNC_NAME s_program_p
{
- return scm_from_bool (SCM_PROGRAM_P (obj));
+ return scm_from_bool (scm_is_program (obj));
}
#undef FUNC_NAME
@@ -177,7 +186,7 @@ SCM_DEFINE_STATIC (primitive_call_ip, "primitive-call-ip",
1, 0, 0,
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
- ip = scm_i_primitive_call_ip (prim);
+ ip = scm_i_primitive_call_ip (scm_to_program (prim));
return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -230,8 +239,9 @@ SCM_DEFINE_STATIC (program_num_free_variables,
"program-num-free-variables",
#define FUNC_NAME s_program_num_free_variables
{
SCM_VALIDATE_PROGRAM (1, program);
+ struct scm_program *p = scm_to_program (program);
- return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
+ return scm_from_ulong (scm_program_free_variable_count (p));
}
#undef FUNC_NAME
@@ -244,9 +254,10 @@ SCM_DEFINE_STATIC (program_free_variable_ref,
"program-free-variable-ref",
SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ struct scm_program *p = scm_to_program (program);
+ if (idx >= scm_program_free_variable_count (p))
SCM_OUT_OF_RANGE (2, i);
- return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
+ return scm_program_free_variable_ref (p, idx);
}
#undef FUNC_NAME
@@ -259,9 +270,11 @@ SCM_DEFINE_STATIC (program_free_variable_set_x,
"program-free-variable-set!",
SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ struct scm_program *p = scm_to_program (program);
+ if (idx >= scm_program_free_variable_count (p))
SCM_OUT_OF_RANGE (2, i);
- SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
+
+ scm_program_free_variable_set_x (p, idx, x);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -270,7 +283,7 @@ SCM_DEFINE_STATIC (program_free_variable_set_x,
"program-free-variable-set!",
static int
try_parse_arity (SCM program, int *req, int *opt, int *rest)
{
- uint32_t *code = SCM_PROGRAM_CODE (program);
+ const uint32_t *code = scm_program_code (scm_to_program (program));
uint32_t slots, min;
if ((code[0] & 0xff) == scm_op_instrument_entry)
diff --git a/libguile/programs.h b/libguile/programs.h
index c3f3dc1c9..8554f7d69 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -26,41 +26,111 @@
* Programs
*/
-#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program))
-#define SCM_PROGRAM_CODE(x) ((uint32_t *) SCM_CELL_WORD_1 (x))
-#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 2))
-#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
-#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES
(x)[i]=(v))
-#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
-#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
-
-#define SCM_F_PROGRAM_IS_BOOT 0x100
-#define SCM_F_PROGRAM_IS_PRIMITIVE 0x200
-#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
-#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
-#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
-#define SCM_F_PROGRAM_IS_FOREIGN 0x2000
-
-#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
-#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PRIMITIVE)
-#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
-#define SCM_PROGRAM_IS_CONTINUATION(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_CONTINUATION)
-#define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION)
-#define SCM_PROGRAM_IS_FOREIGN(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_FOREIGN)
-
-#ifdef BUILDING_LIBGUILE
+struct scm_program
+{
+ scm_t_bits tag_flags_and_free_variable_count;
+ const uint32_t *code;
+ SCM free_variables[];
+};
+
+static inline int
+scm_is_program (SCM x)
+{
+ return SCM_HAS_TYP7 (x, scm_tc7_program);
+}
+
+static inline struct scm_program*
+scm_to_program (SCM x)
+{
+ if (!scm_is_program (x))
+ abort ();
+ return (struct scm_program*) SCM_UNPACK_POINTER (x);
+}
+
static inline SCM
-scm_i_make_program (const uint32_t *code)
+scm_from_program (struct scm_program *program)
{
- return scm_cell (scm_tc7_program, (scm_t_bits)code);
+ return SCM_PACK_POINTER (program);
+}
+
+enum scm_program_flags
+ {
+ SCM_F_PROGRAM_IS_BOOT = 0x100,
+ SCM_F_PROGRAM_IS_PRIMITIVE = 0x200,
+ SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC = 0x400,
+ SCM_F_PROGRAM_IS_CONTINUATION = 0x800,
+ SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION = 0x1000,
+ SCM_F_PROGRAM_IS_FOREIGN = 0x2000
+ };
+
+static inline scm_t_bits
+scm_program_flags (struct scm_program *program)
+{
+ return program->tag_flags_and_free_variable_count & 0xff00;
}
static inline int
-scm_is_program (SCM x)
+scm_program_is_boot (struct scm_program *program)
+{
+ return scm_program_flags (program) & SCM_F_PROGRAM_IS_BOOT;
+}
+static inline int
+scm_program_is_primitive (struct scm_program *program)
+{
+ return scm_program_flags (program) & SCM_F_PROGRAM_IS_PRIMITIVE;
+}
+static inline int
+scm_program_is_primitive_generic (struct scm_program *program)
+{
+ return scm_program_flags (program) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC;
+}
+static inline int
+scm_program_is_continuation (struct scm_program *program)
+{
+ return scm_program_flags (program) & SCM_F_PROGRAM_IS_CONTINUATION;
+}
+static inline int
+scm_program_is_partial_continuation (struct scm_program *program)
+{
+ return scm_program_flags (program) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
+}
+static inline int
+scm_program_is_foreign (struct scm_program *program)
+{
+ return scm_program_flags (program) & SCM_F_PROGRAM_IS_FOREIGN;
+}
+
+static inline const uint32_t*
+scm_program_code (struct scm_program *program)
+{
+ return program->code;
+}
+
+static inline size_t
+scm_program_free_variable_count (struct scm_program *program)
+{
+ return program->tag_flags_and_free_variable_count >> 16;
+}
+static inline SCM
+scm_program_free_variable_ref (struct scm_program *program, size_t idx)
+{
+ return program->free_variables[idx];
+}
+static inline void
+scm_program_free_variable_set_x (struct scm_program *program, size_t idx, SCM
v)
+{
+ program->free_variables[idx] = v;
+}
+
+static inline SCM
+scm_i_make_program (const uint32_t *code)
{
- return SCM_PROGRAM_P (x);
+ struct scm_program *ret =
+ scm_gc_malloc_pointerless (sizeof (struct scm_program), "program");
+ ret->tag_flags_and_free_variable_count = scm_tc7_program;
+ ret->code = code;
+ return scm_from_program (ret);
}
-#endif
SCM_INTERNAL SCM scm_i_program_name (SCM program);
SCM_INTERNAL SCM scm_i_program_documentation (SCM program);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 2f5273e03..be4f5873d 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -39,6 +39,7 @@
#include "pairs.h"
#include "private-options.h"
#include "procprop.h"
+#include "programs.h"
#include "strings.h"
#include "struct.h"
#include "symbols.h"
@@ -337,26 +338,37 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
kind = scm_vm_frame_kind (f);
scm_frame_init_from_vm_frame (&frame, f);
}
- else if (SCM_CONTINUATIONP (obj))
- /* FIXME: Narrowing to prompt tags should narrow with respect to the
prompts
- that were in place when the continuation was captured. */
+ else if (scm_is_program (obj))
{
- kind = SCM_VM_FRAME_KIND_CONT;
- if (!scm_i_continuation_to_frame (obj, &frame))
- return SCM_BOOL_F;
- }
- else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
- {
- kind = SCM_VM_FRAME_KIND_CONT;
- if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
- &frame))
- return SCM_BOOL_F;
+ struct scm_program *program = scm_to_program (obj);
+ if (scm_program_is_continuation (program))
+ /* FIXME: Narrowing to prompt tags should narrow with respect to
+ the prompts that were in place when the continuation was
+ captured. */
+ {
+ kind = SCM_VM_FRAME_KIND_CONT;
+ if (!scm_i_continuation_to_frame (obj, &frame))
+ return SCM_BOOL_F;
+ }
+ else if (scm_program_is_partial_continuation (program))
+ {
+ kind = SCM_VM_FRAME_KIND_CONT;
+ if (!scm_i_vm_cont_to_frame (scm_program_free_variable_ref (program,
0),
+ &frame))
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
+ /* not reached */
+ }
}
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
/* not reached */
}
+
/* Skip initial boot frame, if any. This is possible if the frame
originates from a captured continuation. */
@@ -416,17 +428,20 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
SCM stacks = scm_fluid_ref (scm_sys_stacks);
return scm_is_pair (stacks) ? scm_car (stacks) : SCM_BOOL_F;
}
- else if (SCM_CONTINUATIONP (stack))
- /* FIXME: implement me */
- return SCM_BOOL_F;
- else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION
(stack))
- /* FIXME: implement me */
- return SCM_BOOL_F;
- else
+ else if (scm_is_program (stack))
{
- SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
- /* not reached */
+ struct scm_program *p = scm_to_program (stack);
+ if (scm_program_is_continuation (p))
+ /* FIXME: implement me */
+ return SCM_BOOL_F;
+ else if (scm_program_is_partial_continuation (p))
+ /* FIXME: implement me */
+ return SCM_BOOL_F;
+ /* Fall through. */
}
+
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
+ /* not reached */
}
#undef FUNC_NAME
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 37e290fe5..18e539fd8 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -454,7 +454,8 @@ VM_NAME (scm_thread *thread)
VP->fp = new_fp;
RESET_FRAME (nlocals);
- ip = CALL_INTRINSIC (get_callee_vcode, (thread));
+ /* FIXME: Don't strip const qualifier. */
+ ip = (uint32_t *) CALL_INTRINSIC (get_callee_vcode, (thread));
CACHE_SP ();
NEXT (0);
@@ -502,7 +503,8 @@ VM_NAME (scm_thread *thread)
*/
VM_DEFINE_OP (5, tail_call, "tail-call", OP1 (X32))
{
- ip = CALL_INTRINSIC (get_callee_vcode, (thread));
+ /* FIXME: Don't strip const qualifier. */
+ ip = (uint32_t *) CALL_INTRINSIC (get_callee_vcode, (thread));
CACHE_SP ();
NEXT (0);
}
@@ -996,13 +998,14 @@ VM_NAME (scm_thread *thread)
VM_DEFINE_OP (29, foreign_call, "foreign-call", OP1 (X8_C12_C12))
{
uint16_t cif_idx, ptr_idx;
- SCM closure, cif, pointer;
+ struct scm_program *closure;
+ SCM cif, pointer;
UNPACK_12_12 (op, cif_idx, ptr_idx);
- closure = FP_REF (0);
- cif = SCM_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
- pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
+ closure = scm_to_program (FP_REF (0));
+ cif = scm_program_free_variable_ref (closure, cif_idx);
+ pointer = scm_program_free_variable_ref (closure, ptr_idx);
SYNC_IP ();
CALL_INTRINSIC (foreign_call, (thread, cif, pointer));
@@ -1026,8 +1029,8 @@ VM_NAME (scm_thread *thread)
UNPACK_24 (op, contregs_idx);
- contregs =
- SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), contregs_idx);
+ struct scm_program *closure = scm_to_program (FP_REF (0));
+ contregs = scm_program_free_variable_ref (closure, contregs_idx);
SYNC_IP ();
CALL_INTRINSIC (reinstate_continuation_x, (thread, contregs));
@@ -1051,7 +1054,8 @@ VM_NAME (scm_thread *thread)
uint8_t *mcode;
UNPACK_24 (op, cont_idx);
- vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), cont_idx);
+ struct scm_program *closure = scm_to_program (FP_REF (0));
+ vmcont = scm_program_free_variable_ref (closure, cont_idx);
SYNC_IP ();
mcode = CALL_INTRINSIC (compose_continuation, (thread, vmcont));
diff --git a/libguile/vm.c b/libguile/vm.c
index 1fcadab98..5b7cf0fcd 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -485,9 +485,12 @@ define_vm_builtins (void)
{ \
size_t sz = sizeof (builtin##_code); \
vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \
- vm_builtin_##builtin = \
- scm_cell (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE, \
- (scm_t_bits)vm_builtin_##builtin##_code); \
+ struct scm_program *p = \
+ scm_gc_malloc_pointerless (sizeof (struct scm_program), "builtin"); \
+ scm_t_bits tag = scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE; \
+ p->tag_flags_and_free_variable_count = tag; \
+ p->code = vm_builtin_##builtin##_code; \
+ vm_builtin_##builtin = scm_from_program (p); \
}
FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
#undef INDEX_TO_NAME
@@ -1453,23 +1456,23 @@ abort_to_prompt (scm_thread *thread, uint8_t *saved_mra)
return mra;
}
-static uint32_t *
+static const uint32_t *
get_callee_vcode (scm_thread *thread)
{
struct scm_vm *vp = &thread->vm;
SCM proc = SCM_FRAME_LOCAL (vp->fp, 0);
- if (SCM_LIKELY (SCM_PROGRAM_P (proc)))
- return SCM_PROGRAM_CODE (proc);
+ if (SCM_LIKELY (scm_is_program (proc)))
+ return scm_program_code (scm_to_program (proc));
while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
SCM_FRAME_LOCAL (vp->fp, 0) = proc;
- if (SCM_PROGRAM_P (proc))
- return SCM_PROGRAM_CODE (proc);
+ if (scm_is_program (proc))
+ return scm_program_code (scm_to_program (proc));
}
if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
@@ -1486,7 +1489,7 @@ get_callee_vcode (scm_thread *thread)
proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
SCM_FRAME_LOCAL (vp->fp, 0) = proc;
- return SCM_PROGRAM_CODE (proc);
+ return scm_program_code (scm_to_program (proc));
}
vp->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp);
@@ -1567,7 +1570,8 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
#endif
}
else
- vp->ip = get_callee_vcode (thread);
+ /* FIXME: Don't strip const qualifier. */
+ vp->ip = (uint32_t *) get_callee_vcode (thread);
ret = vm_engines[vp->engine](thread);
thread->vm.registers = prev_registers;
diff --git a/libguile/vm.h b/libguile/vm.h
index d44456c0e..a32aee24e 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -28,7 +28,6 @@
#include <libguile/gc.h>
#include <libguile/frames.h>
-#include <libguile/programs.h>
#define SCM_VM_REGULAR_ENGINE 0
#define SCM_VM_DEBUG_ENGINE 1
