[Guile-commits] 01/01: Add struct-ref/unboxed, struct-set!/unboxed

[Andy Wingo]

wingo pushed a commit to branch stable-2.2
in repository guile.

commit a74d4ee4f6e062ff640f2532c9cfc9977bb68a49
Author: Andy Wingo <address@hidden>
Date:   Mon Sep 25 21:33:22 2017 +0200

    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.
---
 NEWS                  |   9 ++++
 doc/ref/api-data.texi |  25 +++++++---
 libguile/struct.c     | 125 ++++++++++++++++++++++++++++++++++++++++++++------
 libguile/struct.h     |   2 +
 module/oop/goops.scm  |  88 +++++++++++++++++++++++------------
 5 files changed, 200 insertions(+), 49 deletions(-)

diff --git a/NEWS b/NEWS
index fec9af3..06d4d38 100644
--- a/NEWS
+++ b/NEWS
@@ -17,6 +17,11 @@ The URI standard, RFC 3986, defines additional 
"relative-ref" and
 for these URI subtypes has been improved.  See "Universal Resource
 Identifiers" in the manual, for more.
 
+** `struct-ref/unboxed' and `struct-set!/unboxed'
+
+These procedures should be used when accessing struct fields with type
+`u' (unboxed).  See "Structure Basics" in the manual, for full details.
+
 * New deprecations
 
 ** Using `uri?' as a predicate on relative-refs deprecated
@@ -81,6 +86,10 @@ To enforce permissions on struct fields, instead layer on an 
abstraction
 at a higher level, in the same way that immutable record fields are
 simply those which don't have an accessor.
 
+** Using `struct-ref' and `struct-set!' on unboxed fields is deprecated
+
+Use the new `struct-ref/unboxed' and `struct-set!/unboxed' instead.
+
 * Bug fixes
 
 ** Enable GNU Readline 7.0's support for "bracketed paste".
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index e0f8be3..677454b 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -8781,10 +8781,9 @@ it's protected against garbage collection.
 
 @item
 @code{u} -- an arbitrary word of data (an @code{scm_t_bits}).  At the
-Scheme level it's read and written as an unsigned integer.  ``u''
-stands for ``uninterpreted'' (it's not treated as a Scheme value), or
-``unprotected'' (it's not marked during GC), or ``unsigned long'' (its
-size), or all of these things.
+Scheme level it's read and written as an unsigned integer.  ``u'' stands
+for ``unboxed'', as it's stored as a raw value without additional type
+annotations.
 @end itemize
 
 The second letter for each field is a permission code,
@@ -8802,7 +8801,7 @@ Here are some examples.
 @example
 (make-vtable "pw")      ;; one writable field
 (make-vtable "prpw")    ;; one read-only and one writable
-(make-vtable "pwuwuw")  ;; one scheme and two uninterpreted
+(make-vtable "pwuwuw")  ;; one scheme and two unboxed
 @end example
 
 The optional @var{print} argument is a function called by
@@ -8840,7 +8839,7 @@ The optional @address@hidden arguments are initial values 
for the
 fields of the structure.  This is the only way to
 put values in read-only fields.  If there are fewer @var{init}
 arguments than fields then the defaults are @code{#f} for a Scheme
-field (type @code{p}) or 0 for an uninterpreted field (type @code{u}).
+field (type @code{p}) or 0 for an unboxed field (type @code{u}).
 
 The name is a bit strange, we admit.  The reason for it is that Guile
 used to have a @code{make-struct} that took an additional argument;
@@ -8890,6 +8889,20 @@ An error is thrown if @var{n} is out of range, or if the 
field cannot
 be written because it's @code{r} read-only.
 @end deffn
 
+Unboxed fields (those with type @code{u}) need to be accessed with
+special procedures.
+
address@hidden {Scheme Procedure} struct-ref/unboxed struct n
address@hidden {Scheme Procedure} struct-set!/unboxed struct n value
address@hidden {C Function} scm_struct_ref_unboxed (struct, n)
address@hidden {C Function} scm_struct_set_x_unboxed (struct, n, value)
+Like @code{struct-ref} and @code{struct-set!}, except that these may
+only be used on unboxed fields.  @code{struct-ref/unboxed} will always
+return a positive integer.  Likewise, @code{struct-set!/unboxed} takes
+an unsigned integer as the @var{value} argument, and will signal an
+error otherwise.
address@hidden deffn
+
 @deffn {Scheme Procedure} struct-vtable struct
 @deffnx {C Function} scm_struct_vtable (struct)
 Return the vtable that describes @var{struct}.
diff --git a/libguile/struct.c b/libguile/struct.c
index 1363fea..b0604f7 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -676,20 +676,37 @@ scm_i_struct_equalp (SCM s1, SCM s2)
 
   for (field_num = 0; field_num < struct_size; field_num++)
     {
-      SCM s_field_num;
-      SCM field1, field2;
-
-      /* We have to use `scm_struct_ref ()' here so that fields are accessed
-        consistently, notably wrt. field types and access rights.  */
-      s_field_num = scm_from_size_t (field_num);
-      field1 = scm_struct_ref (s1, s_field_num);
-      field2 = scm_struct_ref (s2, s_field_num);
-
-      /* Self-referencing fields (type `s') must be skipped to avoid infinite
-        recursion.  */
-      if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
-       if (scm_is_false (scm_equal_p (field1, field2)))
-         return SCM_BOOL_F;
+      scm_t_bits field1, field2;
+
+      field1 = SCM_STRUCT_DATA_REF (s1, field_num);
+      field2 = SCM_STRUCT_DATA_REF (s2, field_num);
+
+      if (field1 != field2) {
+        switch (scm_i_symbol_ref (layout, field_num * 2))
+          {
+          case 'p':
+            /* Having a normal field point to the object itself is a bit
+               bonkers, but R6RS enums do it, so here we have a horrible
+               hack.  */
+            if (field1 != SCM_UNPACK (s1) && field2 != SCM_UNPACK (s2))
+              {
+                if (scm_is_false
+                    (scm_equal_p (SCM_PACK (field1), SCM_PACK (field2))))
+                  return SCM_BOOL_F;
+              }
+            break;
+          case 's':
+            /* Skip to avoid infinite recursion.  */
+            break;
+          case 'u':
+            return SCM_BOOL_F;
+          default:
+            /* Don't bother inspecting tail arrays; we never did this in
+               the past and in the future tail arrays are going away
+               anyway.  */
+            return SCM_BOOL_F;
+          }
+      }
     }
 
   /* FIXME: Tail elements should be tested for equality.  */
@@ -765,6 +782,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
       switch (field_type)
        {
        case 'u':
+          scm_c_issue_deprecation_warning
+            ("Accessing unboxed struct fields with struct-ref is deprecated.  "
+             "Use struct-ref/unboxed instead.");
          answer = scm_from_ulong (data[p]);
          break;
 
@@ -838,6 +858,9 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
       switch (field_type)
        {
        case 'u':
+          scm_c_issue_deprecation_warning
+            ("Accessing unboxed struct fields with struct-set! is deprecated.  
"
+             "Use struct-set!/unboxed instead.");
          data[p] = SCM_NUM2ULONG (3, val);
          break;
 
@@ -859,6 +882,80 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_struct_ref_unboxed, "struct-ref/unboxed", 2, 0, 0,
+            (SCM handle, SCM pos),
+           "Access the @var{pos}th field of struct associated with\n"
+           "@var{handle}.  The field must be of type 'u'.")
+#define FUNC_NAME s_scm_struct_ref_unboxed
+{
+  SCM vtable, layout;
+  size_t layout_len, n_fields;
+  size_t p;
+
+  SCM_VALIDATE_STRUCT (1, handle);
+
+  vtable = SCM_STRUCT_VTABLE (handle);
+  p = scm_to_size_t (pos);
+
+  layout = SCM_VTABLE_LAYOUT (vtable);
+  layout_len = scm_i_symbol_length (layout);
+  n_fields = layout_len / 2;
+
+  SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+  /* Only 'u' fields, no tail arrays.  */
+  SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u',
+              layout, 0, FUNC_NAME);
+
+  /* Don't support opaque fields.  */
+  SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o',
+              layout, 0, FUNC_NAME);
+
+  return scm_from_uintptr_t (SCM_STRUCT_DATA_REF (handle, p));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_set_x_unboxed, "struct-set!/unboxed", 3, 0, 0,
+            (SCM handle, SCM pos, SCM val),
+           "Set the slot of the structure @var{handle} with index @var{pos}\n"
+           "to @var{val}.  Signal an error if the slot can not be written\n"
+           "to.")
+#define FUNC_NAME s_scm_struct_set_x_unboxed
+{
+  SCM vtable, layout;
+  size_t layout_len, n_fields;
+  size_t p;
+
+  SCM_VALIDATE_STRUCT (1, handle);
+
+  vtable = SCM_STRUCT_VTABLE (handle);
+  p = scm_to_size_t (pos);
+
+  layout = SCM_VTABLE_LAYOUT (vtable);
+  layout_len = scm_i_symbol_length (layout);
+  n_fields = layout_len / 2;
+
+  SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+  /* Only 'u' fields, no tail arrays.  */
+  SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u',
+              layout, 0, FUNC_NAME);
+
+  /* Don't support opaque fields.  */
+  SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o',
+              layout, 0, FUNC_NAME);
+
+  if (scm_i_symbol_ref (layout, p * 2 + 1) == 'r')
+    SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
+
+  SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
+
+  return val;
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0, 
             (SCM handle),
            "Return the vtable structure that describes the type of struct\n"
diff --git a/libguile/struct.h b/libguile/struct.h
index 257e40e..e53bf4f 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -185,6 +185,8 @@ SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
 SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM fields);
 SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
 SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
+SCM_API SCM scm_struct_ref_unboxed (SCM handle, SCM pos);
+SCM_API SCM scm_struct_set_x_unboxed (SCM handle, SCM pos, SCM val);
 SCM_API SCM scm_struct_vtable (SCM handle);
 SCM_API SCM scm_struct_vtable_name (SCM vtable);
 SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 4569336..3c787d7 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 '())