mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-17 01:00:20 +02:00
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.
This commit is contained in:
Andy Wingo
parent
f23415589a
commit
a74d4ee4f6
5 changed files with 198 additions and 47 deletions
|
|
@ -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 '())
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue