[Guile-commits] 04/07: Remove indirection in structs

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 7e91ff651b3c9f7c27f2be146ea611bab65809a8
Author: Andy Wingo <address@hidden>
Date:   Thu Sep 7 16:55:30 2017 +0200

    Remove indirection in structs
    
    * libguile/gc.c (scm_storage_prehistory): Register struct displacement
      here.
    * libguile/goops.c (scm_sys_modify_instance): Fix the format of a
      comment.
    * libguile/modules.c (scm_post_boot_init_modules): Update for new format
      of struct vtable references.
    * libguile/struct.c (scm_i_alloc_struct): Update to include slots
      directly, instead of being indirected by an embedded pointer.
      (scm_c_make_structv, scm_allocate_struct, scm_i_make_vtable_vtable):
      Adapt to pass vtable bits as argument to scm_i_alloc_struct, not
      vtable data bits.
      (scm_init_struct): Remove two-word displacement from libgc.
    * libguile/struct.h: Update comment.
      (SCM_STRUCT_SLOTS, SCM_STRUCT_DATA): Update definitions.
      (SCM_STRUCT_VTABLE_DATA, SCM_STRUCT_VTABLE_SLOTS): Remove.
      (SCM_STRUCT_VTABLE, SCM_STRUCT_LAYOUT, SCM_STRUCT_PRINTER)
      (SCM_STRUCT_FINALIZER, SCM_STRUCT_VTABLE_FLAGS)
      (SCM_STRUCT_VTABLE_FLAG_IS_SET): Simplify definitions.
    * module/system/base/types.scm (cell->object, address->inferior-struct):
      Adapt to struct representation change.
---
 libguile/gc.c                |  6 ++--
 libguile/goops.c             |  5 ++-
 libguile/modules.c           |  4 +--
 libguile/struct.c            | 47 +++++++--------------------
 libguile/struct.h            | 75 ++++++++++++++++----------------------------
 module/system/base/types.scm | 11 ++++---
 6 files changed, 52 insertions(+), 96 deletions(-)

diff --git a/libguile/gc.c b/libguile/gc.c
index 4478128..b9064b3 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006,
- *   2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016 Free Software Foundation, 
Inc.
+ *   2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016, 2017 Free Software 
Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -480,9 +480,9 @@ scm_storage_prehistory ()
 
   /* We only need to register a displacement for those types for which the
      higher bits of the type tag are used to store a pointer (that is, a
-     pointer to an 8-octet aligned region).  For `scm_tc3_struct', this is
-     handled in `scm_alloc_struct ()'.  */
+     pointer to an 8-octet aligned region).  */
   GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
+  GC_REGISTER_DISPLACEMENT (scm_tc3_struct);
   /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
 
   /* Sanity check.  */
diff --git a/libguile/goops.c b/libguile/goops.c
index 12a3687..7e7a265 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -521,9 +521,8 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 
0, 0,
   SCM_ASSERT (old_nfields == new_nfields, new, SCM_ARG2, FUNC_NAME);
 
   /* Exchange the data contained in old and new. We exchange rather than
-   * scratch the old value with new to be correct with GC.
-   * See "Class redefinition protocol above".
-   */
+     scratch the old value with new to be correct with GC.  See "Class
+     redefinition protocol" in goops.scm.  */
   scm_i_pthread_mutex_lock (&goops_lock);
   /* Swap vtables.  */
   {
diff --git a/libguile/modules.c b/libguile/modules.c
index d87ec7a..b469a1a 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 
1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software 
Foundation, Inc.
+/* Copyright (C) 
1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012,2017 Free 
Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -875,7 +875,7 @@ static void
 scm_post_boot_init_modules ()
 {
   SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
-  scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
+  scm_module_tag = SCM_UNPACK (module_type) + scm_tc3_struct;
 
   resolve_module_var = scm_c_lookup ("resolve-module");
   define_module_star_var = scm_c_lookup ("define-module*");
diff --git a/libguile/struct.c b/libguile/struct.c
index 51c0f11..67e2e62 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
- *   2008, 2009, 2010, 2011, 2012, 2013, 2015 Free Software Foundation, Inc.
+ *   2008, 2009, 2010, 2011, 2012, 2013, 2015, 2017 Free Software Foundation, 
Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -420,30 +420,17 @@ struct_finalizer_trampoline (void *ptr, void *unused_data)
     finalize (obj);
 }
 
-/* All struct data must be allocated at an address whose bottom three
-   bits are zero.  This is because the tag for a struct lives in the
-   bottom three bits of the struct's car, and the upper bits point to
-   the data of its vtable, which is a struct itself.  Thus, if the
-   address of that data doesn't end in three zeros, tagging it will
-   destroy the pointer.
-
-   I suppose we should make it clear here that, the data must be 8-byte 
aligned,
-   *within* the struct, and the struct itself should be 8-byte aligned. In
-   practice we ensure this because the data starts two words into a struct.
-
-   This function allocates an 8-byte aligned block of memory, whose first word
-   points to the given vtable data, then a data pointer, then n_words of data.
- */
-SCM
-scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
+/* A struct is a sequence of words preceded by a pointer to the struct's
+   vtable.  The vtable reference is tagged with the struct tc3.  */
+static SCM
+scm_i_alloc_struct (scm_t_bits vtable_bits, int n_words)
 {
   SCM ret;
 
-  ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, n_words + 2);
-  SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
+  ret = scm_words (vtable_bits | scm_tc3_struct, n_words + 1);
 
-  /* vtable_data can be null when making a vtable vtable */
-  if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
+  /* vtable_bits can be 0 when making a vtable vtable */
+  if (vtable_bits && SCM_VTABLE_INSTANCE_FINALIZER (SCM_PACK (vtable_bits)))
     /* Register a finalizer for the newly created instance.  */
     scm_i_set_finalizer (SCM2PTR (ret), struct_finalizer_trampoline, NULL);
 
@@ -481,7 +468,7 @@ scm_c_make_structv (SCM vtable, size_t n_tail, size_t 
n_init, scm_t_bits *init)
         goto bad_tail;
     }
 
-  obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + n_tail);
+  obj = scm_i_alloc_struct (SCM_UNPACK (vtable), basic_size + n_tail);
 
   scm_struct_init (obj, layout, n_tail, n_init, init);
 
@@ -538,7 +525,7 @@ SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
   SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields,
               nfields, 2, FUNC_NAME);
 
-  ret = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), c_nfields);
+  ret = scm_i_alloc_struct (SCM_UNPACK (vtable), c_nfields);
 
   if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
     {
@@ -612,9 +599,9 @@ scm_i_make_vtable_vtable (SCM fields)
 
   basic_size = scm_i_symbol_length (layout) / 2;
 
-  obj = scm_i_alloc_struct (NULL, basic_size);
+  obj = scm_i_alloc_struct (0, basic_size);
   /* Make it so that the vtable of OBJ is itself.  */
-  SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | 
scm_tc3_struct);
+  SCM_SET_CELL_WORD_0 (obj, SCM_UNPACK (obj) | scm_tc3_struct);
 
   v = SCM_UNPACK (layout);
   scm_struct_init (obj, layout, 0, 1, &v);
@@ -980,16 +967,6 @@ scm_init_struct ()
 {
   SCM name;
 
-  /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
-     scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
-     default.  */
-  GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits) + scm_tc3_struct);
-
-  /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
-     beginning of a GC-allocated region; that region is different from that of
-     OBJ once OBJ has undergone class redefinition.  */
-  GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
-
   required_vtable_fields = scm_from_latin1_string (SCM_VTABLE_BASE_LAYOUT);
   scm_c_define ("standard-vtable-fields", required_vtable_fields);
   required_applicable_fields = scm_from_latin1_string 
(SCM_APPLICABLE_BASE_LAYOUT);
diff --git a/libguile/struct.h b/libguile/struct.h
index e7007b7..0dfcf46 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
 #ifndef SCM_STRUCT_H
 #define SCM_STRUCT_H
 
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 
2012, 2013, 2015 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 
2012, 2013, 2015, 2017 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -28,42 +28,28 @@
 
 
 
-/* The relationship between a struct and its vtable is a bit complicated,
-   because we want structs to be used as GOOPS' native representation -- which
-   in turn means we need support for changing the "class" (vtable) of an
-   "instance" (struct). This necessitates some indirection and trickery.
-
-   To summarize, structs are laid out this way:
-
-                  .-------.
-                  |       |
-     .----------------+---v------------- -
-     | vtable | data  | slot0 | slot1 |
-     `----------------+----------------- -
-         |        .-------.
-         |        |       |
-     .---v------------+---v------------- -
-     | vtable | data  | slot0 | slot1 |
-     `----------------+----------------- -
-         |
-         v
+/* Structs are sequences of words where the first word points to the
+   struct's vtable, and the rest are its slots.  The vtable indicates
+   how many words are in the struct among other meta-information.  A
+   vtable is itself a struct and as such has a vtable, and so on until
+   you get to a root struct that is its own vtable.
 
+     .--------+----------------- -
+     | vtable | slot0 | slot1 |
+     `--------+----------------- -
+         |
+         |
+     .---v----+----------------- -
+     | vtable | slot0 | slot1 |
+     `--------+----------------- -
+         |
         ...
-                  .-------.
-         |        |       |
-     .---v------------+---v------------- -
-   .-| vtable | data  | slot0 | slot1 |
-   | `----------------+----------------- -
+         |
+     .---v----+----------------- -
+   .-| vtable | slot0 | slot1 |
+   | `--------+----------------- -
    |     ^
    `-----'
-
-   The DATA indirection (which corresponds to `SCM_STRUCT_DATA ()') is 
necessary
-   to implement class redefinition.
-
-   For more details, see:
-
-     http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile
-
  */
 
 /* All vtables have the following fields. */
@@ -123,10 +109,10 @@
 typedef void (*scm_t_struct_finalize) (SCM obj);
 
 #define SCM_STRUCTP(X)                 (!SCM_IMP(X) && (SCM_TYP3(X) == 
scm_tc3_struct))
-#define SCM_STRUCT_SLOTS(X)            ((SCM*)SCM_CELL_WORD_1 ((X)))
+#define SCM_STRUCT_SLOTS(X)            (SCM_CELL_OBJECT_LOC(X, 1))
 #define SCM_STRUCT_SLOT_REF(X,I)       (SCM_STRUCT_SLOTS (X)[(I)])
 #define SCM_STRUCT_SLOT_SET(X,I,V)     SCM_STRUCT_SLOTS (X)[(I)]=(V)
-#define SCM_STRUCT_DATA(X)             ((scm_t_bits*)SCM_CELL_WORD_1 (X))
+#define SCM_STRUCT_DATA(X)             ((scm_t_bits*)SCM_STRUCT_SLOTS (X))
 #define SCM_STRUCT_DATA_REF(X,I)       (SCM_STRUCT_DATA (X)[(I)])
 #define SCM_STRUCT_DATA_SET(X,I,V)     SCM_STRUCT_DATA (X)[(I)]=(V)
 
@@ -145,18 +131,12 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
 #define SCM_VTABLE_NAME(X)              (SCM_STRUCT_SLOT_REF (X, 
scm_vtable_index_name))
 #define SCM_SET_VTABLE_NAME(X,V)        (SCM_STRUCT_SLOT_SET (X, 
scm_vtable_index_name, V))
 
-/* Structs hold a pointer to their vtable's data, not the vtable itself. To get
-   the vtable we have to do an indirection through the self slot. */
-#define SCM_STRUCT_VTABLE_DATA(X)       ((scm_t_bits*)(SCM_CELL_WORD_0 (X) - 
scm_tc3_struct))
-#define SCM_STRUCT_VTABLE_SLOTS(X)      ((SCM*)(SCM_CELL_WORD_0 (X) - 
scm_tc3_struct))
-#define SCM_STRUCT_VTABLE(X)            
(SCM_STRUCT_VTABLE_SLOTS(X)[scm_vtable_index_self])
-/* But often we just need to access the vtable's data; we can do that without
-   the data->self->data indirection. */
-#define SCM_STRUCT_LAYOUT(X)           (SCM_STRUCT_VTABLE_SLOTS 
(X)[scm_vtable_index_layout])
-#define SCM_STRUCT_PRINTER(X)          (SCM_STRUCT_VTABLE_SLOTS 
(X)[scm_vtable_index_instance_printer])
-#define SCM_STRUCT_FINALIZER(X)         
((scm_t_struct_finalize)SCM_STRUCT_VTABLE_DATA 
(X)[scm_vtable_index_instance_finalize])
-#define SCM_STRUCT_VTABLE_FLAGS(X)     (SCM_STRUCT_VTABLE_DATA 
(X)[scm_vtable_index_flags])
-#define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_VTABLE_DATA 
(X)[scm_vtable_index_flags]&(F))
+#define SCM_STRUCT_VTABLE(X)            (SCM_PACK (SCM_CELL_WORD_0 (X) - 
scm_tc3_struct))
+#define SCM_STRUCT_LAYOUT(X)           (SCM_VTABLE_LAYOUT (SCM_STRUCT_VTABLE 
(X)))
+#define SCM_STRUCT_PRINTER(X)          (SCM_VTABLE_INSTANCE_PRINTER 
(SCM_STRUCT_VTABLE (X)))
+#define SCM_STRUCT_FINALIZER(X)         (SCM_VTABLE_INSTANCE_FINALIZER 
(SCM_STRUCT_VTABLE (X)))
+#define SCM_STRUCT_VTABLE_FLAGS(X)      (SCM_VTABLE_FLAGS (SCM_STRUCT_VTABLE 
(X)))
+#define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_VTABLE_FLAG_IS_SET 
(SCM_STRUCT_VTABLE (X), (F)))
 
 #define SCM_STRUCT_APPLICABLE_P(X)     (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), 
SCM_VTABLE_FLAG_APPLICABLE))
 #define SCM_STRUCT_SETTER_P(X)                 (SCM_STRUCT_VTABLE_FLAG_IS_SET 
((X), SCM_VTABLE_FLAG_SETTER))
@@ -191,7 +171,6 @@ SCM_API void scm_print_struct (SCM exp, SCM port, 
scm_print_state *);
 
 SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
 SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
-SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words);
 SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
 SCM_INTERNAL void scm_init_struct (void);
 
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 49aea27..0652885 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -366,13 +366,14 @@ TYPE-NUMBER."
                                                  (%visited-cells))))
        body ...))))
 
-(define (address->inferior-struct address vtable-data-address backend)
+(define (address->inferior-struct address vtable-address backend)
   "Read the struct at ADDRESS using BACKEND.  Return an 'inferior-struct'
 object representing it."
   (define %vtable-layout-index 0)
   (define %vtable-name-index 5)
 
-  (let* ((layout-address (+ vtable-data-address
+  (let* ((vtable-data-address (+ vtable-address %word-size))
+         (layout-address (+ vtable-data-address
                             (* %vtable-layout-index %word-size)))
          (layout-bits    (dereference-word backend layout-address))
          (layout         (scm->object layout-bits backend))
@@ -383,7 +384,7 @@ object representing it."
     (if (symbol? layout)
         (let* ((layout (symbol->string layout))
                (len    (/ (string-length layout) 2))
-               (slots  (dereference-word backend (+ address %word-size)))
+               (slots  (+ address %word-size))
                (port   (memory-port backend slots (* len %word-size)))
                (fields (get-bytevector-n port (* len %word-size)))
                (result (inferior-struct name #f)))
@@ -405,9 +406,9 @@ using BACKEND."
   (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
       (let ((port (memory-port backend address)))
         (match-cell port
-          (((vtable-data-address & 7 = %tc3-struct))
+          (((vtable-address & 7 = %tc3-struct))
            (address->inferior-struct address
-                                     (- vtable-data-address %tc3-struct)
+                                     (- vtable-address %tc3-struct)
                                      backend))
           (((_ & #x7f = %tc7-symbol) buf hash props)
            (match (cell->object buf backend)