Add struct-ref/unboxed, struct-set!/unboxed

* NEWS: Add news entry.
* doc/ref/api-data.texi (Vtables, Structure Basics): Update
  documentation.
* libguile/struct.c (scm_i_struct_equalp): Avoid using struct-ref on
  unboxed fields.
  (scm_struct_ref, scm_struct_set_x_unboxed): Issue deprecation warning
  when accessing unboxed fields.
  (scm_struct_ref_unboxed, scm_struct_set_x_unboxed): New functions.
* libguile/struct.h (scm_struct_ref_unboxed, scm_struct_set_x_unboxed):
  New functions.
* module/oop/goops.scm (class-add-flags!, class-clear-flags!):
  (class-has-flags?, <class>, %allocate-instance, <slot>):
  (compute-get-n-set, unboxed-get, unboxed-set, unboxed-slot?):
  (allocate-slots, %prep-layout!, make-standard-class, initialize):
  Adapt to access unboxed nfields and flags fields via the new
  accessors.

1 files changed, 59 insertions, 29 deletions

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 4569336a9..3c787d763 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -256,16 +256,20 @@
   (logior vtable-flag-vtable vtable-flag-goops-class))
 
 (define-inlinable (class-add-flags! class flags)
-  (struct-set! class class-index-flags
-               (logior flags (struct-ref class class-index-flags))))
+  (struct-set!/unboxed
+   class
+   class-index-flags
+   (logior flags (struct-ref/unboxed class class-index-flags))))
 
 (define-inlinable (class-clear-flags! class flags)
-  (struct-set! class class-index-flags
-               (logand (lognot flags) (struct-ref class class-index-flags))))
+  (struct-set!/unboxed
+   class
+   class-index-flags
+   (logand (lognot flags) (struct-ref/unboxed class class-index-flags))))
 
 (define-inlinable (class-has-flags? class flags)
   (eqv? flags
-        (logand (struct-ref class class-index-flags) flags)))
+        (logand (struct-ref/unboxed class class-index-flags) flags)))
 
 (define-inlinable (class? obj)
   (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
@@ -312,7 +316,7 @@
       (class-add-flags! <class> (logior vtable-flag-goops-class
                                         vtable-flag-goops-valid))
       (struct-set! <class> class-index-name '<class>)
-      (struct-set! <class> class-index-nfields nfields)
+      (struct-set!/unboxed <class> class-index-nfields nfields)
       (struct-set! <class> class-index-direct-supers '())
       (struct-set! <class> class-index-direct-slots '())
       (struct-set! <class> class-index-direct-subclasses '())
@@ -407,7 +411,8 @@ followed by its associated value.  If @var{l} does not hold a value for
   (eq? x *unbound*))
 
 (define (%allocate-instance class)
-  (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
+  (let ((obj (allocate-struct class
+                              (struct-ref/unboxed class class-index-nfields))))
     (%clear-fields! obj *unbound*)
     obj))
 
@@ -423,7 +428,7 @@ followed by its associated value.  If @var{l} does not hold a value for
                                        vtable-flag-goops-slot
                                        vtable-flag-goops-valid))
       (struct-set! <slot> class-index-name '<slot>)
-      (struct-set! <slot> class-index-nfields nfields)
+      (struct-set!/unboxed <slot> class-index-nfields nfields)
       (struct-set! <slot> class-index-direct-supers '())
       (struct-set! <slot> class-index-direct-slots '())
       (struct-set! <slot> class-index-direct-subclasses '())
@@ -686,8 +691,8 @@ followed by its associated value.  If @var{l} does not hold a value for
 
 ;; Boot definition.
 (define (compute-get-n-set class slot)
-  (let ((index (struct-ref class class-index-nfields)))
-    (struct-set! class class-index-nfields (1+ index))
+  (let ((index (struct-ref/unboxed class class-index-nfields)))
+    (struct-set!/unboxed class class-index-nfields (1+ index))
     index))
 
 ;;; Pre-generate getters and setters for the first 20 slots.
@@ -719,9 +724,18 @@ followed by its associated value.  If @var{l} does not hold a value for
 (define-standard-accessor-method ((standard-set n) o v)
   (struct-set! o n v))
 
+(define-standard-accessor-method ((unboxed-get n) o)
+  (struct-ref/unboxed o n))
+
+(define-standard-accessor-method ((unboxed-set n) o v)
+  (struct-set!/unboxed o n v))
+
 ;; Boot definitions.
 (define (opaque-slot? slot) #f)
 (define (read-only-slot? slot) #f)
+(define (unboxed-slot? slot)
+  (memq (%slot-definition-name slot)
+        '(flags instance-finalizer nfields %reserved)))
 
 (define (allocate-slots class slots)
   "Transform the computed list of direct slot definitions @var{slots}
@@ -733,20 +747,25 @@ slots as we go."
     ;; the behavior for backward compatibility.
     (let* ((slot (compute-effective-slot-definition class slot))
            (name (%slot-definition-name slot))
-           (index (struct-ref class class-index-nfields))
+           (index (struct-ref/unboxed class class-index-nfields))
            (g-n-s (compute-get-n-set class slot))
-           (size (- (struct-ref class class-index-nfields) index)))
+           (size (- (struct-ref/unboxed class class-index-nfields) index)))
       (call-with-values
           (lambda ()
             (match g-n-s
               ((? integer?)
                (unless (= size 1)
                  (error "unexpected return from compute-get-n-set"))
-               (values (standard-get g-n-s)
-                       (if (slot-definition-init-thunk slot)
-                           (standard-get g-n-s)
-                           (bound-check-get g-n-s))
-                       (standard-set g-n-s)))
+               (cond
+                ((unboxed-slot? slot)
+                 (let ((get (unboxed-get g-n-s)))
+                   (values get get (unboxed-set g-n-s))))
+                (else
+                 (values (standard-get g-n-s)
+                         (if (slot-definition-init-thunk slot)
+                             (standard-get g-n-s)
+                             (bound-check-get g-n-s))
+                         (standard-set g-n-s)))))
               (((? procedure? get) (? procedure? set))
                (values get
                        (lambda (o)
@@ -765,12 +784,19 @@ slots as we go."
                        (lambda (o v)
                          (error "Slot is opaque" name)))
                       ((read-only-slot? slot)
-                       (lambda (o v)
-                         (let ((v* (get/raw o)))
-                           (if (unbound? v*)
-                               ;; Allow initialization.
-                               (set o v)
-                               (error "Slot is read-only" name)))))
+                       (if (unboxed-slot? slot)
+                           (lambda (o v)
+                             (let ((v* (get/raw o)))
+                               (if (zero? v*)
+                                   ;; Allow initialization.
+                                   (set o v)
+                                   (error "Slot is read-only" name))))
+                           (lambda (o v)
+                             (let ((v* (get/raw o)))
+                               (if (unbound? v*)
+                                   ;; Allow initialization.
+                                   (set o v)
+                                   (error "Slot is read-only" name))))))
                       (else set))))
             (struct-set! slot slot-index-slot-ref/raw get/raw)
             (struct-set! slot slot-index-slot-ref get)
@@ -778,7 +804,7 @@ slots as we go."
             (struct-set! slot slot-index-index index)
             (struct-set! slot slot-index-size size))))
       slot))
-  (struct-set! class class-index-nfields 0)
+  (struct-set!/unboxed class class-index-nfields 0)
   (map-in-order make-effective-slot-definition slots))
 
 (define (%compute-layout slots nfields is-class?)
@@ -828,7 +854,7 @@ slots as we go."
 (define (%prep-layout! class)
   (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
          (layout (%compute-layout (struct-ref class class-index-slots)
-                                  (struct-ref class class-index-nfields)
+                                  (struct-ref/unboxed class class-index-nfields)
                                   is-class?)))
     (%init-layout! class layout)))
 
@@ -839,7 +865,7 @@ slots as we go."
         (compute-direct-slot-definition z initargs)))
 
     (struct-set! z class-index-name name)
-    (struct-set! z class-index-nfields 0)
+    (struct-set!/unboxed z class-index-nfields 0)
     (struct-set! z class-index-direct-supers dsupers)
     (struct-set! z class-index-direct-subclasses '())
     (struct-set! z class-index-direct-methods '())
@@ -914,6 +940,10 @@ slots as we go."
 
 (define (opaque-slot? slot) (is-a? slot <opaque-slot>))
 (define (read-only-slot? slot) (is-a? slot <read-only-slot>))
+(define (unboxed-slot? slot)
+  (and (is-a? slot <foreign-slot>)
+       (not (is-a? slot <self-slot>))
+       (not (is-a? slot <protected-slot>))))
 
 
 
@@ -2748,8 +2778,8 @@ function."
   (case (slot-definition-allocation s)
     ((#:instance) ;; Instance slot
      ;; get-n-set is just its offset
-     (let ((already-allocated (struct-ref class class-index-nfields)))
-       (struct-set! class class-index-nfields (+ already-allocated 1))
+     (let ((already-allocated (struct-ref/unboxed class class-index-nfields)))
+       (struct-set!/unboxed class class-index-nfields (+ already-allocated 1))
        already-allocated))
 
     ((#:class) ;; Class slot
@@ -2862,7 +2892,7 @@ var{initargs}."
   (class-add-flags! class (logior vtable-flag-goops-class
                                   vtable-flag-goops-valid))
   (struct-set! class class-index-name (get-keyword #:name initargs '???))
-  (struct-set! class class-index-nfields 0)
+  (struct-set!/unboxed class class-index-nfields 0)
   (struct-set! class class-index-direct-supers
                (get-keyword #:dsupers initargs '()))
   (struct-set! class class-index-direct-subclasses '())