wingo pushed a commit to branch wip-whippet
in repository guile.
commit ccaff3da3927061195fbf296dd792da2d7837be3
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue Jun 17 10:36:32 2025 +0200
Allocate a static tc16 for random states
* libguile/random.h (scm_t_rstate): Put a tag word in the beginning.
(scm_is_random_state, scm_to_random_state, scm_from_random_state): New
helpers.
(SCM_RSTATEP, SCM_RSTATE): Use the new helpers.
(scm_masktab): Make private.
* libguile/random.c: Adapt random states to not be a smob.
* libguile/eq.c:
* libguile/print.c:
* libguile/scm.h:
* module/oop/goops.scm: Add new random-state cases. Fix a number of
classes for other types that were recently changed to not be smobs.
---
libguile/eq.c | 1 +
libguile/goops.c | 8 +++++++-
libguile/print.c | 5 +++++
libguile/random.c | 31 +++++++++----------------------
libguile/random.h | 30 ++++++++++++++++++++++++------
libguile/scm.h | 3 +--
module/oop/goops.scm | 24 ++++++++++--------------
7 files changed, 57 insertions(+), 45 deletions(-)
diff --git a/libguile/eq.c b/libguile/eq.c
index f85ad43d7..bbcd158d4 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -393,6 +393,7 @@ scm_equal_p (SCM x, SCM y)
case scm_tc16_continuation:
case scm_tc16_directory:
case scm_tc16_syntax_transformer:
+ case scm_tc16_random_state:
return SCM_BOOL_F;
default:
abort ();
diff --git a/libguile/goops.c b/libguile/goops.c
index c8d504bab..5825c3732 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -142,6 +142,8 @@ static SCM class_condition_variable;
static SCM class_mutex;
static SCM class_continuation;
static SCM class_directory;
+static SCM class_macro;
+static SCM class_random_state;
static struct scm_ephemeron_table *vtable_class_map;
static SCM pre_goops_vtables = SCM_EOL;
@@ -352,7 +354,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_directory:
return class_directory;
case scm_tc16_syntax_transformer:
- return class_unknown;
+ return class_macro;
+ case scm_tc16_random_state:
+ return class_random_state;
default:
abort ();
}
@@ -992,6 +996,8 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init",
0, 0, 0,
class_mutex = scm_variable_ref (scm_c_lookup ("<mutex>"));
class_continuation = scm_variable_ref (scm_c_lookup ("<continuation>"));
class_directory = scm_variable_ref (scm_c_lookup ("<directory>"));
+ class_macro = scm_variable_ref (scm_c_lookup ("<macro>"));
+ class_random_state = scm_variable_ref (scm_c_lookup ("<random-state>"));
create_smob_classes ();
create_struct_classes ();
diff --git a/libguile/print.c b/libguile/print.c
index 729d3de01..45d8c9d00 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -755,6 +755,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc16_syntax_transformer:
scm_i_print_syntax_transformer (exp, port, pstate);
break;
+ case scm_tc16_random_state:
+ scm_puts ("#<random-state ", port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+ break;
default:
abort ();
}
diff --git a/libguile/random.c b/libguile/random.c
index 2bd34a1a0..58b0496ec 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -46,7 +46,6 @@
#include "numbers.h"
#include "numbers.h"
#include "pairs.h"
-#include "smob.h"
#include "srfi-4.h"
#include "stime.h"
#include "strings.h"
@@ -185,6 +184,7 @@ scm_c_make_rstate (const char *seed, int n)
state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
"random-state");
+ state->tag = scm_tc16_random_state;
state->rng = &scm_the_rng;
state->normal_next = 0.0;
state->rng->init_rstate (state, seed, n);
@@ -198,6 +198,7 @@ scm_c_rstate_from_datum (SCM datum)
state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
"random-state");
+ state->tag = scm_tc16_random_state;
state->rng = &scm_the_rng;
state->normal_next = 0.0;
state->rng->from_datum (state, datum);
@@ -255,7 +256,7 @@ scm_c_exp1 (scm_t_rstate *state)
return - log (scm_c_uniform01 (state));
}
-unsigned char scm_masktab[256];
+static unsigned char scm_masktab[256];
static inline uint32_t
scm_i_mask32 (uint32_t m)
@@ -371,19 +372,6 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m)
return ret;
}
-/*
- * Scheme level representation of random states.
- */
-
-scm_t_bits scm_tc16_rstate;
-
-static SCM
-make_rstate (scm_t_rstate *state)
-{
- SCM_RETURN_NEWSMOB (scm_tc16_rstate, state);
-}
-
-
/*
* Scheme level interface.
*/
@@ -444,7 +432,8 @@ SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0,
1, 0,
if (SCM_UNBNDP (state))
state = SCM_VARIABLE_REF (scm_var_random_state);
SCM_VALIDATE_RSTATE (1, state);
- return make_rstate (SCM_RSTATE (state)->rng->copy_rstate (SCM_RSTATE
(state)));
+ return scm_from_random_state
+ (SCM_RSTATE (state)->rng->copy_rstate (SCM_RSTATE (state)));
}
#undef FUNC_NAME
@@ -478,7 +467,7 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state",
1, 0, 0,
SCM_OUT_OF_RANGE (1, seed);
}
- res = make_rstate (scm_c_make_rstate (c_str, len));
+ res = scm_from_random_state (scm_c_make_rstate (c_str, len));
free (c_str);
scm_remember_upto_here_1 (seed);
@@ -493,7 +482,7 @@ SCM_DEFINE (scm_datum_to_random_state,
"datum->random-state", 1, 0, 0,
"been obtained from @code{random-state->datum}.")
#define FUNC_NAME s_scm_datum_to_random_state
{
- return make_rstate (scm_c_rstate_from_datum (datum));
+ return scm_from_random_state (scm_c_rstate_from_datum (datum));
}
#undef FUNC_NAME
@@ -759,7 +748,7 @@ random_state_of_last_resort (void)
buf[i] = scm_to_int (scm_logand (seed, SCM_I_MAKINUM (255)));
seed = scm_ash (seed, SCM_I_MAKINUM (-8));
}
- state = make_rstate (scm_c_make_rstate ((char *) buf, len));
+ state = scm_from_random_state (scm_c_make_rstate ((char *) buf, len));
free (buf);
}
return state;
@@ -807,7 +796,7 @@ source of entropy, appropriate for use in
non-security-critical applications.")
{
unsigned char buf[32];
if (read_dev_urandom (buf, sizeof(buf)))
- return make_rstate (scm_c_make_rstate ((char *) buf, sizeof(buf)));
+ return scm_from_random_state (scm_c_make_rstate ((char *) buf,
sizeof(buf)));
else
return random_state_of_last_resort ();
}
@@ -829,8 +818,6 @@ scm_init_random ()
};
scm_the_rng = rng;
- scm_tc16_rstate = scm_make_smob_type ("random-state", 0);
-
for (m = 1; m <= 0x100; m <<= 1)
for (i = m >> 1; i < m; ++i)
scm_masktab[i] = m - 1;
diff --git a/libguile/random.h b/libguile/random.h
index e3bb321c3..9994cc82b 100644
--- a/libguile/random.h
+++ b/libguile/random.h
@@ -1,7 +1,7 @@
#ifndef SCM_RANDOM_H
#define SCM_RANDOM_H
-/* Copyright 1999-2001,2006,2008,2010,2018
+/* Copyright 1999-2001,2006,2008,2010,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -38,6 +38,7 @@
*/
typedef struct scm_t_rstate {
+ scm_t_bits tag;
struct scm_t_rng *rng;
double normal_next; /* For scm_c_normal01 */
/* Custom fields follow here */
@@ -73,15 +74,32 @@ SCM_API SCM scm_c_random_bignum (scm_t_rstate *, SCM m);
/*
* Scheme level interface
*/
-SCM_API scm_t_bits scm_tc16_rstate;
-#define SCM_RSTATEP(obj) SCM_SMOB_PREDICATE (scm_tc16_rstate, obj)
-#define SCM_RSTATE(obj) ((scm_t_rstate *) SCM_SMOB_DATA (obj))
+static inline int
+scm_is_random_state (SCM x)
+{
+ return SCM_HAS_TYP16 (x, scm_tc16_random_state);
+}
+
+static inline struct scm_t_rstate *
+scm_to_random_state (SCM x)
+{
+ if (!scm_is_random_state (x))
+ abort ();
+ return (struct scm_t_rstate *) SCM_UNPACK_POINTER (x);
+}
+
+static inline SCM
+scm_from_random_state (struct scm_t_rstate *x)
+{
+ return SCM_PACK_POINTER (x);
+}
+
+#define SCM_RSTATEP(obj) scm_is_random_state (obj)
+#define SCM_RSTATE(obj) scm_to_random_state (obj)
#define SCM_VALIDATE_RSTATE(pos, v) \
SCM_MAKE_VALIDATE_MSG (pos, v, RSTATEP, "random-generator-state")
-SCM_API unsigned char scm_masktab[256];
-
SCM_API SCM scm_var_random_state;
SCM_API SCM scm_random (SCM n, SCM state);
SCM_API SCM scm_copy_random_state (SCM state);
diff --git a/libguile/scm.h b/libguile/scm.h
index 8e2903917..10aa0d2c8 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -514,9 +514,8 @@ typedef uintptr_t scm_t_bits;
#define scm_tc16_continuation 0x037f
#define scm_tc16_directory 0x047f
#define scm_tc16_syntax_transformer 0x057f
+#define scm_tc16_random_state 0x067f
/*
-#define scm_tc16_promise 0x0e7f
-#define scm_tc16_random_state 0x0f7f
#define scm_tc16_regexp 0x107f
*/
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 5d5121652..89cc69da1 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -71,7 +71,8 @@
<fluid> <dynamic-state> <frame> <vm> <vm-continuation>
<keyword> <syntax> <atomic-box> <thread> <bitvector>
<finalizer> <ephemeron> <ephemeron-table> <character-set>
- <mutex> <condition-variable> <continuation>
+ <mutex> <condition-variable> <continuation> <directory>
+ <array> <random-state>
;; Numbers.
<number> <complex> <real> <integer> <fraction>
@@ -79,14 +80,12 @@
;; Unknown.
<unknown>
- ;; Particular SMOB data types. All SMOB types have
- ;; corresponding classes, which may be obtained via class-of,
- ;; once you have an instance. Perhaps FIXME to provide a
- ;; smob-type-name->class procedure.
- <promise>
- <regexp> <random-state>
- <directory> <array>
- <dynamic-object> <macro>
+ ;; Particular SMOB or record data types. All SMOB types
+ ;; have corresponding classes, which may be obtained via
+ ;; class-of, once you have an instance. Perhaps FIXME to
+ ;; provide a smob-type-name->class procedure.
+ <regexp>
+ <dynamic-object>
;; Modules.
<module>
@@ -1088,6 +1087,8 @@ slots as we go."
(define-standard-class <mutex> (<top>))
(define-standard-class <continuation> (<top>))
(define-standard-class <directory> (<top>))
+(define-standard-class <macro> (<top>))
+(define-standard-class <random-state> (<top>))
(define-standard-class <thread> (<top>))
(define-standard-class <number> (<top>))
(define-standard-class <complex> (<number>))
@@ -3535,12 +3536,7 @@ var{initargs}."
;;; {SMOB and port classes}
;;;
-(define <promise> (find-subclass <top> '<promise>))
(define <regexp> (find-subclass <top> '<regexp>))
-(define <bitvector> (find-subclass <top> '<bitvector>))
-(define <random-state> (find-subclass <top> '<random-state>))
-(define <array> (find-subclass <top> '<array>))
-(define <macro> (find-subclass <top> '<macro>))
;; <dynamic-object> used to be a SMOB type, albeit not exported even to
;; C. However now it's a record type, though still private. Cross our
