wingo pushed a commit to branch wip-whippet
in repository guile.
commit 9de24bd42950c91020c9123b12e862fedc10b51c
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue Jul 1 11:07:39 2025 +0200
Implement scm_trace_object
* libguile/trace.h: Make a precise object tracer.
---
libguile/trace.h | 665 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 662 insertions(+), 3 deletions(-)
diff --git a/libguile/trace.h b/libguile/trace.h
index 43df0eab3..eb35f4985 100644
--- a/libguile/trace.h
+++ b/libguile/trace.h
@@ -21,9 +21,45 @@
-#include "libguile/scm.h"
-#include "gc-ref.h"
+#include "gc-api.h"
#include "gc-edge.h"
+#include "gc-conservative-ref.h"
+#include "gc-ref.h"
+#include "gc-finalizer.h"
+#include "gc-ephemeron.h"
+#include "libguile/arrays-internal.h"
+#include "libguile/atomic.h"
+#include "libguile/bitvectors-internal.h"
+#include "libguile/bytevectors-internal.h"
+#include "libguile/continuations-internal.h"
+#include "libguile/dynstack.h"
+#include "libguile/ephemerons.h"
+#include "libguile/filesys-internal.h"
+#include "libguile/fluids-internal.h"
+#include "libguile/foreign.h"
+#include "libguile/frames-internal.h"
+#include "libguile/hashtab.h"
+#include "libguile/i18n-internal.h"
+#include "libguile/integers.h"
+#include "libguile/keywords-internal.h"
+#include "libguile/macros-internal.h"
+#include "libguile/numbers.h"
+#include "libguile/ports-internal.h"
+#include "libguile/programs.h"
+#include "libguile/random.h"
+#include "libguile/regex-posix.h"
+#include "libguile/scm.h"
+#include "libguile/smob-internal.h"
+#include "libguile/srfi-14-internal.h"
+#include "libguile/strings-internal.h"
+#include "libguile/struct.h"
+#include "libguile/symbols.h"
+#include "libguile/syntax.h"
+#include "libguile/threads-internal.h"
+#include "libguile/values-internal.h"
+#include "libguile/variable.h"
+#include "libguile/vectors-internal.h"
+#include "libguile/vm-internal.h"
@@ -92,17 +128,640 @@ scm_trace_dynstack_roots (struct scm_dynstack *dynstack,
void (*trace) (struct gc_edge, struct gc_heap *, void *), \
struct gc_heap *heap, \
void *trace_data
+#define TRACE_ARGS trace, heap, trace_data
+
+static inline void
+scm_trace_edge_conservatively (void * addr, int maybe_interior, TRACE_PARAMS)
+{
+ uintptr_t *loc = addr;
+ uintptr_t val = *loc;
+ if (SCM_HEAP_OBJECT_P (SCM_PACK (val)))
+ {
+ struct gc_conservative_ref maybe_ref = gc_conservative_ref (val);
+ struct gc_ref ref =
+ gc_resolve_conservative_ref (heap, maybe_ref, maybe_interior);
+ // Precondition: targers of ambiguous edges are not evacuated.
+ // Two ways to make this happen: either nothing is evacuated, or
+ // these objects are pinned, as in
+ // continuations.c:pin_conservative_roots.
+ if (!gc_ref_is_null (ref))
+ trace (gc_edge (&ref), heap, trace_data);
+ }
+}
+
+static inline void
+scm_trace_field_conservatively (void *field, TRACE_PARAMS)
+{
+ scm_trace_edge_conservatively (field, 0, TRACE_ARGS);
+}
+
+static inline void
+scm_trace_range_conservatively (void *start, size_t size, int maybe_interior,
+ TRACE_PARAMS)
+{
+ size_t word_size = sizeof (uintptr_t);
+ uintptr_t addr = (uintptr_t) start;
+ uintptr_t end = (addr + size) & ~(word_size - 1);
+ addr = (addr + word_size - 1) & ~(word_size - 1);
+
+ for (; addr < end; addr += word_size)
+ scm_trace_edge_conservatively ((void *) addr, maybe_interior, TRACE_ARGS);
+}
+
+#define TRACE(loc) trace (gc_edge (loc), heap, trace_data)
+#define TRACE_SLOT(x, n) TRACE(&((x)[n]))
+#define TRACE_MEMBER(x, m) TRACE(&(x)->m)
+
+#define TRACE_PINNED_AMBIGUOUS_SLOT(x, n) \
+ scm_trace_field_conservatively (&((x)[n]), TRACE_ARGS)
+
+#define SIZEOF_WITH_TAIL(x, field, count) \
+ (sizeof (*(x)) + sizeof (*((x)->field)) * count)
+
+#define SCM_CAST(x, type) ((type) SCM_UNPACK_POINTER (x))
SCM_INTERNAL void
scm_trace_dynstack (struct scm_dynstack *dynstack, TRACE_PARAMS);
+static inline size_t
+scm_trace_pair (struct scm_pair *pair, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (pair, car);
+ TRACE_MEMBER (pair, cdr);
+ }
+
+ return sizeof (*pair);
+}
+
+static inline size_t
+scm_trace_struct (struct scm_struct *s, TRACE_PARAMS)
+{
+ // Struct vtables are pinned.
+ struct scm_struct *vtable = scm_i_struct_vtable (s);
+ size_t nfields = scm_i_vtable_size (vtable);
+
+ if (trace)
+ {
+ // unboxed_fields is either an inum or a bignum. If it's a
+ // bignum, it's pinned.
+ SCM unboxed_fields = scm_i_vtable_unboxed_fields (vtable);
+ if (scm_is_eq (unboxed_fields, SCM_INUM0))
+ for (size_t i = 0; i < nfields; i++)
+ TRACE_SLOT (s->slots, i);
+ else
+ for (size_t i = 0; i < nfields; i++)
+ if (scm_is_false (scm_logbit_p (unboxed_fields, SCM_I_MAKINUM (i))))
+ TRACE_SLOT (s->slots, i);
+ }
+
+ return SIZEOF_WITH_TAIL (s, slots, nfields);
+}
+
+static inline size_t
+scm_trace_symbol (struct scm_symbol *s, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (s, name);
+
+ return sizeof (*s);
+}
+
+static inline size_t
+scm_trace_variable (struct scm_variable *v, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (v, value);
+
+ return sizeof (*v);
+}
+
+static inline size_t
+scm_trace_vector (struct scm_vector *v, TRACE_PARAMS)
+{
+ size_t len = scm_i_vector_length (v);
+
+ if (trace)
+ for (size_t idx = 0; idx < len; idx++)
+ TRACE_SLOT (v->slots, idx);
+
+ return SIZEOF_WITH_TAIL (v, slots, len);
+}
+
+static inline size_t
+scm_trace_ephemeron_table (struct scm_ephemeron_table *et, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ for (size_t idx = 0; idx < et->size; idx++)
+ TRACE_SLOT (et->contents, idx);
+ }
+
+ return SIZEOF_WITH_TAIL (et, contents, et->size);
+}
+
+static inline size_t
+scm_trace_string (struct scm_string *s, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (s, chars);
+
+ return sizeof (*s);
+}
+
+static inline size_t
+scm_trace_number (SCM obj, TRACE_PARAMS)
+{
+ switch (SCM_TYP16 (obj))
+ {
+ case scm_tc16_big:
+ return scm_integer_size_z (scm_bignum (obj));
+ case scm_tc16_real:
+ return sizeof (struct scm_t_double);
+ case scm_tc16_complex:
+ return sizeof (struct scm_t_complex);
+ case scm_tc16_fraction:
+ {
+ struct scm_fraction *f = SCM_CAST (obj, struct scm_fraction *);
+ if (trace)
+ {
+ TRACE_MEMBER (f, numerator);
+ TRACE_MEMBER (f, denominator);
+ }
+ return sizeof (*f);
+ }
+ default:
+ abort();
+ }
+}
+
+static inline size_t
+scm_trace_hashtable (struct scm_t_hashtable *ht, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (ht, buckets);
+
+ return sizeof (*ht);
+}
+
+static inline size_t
+scm_trace_pointer (struct scm_pointer *p, TRACE_PARAMS)
+{
+ size_t extra_words = scm_pointer_gc_object_count (p);
+
+ if (trace)
+ for (size_t i = 0; i < extra_words; i++)
+ TRACE_MEMBER (p, gc_objects);
+
+ return SIZEOF_WITH_TAIL (p, gc_objects, extra_words);
+}
+
+static inline size_t
+scm_trace_fluid (struct scm_fluid *f, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (f, default_value);
+
+ return sizeof (*f);
+}
+
+static inline size_t
+scm_trace_stringbuf (struct scm_stringbuf *buf, TRACE_PARAMS)
+{
+ size_t char_sz = (buf->tag_and_flags & SCM_I_STRINGBUF_F_WIDE) ? 4 : 1;
+ return sizeof (*buf) + buf->length * char_sz;
+}
+
+static inline size_t
+scm_trace_dynamic_state (struct scm_dynamic_state_snapshot *dynstate,
TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (dynstate, bindings);
+
+ return sizeof (*dynstate);
+}
+
+static inline size_t
+scm_trace_frame (struct scm_vm_frame *f, TRACE_PARAMS)
+{
+ if (trace)
+ switch (scm_vm_frame_kind (f))
+ {
+ case SCM_VM_FRAME_KIND_VM:
+ break;
+ case SCM_VM_FRAME_KIND_CONT:
+ TRACE_MEMBER (&f->frame, stack_holder);
+ break;
+ default:
+ abort ();
+ }
+
+ return sizeof (*f);
+}
+
+static inline size_t
+scm_trace_keyword (struct scm_keyword *k, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (k, symbol);
+
+ return sizeof (*k);
+}
+
+static inline size_t
+scm_trace_atomic_box (struct scm_atomic_box *b, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (b, value);
+
+ return sizeof (*b);
+}
+
+static inline size_t
+scm_trace_syntax (struct scm_syntax *stx, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (stx, expr);
+ TRACE_MEMBER (stx, wrap);
+ TRACE_MEMBER (stx, module);
+ TRACE_MEMBER (stx, source);
+ }
+
+ return sizeof (*stx);
+}
+
+static inline size_t
+scm_trace_values (struct scm_values *v, TRACE_PARAMS)
+{
+ size_t count = scm_values_count (v);
+
+ if (trace)
+ for (size_t i = 0; i < count; i++)
+ TRACE_SLOT (v->values, i);
+
+ return SIZEOF_WITH_TAIL (v, values, count);
+}
+
+static inline size_t
+scm_trace_program (struct scm_program *p, TRACE_PARAMS)
+{
+ size_t count = scm_program_free_variable_count (p);
+
+ if (trace)
+ for (size_t i = 0; i < count; i++)
+ TRACE_SLOT (p->free_variables, i);
+
+ return SIZEOF_WITH_TAIL (p, free_variables, count);
+}
+
+static inline size_t
+scm_trace_vm_cont (struct scm_vm_cont *c, TRACE_PARAMS)
+{
+ size_t count = c->stack_size;
+
+ if (trace)
+ {
+ TRACE_MEMBER (c, dynstack);
+ for (size_t i = 0; i < count; i++)
+ TRACE_PINNED_AMBIGUOUS_SLOT (c->stack_slice, i);
+ }
+
+ return SIZEOF_WITH_TAIL (c, stack_slice, count);
+}
+
+static inline size_t
+scm_trace_bytevector (struct scm_bytevector *x, TRACE_PARAMS)
+{
+ if (x->contents == x->inline_contents)
+ return SIZEOF_WITH_TAIL (x, inline_contents, x->length);
+
+ if (trace)
+ {
+ TRACE_MEMBER (x, parent);
+ if (scm_is_false (x->parent))
+ TRACE_MEMBER (x, contents);
+ }
+
+ return sizeof (*x);
+}
+
+static inline size_t
+scm_trace_thread (struct scm_thread *x, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (x, next_thread);
+ TRACE_MEMBER (x, pending_asyncs);
+ TRACE_MEMBER (x, continuation_root);
+ TRACE_MEMBER (x, join_cond);
+ TRACE_MEMBER (x, join_lock);
+ TRACE_MEMBER (x, join_results);
+
+ scm_trace_dynstack (&x->dynstack, TRACE_ARGS);
+ }
+
+ return sizeof (*x);
+}
+
+static inline size_t
+scm_trace_port_type (struct scm_t_port_type *ptob, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (ptob, scm_read);
+ TRACE_MEMBER (ptob, scm_write);
+ TRACE_MEMBER (ptob, input_class);
+ TRACE_MEMBER (ptob, output_class);
+ TRACE_MEMBER (ptob, input_output_class);
+ }
+
+ return sizeof (*ptob);
+}
+
+static inline size_t
+scm_trace_array (struct scm_array *x, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (x, vector);
+
+ return SIZEOF_WITH_TAIL (x, dims, scm_array_dimension_count (x));
+}
+
+static inline size_t
+scm_trace_bitvector (struct scm_bitvector *x, TRACE_PARAMS)
+{
+ return SIZEOF_WITH_TAIL (x, bits, scm_bitvector_word_length (x));
+}
+
+static inline size_t
+scm_trace_smob (struct scm_smob *x, TRACE_PARAMS)
+{
+ const struct scm_smob_descriptor *desc = scm_i_smob_descriptor (x);
+
+ if (!desc->field_count)
+ {
+ size_t size = desc->observed_size * sizeof (scm_t_bits);
+ if (trace)
+ scm_trace_range_conservatively (x, size, 1, TRACE_ARGS);
+ return size;
+ }
+
+ if (trace)
+ for (size_t i = 0; i < desc->field_count; i++)
+ if (scm_smob_field_is_managed (desc, i))
+ TRACE (scm_smob_field_loc (x, i));
+
+ return sizeof (*x) + desc->field_count * sizeof (SCM);
+}
+
+static inline size_t
+scm_trace_port (struct scm_t_port *x, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (x, file_name);
+ TRACE_MEMBER (x, position);
+ TRACE_MEMBER (x, read_buf);
+ TRACE_MEMBER (x, write_buf);
+ TRACE_MEMBER (x, encoding);
+ TRACE_MEMBER (x, conversion_strategy);
+ TRACE_MEMBER (x, precise_encoding);
+ TRACE_MEMBER (x, close_handle);
+ TRACE_MEMBER (x, alist);
+
+ if (x->ptob->stream_mode != SCM_PORT_STREAM_UNMANAGED)
+ TRACE_MEMBER (x, stream);
+ }
+
+ return sizeof (*x);
+}
+
+static inline size_t
+scm_trace_character_set (struct scm_charset *cs, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (cs, ranges);
+
+ return sizeof (*cs);
+}
+
+static inline size_t
+scm_trace_condition_variable (struct scm_cond *c, TRACE_PARAMS)
+{
+ if (trace)
+ TRACE_MEMBER (c, waiting);
+
+ return sizeof (*c);
+}
+
+static inline size_t
+scm_trace_mutex (struct scm_mutex *m, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (m, owner);
+ TRACE_MEMBER (m, waiting);
+ }
+
+ return sizeof (*m);
+}
+
+static inline size_t
+scm_trace_continuation (struct scm_continuation *c, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (c, root);
+ TRACE_MEMBER (c, vm_cont);
+
+ scm_trace_range_conservatively (&c->jmpbuf, sizeof (c->jmpbuf), 1,
+ TRACE_ARGS);
+ scm_trace_range_conservatively (c->stack,
+ c->num_stack_items * sizeof
(SCM_STACKITEM),
+ 1,
+ TRACE_ARGS);
+ }
+
+ return SIZEOF_WITH_TAIL (c, stack, c->num_stack_items);
+}
+
+static inline size_t
+scm_trace_directory (struct scm_directory *d, TRACE_PARAMS)
+{
+ return sizeof (*d);
+}
+
+static inline size_t
+scm_trace_syntax_transformer (struct scm_syntax_transformer *tx, TRACE_PARAMS)
+{
+ if (trace)
+ {
+ TRACE_MEMBER (tx, name);
+ TRACE_MEMBER (tx, type);
+ TRACE_MEMBER (tx, binding);
+ }
+
+ return sizeof (*tx);
+}
+
+static inline size_t
+scm_trace_random_state (struct scm_t_rstate *s, TRACE_PARAMS)
+{
+ return s->rng->rstate_size;
+}
+
+static inline size_t
+scm_trace_regexp (struct scm_regexp *rx, TRACE_PARAMS)
+{
+ return sizeof (*rx);
+}
+
+static inline size_t
+scm_trace_locale (struct scm_locale *l, TRACE_PARAMS)
+{
+ return sizeof (*l);
+}
+
+static inline size_t
+scm_trace_dynstack_slice (struct scm_dynstack *ds, TRACE_PARAMS)
+{
+ if (trace)
+ scm_trace_dynstack (ds, TRACE_ARGS);
+
+ return SIZEOF_WITH_TAIL (ds, inline_storage, scm_dynstack_capacity (ds));
+}
+
+#define FOR_EACH_TC7_WITH_STRUCT_TYPE(M) \
+ M(tcs_cons_nimcar, pair, scm_pair) \
+ M(tcs_cons_imcar, pair, scm_pair) \
+ M(tcs_struct, struct, scm_struct) \
+ M(tc7_symbol, symbol, scm_symbol) \
+ M(tc7_variable, variable, scm_variable) \
+ M(tc7_vector, vector, scm_vector) \
+ M(tc7_ephemeron_table, ephemeron_table, scm_ephemeron_table) \
+ M(tc7_string, string, scm_string) \
+ M(tc7_hashtable, hashtable, scm_t_hashtable) \
+ M(tc7_pointer, pointer, scm_pointer) \
+ M(tc7_fluid, fluid, scm_fluid) \
+ M(tc7_stringbuf, stringbuf, scm_stringbuf) \
+ M(tc7_dynamic_state, dynamic_state, scm_dynamic_state_snapshot) \
+ M(tc7_frame, frame, scm_vm_frame) \
+ M(tc7_keyword, keyword, scm_keyword) \
+ M(tc7_atomic_box, atomic_box, scm_atomic_box) \
+ M(tc7_syntax, syntax, scm_syntax) \
+ M(tc7_values, values, scm_values) \
+ M(tc7_program, program, scm_program) \
+ M(tc7_vm_cont, vm_cont, scm_vm_cont) \
+ M(tc7_bytevector, bytevector, scm_bytevector) \
+ M(tc7_thread, thread, scm_thread) \
+ M(tc7_port_type, port_type, scm_t_port_type) \
+ M(tc7_array, array, scm_array) \
+ M(tc7_bitvector, bitvector, scm_bitvector) \
+ M(tc7_port, port, scm_t_port) \
+
+#define FOR_EACH_EXT_TC16_WITH_STRUCT_TYPE(M) \
+ M(charset, character_set, scm_charset) \
+ M(condition_variable, condition_variable, scm_cond) \
+ M(mutex, mutex, scm_mutex) \
+ M(continuation, continuation, scm_continuation) \
+ M(directory, directory, scm_directory) \
+ M(syntax_transformer, syntax_transformer, scm_syntax_transformer) \
+ M(random_state, random_state, scm_t_rstate) \
+ M(regexp, regexp, scm_regexp) \
+ M(locale, locale, scm_locale) \
+ M(dynstack_slice, dynstack_slice, scm_dynstack)
+
static inline size_t
scm_trace_object (SCM obj, TRACE_PARAMS)
{
- GC_CRASH ();
+ // Trace an object. Note that in the rare case in which we need to
+ // access another object in order to trace this object, as with
+ // structs and vtables, we need to consider that the other object may
+ // be evacuated and have a forwarding word in their first word.
+ // Sometimes this is OK, sometimes instead we need to make sure to pin
+ // the other object.
+
+ switch (SCM_TYP7 (obj))
+ {
+#define TRACE_TC7(tc, stem, struct_tag) \
+ case scm_##tc: \
+ return scm_trace_##stem (SCM_CAST (obj, struct struct_tag *), \
+ TRACE_ARGS);
+ FOR_EACH_TC7_WITH_STRUCT_TYPE(TRACE_TC7)
+#undef TRACE_TC7
+
+ case scm_tc7_ext:
+ {
+ switch (SCM_TYP16 (obj))
+ {
+#define TRACE_EXT_TC16(tc, stem, struct_tag) \
+ case scm_tc16_##tc: \
+ return scm_trace_##stem (SCM_CAST (obj, struct struct_tag *), \
+ TRACE_ARGS);
+ FOR_EACH_EXT_TC16_WITH_STRUCT_TYPE(TRACE_EXT_TC16)
+#undef TRACE_EXT_TC16
+
+ default:
+ abort ();
+ }
+ }
+
+ case scm_tc7_number:
+ switch (SCM_TYP16 (obj))
+ {
+ case scm_tc16_big:
+ return scm_integer_size_z (scm_bignum (obj));
+ case scm_tc16_real:
+ return sizeof (struct scm_t_double);
+ case scm_tc16_complex:
+ return sizeof (struct scm_t_complex);
+ case scm_tc16_fraction:
+ {
+ struct scm_fraction *f = SCM_CAST (obj, struct scm_fraction *);
+ if (trace)
+ {
+ TRACE_MEMBER (f, numerator);
+ TRACE_MEMBER (f, denominator);
+ }
+ return sizeof (*f);
+ }
+ default:
+ abort();
+ }
+
+ case scm_tc7_finalizer:
+ gc_trace_finalizer (SCM_CAST (obj, struct gc_finalizer *), TRACE_ARGS);
+ return gc_finalizer_size ();
+
+ case scm_tc7_ephemeron:
+ gc_trace_ephemeron (SCM_CAST (obj, struct gc_ephemeron *), TRACE_ARGS);
+ return gc_ephemeron_size ();
+
+ case scm_tc7_smob:
+ {
+ struct scm_smob *x = SCM_CAST (obj, struct scm_smob *);
+ return sizeof (*x);
+ }
+
+ default:
+ abort ();
+ }
}
+#undef FOR_EACH_TC7_WITH_STRUCT_TYPE
+#undef FOR_EACH_EXT_TC16_WITH_STRUCT_TYPE
+
#undef TRACE_PARAMS
+#undef TRACE_ARGS
+
+#undef TRACE_MEMBER
+#undef TRACE_SLOT
+#undef TRACE
+
+#undef SIZEOF_WITH_TAIL
+#undef SCM_CAST
#endif /* SCM_TRACE_H */
