Implement scm_trace_object

* libguile/trace.h: Make a precise object tracer.

libguile/trace.h

@@ -21,9 +21,45 @@
 
 
 
-#include "libguile/scm.h"
+#include "gc-api.h"
-#include "gc-ref.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_object (SCM obj, TRACE_PARAMS)
+scm_trace_pair (struct scm_pair *pair, TRACE_PARAMS)
 {
-  GC_CRASH ();
+  if (trace)
+    {
+      TRACE_MEMBER (pair, car);
+      TRACE_MEMBER (pair, cdr);
+    }
+
+  return sizeof (*pair);
 }
 
-#undef TRACE_PARAMS
+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)
+{
+  // 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 */