[Guile-commits] 05/07: remove self field of vtables

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit ee5994a5178c14de685011c28e3c3c0a0a353622
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 13 22:23:20 2017 +0200

    remove self field of vtables
    
    * libguile/struct.h (SCM_VTABLE_BASE_LAYOUT, scm_vtable_index_self):
      Remove "self" field.  Renumber the other fields.
    * module/oop/goops.scm (<self-slot>): Remove.
      (fold-class-slots): Adapt for "self" slot removal.  Adapt all users.
      (class-redefinition): Now that there is no "self" slot to update, use
      %modify-instance instead of %modify-class.
    * libguile/goops.c (class_self): Remove.
      (scm_sys_modify_class): Remove.
    * libguile/goops.h (scm_sys_modify_class): Remove.
    * module/rnrs/records/procedural.scm: Import vtable-offset-user.
      Renumber rtd indexes using vtable-offset-user.
    * module/srfi/srfi-35.scm (%condition-type-vtable): Remove mention of
      vtable fields.
    * module/system/base/types.scm (address->inferior-struct): Adapt for
      different vtable field layout.
---
 libguile/goops.c                   | 19 +------------------
 libguile/goops.h                   |  1 -
 libguile/struct.h                  | 14 ++++++--------
 module/oop/goops.scm               | 10 ++--------
 module/rnrs/records/procedural.scm | 22 ++++++++++++----------
 module/srfi/srfi-35.scm            |  1 -
 module/system/base/types.scm       |  4 ++--
 7 files changed, 23 insertions(+), 48 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 7e7a265..d0e6463 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -115,7 +115,7 @@ static SCM class_atomic_box;
 static SCM class_port, class_input_output_port;
 static SCM class_input_port, class_output_port;
 static SCM class_foreign_slot;
-static SCM class_self, class_protected;
+static SCM class_protected;
 static SCM class_hidden, class_opaque, class_read_only;
 static SCM class_protected_hidden, class_protected_opaque, 
class_protected_read_only;
 static SCM class_scm;
@@ -542,22 +542,6 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 
2, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
-           (SCM old, SCM new),
-           "")
-#define FUNC_NAME s_scm_sys_modify_class
-{
-  SCM_VALIDATE_CLASS (1, old);
-  SCM_VALIDATE_CLASS (2, new);
-
-  scm_sys_modify_instance (old, new);
-  SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
-  SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
-
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
 
 
 /* Primitive generics: primitives that can dispatch to generics if their
@@ -920,7 +904,6 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 
0, 0, 0,
   class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
   class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
   class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
-  class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
   class_protected_opaque = scm_variable_ref (scm_c_lookup 
("<protected-opaque-slot>"));
   class_protected_hidden = scm_variable_ref (scm_c_lookup 
("<protected-hidden-slot>"));
   class_protected_read_only = scm_variable_ref (scm_c_lookup 
("<protected-read-only-slot>"));
diff --git a/libguile/goops.h b/libguile/goops.h
index 202fef9..332635b 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -130,7 +130,6 @@ SCM_API SCM scm_method_procedure (SCM obj);
 SCM_API SCM scm_slot_bound_p (SCM obj, SCM slot_name);
 SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name);
 SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
-SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls);
 SCM_API SCM scm_generic_capability_p (SCM proc);
 SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
 SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic);
diff --git a/libguile/struct.h b/libguile/struct.h
index 0dfcf46..25d5ae5 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -56,7 +56,6 @@
 #define SCM_VTABLE_BASE_LAYOUT                                          \
   "pr" /* layout */                                                     \
   "uh" /* flags */                                                     \
-  "sr" /* self */                                                       \
   "uh" /* finalizer */                                                  \
   "pw" /* printer */                                                    \
   "ph" /* name (hidden from make-struct for back-compat reasons) */     \
@@ -65,13 +64,12 @@
 
 #define scm_vtable_index_layout            0 /* A symbol describing the 
physical arrangement of this type. */
 #define scm_vtable_index_flags            1 /* Class flags */
-#define scm_vtable_index_self             2 /* A pointer to the vtable itself 
*/
-#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of 
this struct type. */
-#define scm_vtable_index_instance_printer  4 /* A printer for this struct 
type. */
-#define scm_vtable_index_name              5 /* Name of this vtable. */
-#define scm_vtable_index_size              6 /* Number of fields, for simple 
structs.  */
-#define scm_vtable_index_reserved_7        7
-#define scm_vtable_offset_user             8 /* Where do user fields start in 
the vtable? */
+#define scm_vtable_index_instance_finalize 2 /* Finalizer for instances of 
this struct type. */
+#define scm_vtable_index_instance_printer  3 /* A printer for this struct 
type. */
+#define scm_vtable_index_name              4 /* Name of this vtable. */
+#define scm_vtable_index_size              5 /* Number of fields, for simple 
structs.  */
+#define scm_vtable_index_reserved_7        6
+#define scm_vtable_offset_user             7 /* Where do user fields start in 
the vtable? */
 
 /* All applicable structs have the following fields. */
 #define SCM_APPLICABLE_BASE_LAYOUT              \
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index f943324..19e68ad 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -42,7 +42,7 @@
             ;; Slot types.
             <slot>
             <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
-            <read-only-slot> <self-slot> <protected-opaque-slot>
+            <read-only-slot> <protected-opaque-slot>
             <protected-hidden-slot> <protected-read-only-slot>
             <scm-slot> <int-slot> <float-slot> <double-slot>
 
@@ -186,7 +186,6 @@
 (define-macro-folder fold-class-slots
   (layout #:class <protected-read-only-slot>)
   (flags #:class <hidden-slot>)
-  (self #:class <self-slot>)
   (instance-finalizer #:class <hidden-slot>)
   (print)
   (name #:class <protected-hidden-slot>)
@@ -306,15 +305,12 @@
                 ;; A simple way to compute class layout for the concrete
                 ;; types used in <class>.
                 (syntax-rules (<protected-read-only-slot>
-                               <self-slot>
                                <hidden-slot>
                                <protected-hidden-slot>)
                   ((_ (name) tail)
                    (string-append "pw" tail))
                   ((_ (name #:class <protected-read-only-slot>) tail)
                    (string-append "pr" tail))
-                  ((_ (name #:class <self-slot>) tail)
-                   (string-append "sr" tail))
                   ((_ (name #:class <hidden-slot>) tail)
                    (string-append "uh" tail))
                   ((_ (name #:class <protected-hidden-slot>) tail)
@@ -779,7 +775,6 @@ slots as we go."
     (let ((type (get-keyword #:class (%slot-definition-options slot))))
       (if (and type (subclass? type <foreign-slot>))
           (values (cond
-                   ((subclass? type <self-slot>) #\s)
                    ((subclass? type <protected-slot>) #\p)
                    (else #\u))
                   (cond
@@ -892,7 +887,6 @@ slots as we go."
 (define-standard-class <hidden-slot> (<foreign-slot>))
 (define-standard-class <opaque-slot> (<foreign-slot>))
 (define-standard-class <read-only-slot> (<foreign-slot>))
-(define-standard-class <self-slot> (<read-only-slot>))
 (define-standard-class <protected-opaque-slot> (<protected-slot>
                                                 <opaque-slot>))
 (define-standard-class <protected-hidden-slot> (<protected-slot>
@@ -3110,7 +3104,7 @@ var{initargs}."
             (class-direct-supers new))
 
   ;; Swap object headers
-  (%modify-class old new)
+  (%modify-instance old new)
 
   ;; Now old is NEW!
 
diff --git a/module/rnrs/records/procedural.scm 
b/module/rnrs/records/procedural.scm
index 6976eeb..d925263 100644
--- a/module/rnrs/records/procedural.scm
+++ b/module/rnrs/records/procedural.scm
@@ -54,22 +54,24 @@
                        hashq-ref
                        hashq-set!
 
-                       vector->list)
+                       vector->list
+
+                        vtable-offset-user)
          (ice-9 receive)
          (only (srfi :1) fold split-at take))
 
   (define (record-internal? obj)
     (and (struct? obj) (record-type-descriptor? (struct-vtable obj))))
 
-  (define rtd-index-name 8)
-  (define rtd-index-uid 9)
-  (define rtd-index-parent 10)
-  (define rtd-index-sealed? 11)
-  (define rtd-index-opaque? 12)
-  (define rtd-index-predicate 13)
-  (define rtd-index-field-names 14)
-  (define rtd-index-field-bit-field 15)
-  (define rtd-index-field-binder 16)
+  (define rtd-index-name            (+ vtable-offset-user 0))
+  (define rtd-index-uid             (+ vtable-offset-user 1))
+  (define rtd-index-parent          (+ vtable-offset-user 2))
+  (define rtd-index-sealed?         (+ vtable-offset-user 3))
+  (define rtd-index-opaque?         (+ vtable-offset-user 4))
+  (define rtd-index-predicate       (+ vtable-offset-user 5))
+  (define rtd-index-field-names     (+ vtable-offset-user 6))
+  (define rtd-index-field-bit-field (+ vtable-offset-user 7))
+  (define rtd-index-field-binder    (+ vtable-offset-user 8))
 
   (define rctd-index-rtd 0)
   (define rctd-index-parent 1)
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 8f86bce..0f0ab3c 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -46,7 +46,6 @@
 
 (define %condition-type-vtable
   ;; The vtable of all condition types.
-  ;;   vtable fields: vtable, self, printer
   ;;   user fields:   id, parent, all-field-names
   (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
                         (lambda (ct port)
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 0652885..daf8bdf 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -369,8 +369,8 @@ TYPE-NUMBER."
 (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)
+  (define %vtable-layout-index vtable-index-layout)
+  (define %vtable-name-index 4)
 
   (let* ((vtable-data-address (+ vtable-address %word-size))
          (layout-address (+ vtable-data-address