X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=410759cda6a9b331120af9a88a28b5f3e283c940;hb=073501ed49414d9638cb41c05fb80627529f796d;hp=8092f7d3337e9100f65c563bd37dcabdbf8aa73f;hpb=322be917a6b06f5741b0da8a6621a4f1e881bf11;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 8092f7d..410759c 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -50,21 +50,25 @@ (:conc-name dd-) (:make-load-form-fun just-dump-it-normally) #-sb-xc-host (:pure t) - (:constructor make-defstruct-description (name))) + (:constructor make-defstruct-description + (name &aux + (conc-name (symbolicate name "-")) + (copier-name (symbolicate "COPY-" name)) + (predicate-name (symbolicate name "-P"))))) ;; name of the structure - (name (missing-arg) :type symbol) + (name (missing-arg) :type symbol :read-only t) ;; documentation on the structure (doc nil :type (or string null)) ;; prefix for slot names. If NIL, none. - (conc-name (symbolicate name "-") :type (or symbol null)) + (conc-name nil :type (or symbol null)) ;; the name of the primary standard keyword constructor, or NIL if none (default-constructor nil :type (or symbol null)) ;; all the explicit :CONSTRUCTOR specs, with name defaulted (constructors () :type list) ;; name of copying function - (copier-name (symbolicate "COPY-" name) :type (or symbol null)) + (copier-name nil :type (or symbol null)) ;; name of type predicate - (predicate-name (symbolicate name "-P") :type (or symbol null)) + (predicate-name nil :type (or symbol null)) ;; the arguments to the :INCLUDE option, or NIL if no included ;; structure (include nil :type list) @@ -189,27 +193,59 @@ ;;;; shared machinery for inline and out-of-line slot accessor functions -;;; an alist mapping from raw slot type to the operator used to access -;;; the raw slot -;;; -;;; FIXME: should be shared with other src/code/*defstruct*.lisp code -;;; which refers to e.g. %RAW-REF-SINGLE, but as of sbcl-0.pre7.78 -;;; is only used by out-of-line versions (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *raw-type->rawref-fun-name* - '(;; The compiler thinks that the raw data vector is a vector of - ;; unsigned bytes, so if the slot we want to access actually *is* - ;; an unsigned byte, it'll access the slot for us even if we don't - ;; lie to it at all. - (unsigned-byte . aref) - ;; "A lie can travel halfway round the world while the truth is - ;; putting on its shoes." -- Mark Twain - (single-float . %raw-ref-single) - (double-float . %raw-ref-double) - #!+long-float (long-float . %raw-ref-long) - (complex-single-float . %raw-ref-complex-single) - (complex-double-float . %raw-ref-complex-double) - #!+long-float (complex-long-float . %raw-ref-complex-long)))) + + ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed + (defstruct raw-slot-data + ;; the raw slot type, or T for a non-raw slot + ;; + ;; (Raw slots are allocated in the raw slots array in a vector which + ;; the GC doesn't need to scavenge. Non-raw slots are in the + ;; ordinary place you'd expect, directly indexed off the instance + ;; pointer.) + (raw-type (missing-arg) :type (or symbol cons) :read-only t) + ;; What operator is used (on the raw data vector) to access a slot + ;; of this type? + (accessor-name (missing-arg) :type symbol :read-only t) + ;; How many words are each value of this type? (This is used to + ;; rescale the offset into the raw data vector.) + (n-words (missing-arg) :type (and index (integer 1)) :read-only t)) + + (defvar *raw-slot-data-list* + (list + ;; The compiler thinks that the raw data vector is a vector of + ;; word-sized unsigned bytes, so if the slot we want to access + ;; actually *is* an unsigned byte, it'll access the slot for us + ;; even if we don't lie to it at all, just let it use normal AREF. + (make-raw-slot-data :raw-type 'unsigned-byte + :accessor-name 'aref + :n-words 1) + ;; In the other cases, we lie to the compiler, making it use + ;; some low-level AREFish access in order to pun the hapless + ;; bits into some other-than-unsigned-byte meaning. + ;; + ;; "A lie can travel halfway round the world while the truth is + ;; putting on its shoes." -- Mark Twain + (make-raw-slot-data :raw-type 'single-float + :accessor-name '%raw-ref-single + :n-words 1) + (make-raw-slot-data :raw-type 'double-float + :accessor-name '%raw-ref-double + :n-words 2) + (make-raw-slot-data :raw-type 'complex-single-float + :accessor-name '%raw-ref-complex-single + :n-words 2) + (make-raw-slot-data :raw-type 'complex-double-float + :accessor-name '%raw-ref-complex-double + :n-words 4) + #!+long-float + (make-raw-slot-data :raw-type long-float + :accessor-name '%raw-ref-long + :n-words #!+x86 3 #!+sparc 4) + #!+long-float + (make-raw-slot-data :raw-type complex-long-float + :accessor-name '%raw-ref-complex-long + :n-words #!+x86 6 #!+sparc 8)))) ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its ;;;; close personal friend SB!XC:DEFSTRUCT) @@ -242,7 +278,10 @@ fun-name))) (cond ((not (eql pf 0)) `((def!method print-object ((,x ,name) ,s) - (funcall #',(farg pf) ,x ,s *current-level*)))) + (funcall #',(farg pf) + ,x + ,s + *current-level-in-print*)))) ((not (eql po 0)) `((def!method print-object ((,x ,name) ,s) (funcall #',(farg po) ,x ,s)))) @@ -483,7 +522,7 @@ (when offset (incf (dd-length dd) offset))))) (when (dd-include dd) - (do-dd-inclusion-stuff dd)) + (frob-dd-inclusion-stuff dd)) dd))) @@ -578,6 +617,8 @@ ;;; RAW? is true if TYPE should be stored in a raw slot. ;;; RAW-TYPE is the raw slot type, or NIL if no raw slot. ;;; WORDS is the number of words in the raw slot, or NIL if no raw slot. +;;; +;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*. (defun structure-raw-slot-type-and-size (type) (cond #+nil (;; FIXME: For now we suppress raw slots, since there are various @@ -642,7 +683,7 @@ ;;; Process any included slots pretty much like they were specified. ;;; Also inherit various other attributes. -(defun do-dd-inclusion-stuff (dd) +(defun frob-dd-inclusion-stuff (dd) (destructuring-bind (included-name &rest modified-slots) (dd-include dd) (let* ((type (dd-type dd)) (included-structure @@ -687,7 +728,7 @@ (dolist (included-slot (dd-slots included-structure)) (let* ((included-name (dsd-name included-slot)) (modified (or (find included-name modified-slots - :key #'(lambda (x) (if (atom x) x (car x))) + :key (lambda (x) (if (atom x) x (car x))) :test #'string=) `(,included-name)))) (parse-1-dsd dd @@ -719,7 +760,7 @@ (vector super))))) ;;; Do miscellaneous (LOAD EVAL) time actions for the structure -;;; described by DD. Create the class & LAYOUT, checking for +;;; described by DD. Create the class and LAYOUT, checking for ;;; incompatible redefinition. Define those functions which are ;;; sufficiently stereotyped that we can implement them as standard ;;; closures. @@ -743,14 +784,9 @@ (setq layout (class-layout class)))) (setf (sb!xc:find-class (dd-name dd)) class) - ;; It doesn't make sense to do these in the cross-compilation host. + ;; Various other operations only make sense on the target SBCL. #-sb-xc-host - (progn - (remhash (dd-name dd) *typecheckfuns*) - (%target-defstruct dd layout) - (when (dd-doc dd) - (setf (fdocumentation (dd-name dd) 'type) - (dd-doc dd))))) + (%target-defstruct dd layout)) (values)) @@ -766,41 +802,38 @@ (raw-type (dsd-raw-type dsd))) (if (eq raw-type t) ; if not raw slot `(,ref ,instance-name ,(dsd-index dsd)) - (let (;; the operator that we'll use to access one value in - ;; the raw data vector - (rawref (ecase raw-type - ;; The compiler thinks that the raw data - ;; vector is a vector of unsigned bytes, so if - ;; the slot we want to access actually *is* an - ;; unsigned byte, it'll access the slot for - ;; us even if we don't lie to it at all. - (unsigned-byte 'aref) - ;; "A lie can travel halfway round the world while - ;; the truth is putting on its shoes." -- Mark Twain - (single-float '%raw-ref-single) - (double-float '%raw-ref-double) - #!+long-float (long-float '%raw-ref-long) - (complex-single-float '%raw-ref-complex-single) - (complex-double-float '%raw-ref-complex-double) - #!+long-float (complex-long-float - '%raw-ref-complex-long)))) - `(,rawref (,ref ,instance-name ,(dd-raw-index dd)) - ,(dsd-index dsd)))))) + (let* ((raw-slot-data (find raw-type *raw-slot-data-list* + :key #'raw-slot-data-raw-type + :test #'equal)) + (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data)) + (raw-n-words (raw-slot-data-n-words raw-slot-data))) + (multiple-value-bind (scaled-dsd-index misalignment) + (floor (dsd-index dsd) raw-n-words) + (aver (zerop misalignment)) + `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd)) + ,scaled-dsd-index)))))) ;;; Return inline expansion designators (i.e. values suitable for -;;; (INFO :FUNCTION :INLINE-EXPANSSION-DESIGNATOR ..)) for the reader +;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader ;;; and writer functions of the slot described by DSD. -(defun accessor-inline-expansion-designators (dd dsd) - (values (lambda () - `(lambda (instance) - (declare (type ,(dd-name dd) instance)) - (truly-the ,(dsd-type dsd) - ,(%accessor-place-form dd dsd 'instance)))) - (lambda () - `(lambda (new-value instance) - (declare (type ,(dsd-type dsd) new-value)) - (declare (type ,(dd-name dd) structure-object)) - (setf ,(%accessor-place-form dd dsd 'instance) new-value))))) +(defun slot-accessor-inline-expansion-designators (dd dsd) + (let ((instance-type-decl `(declare (type ,(dd-name dd) instance))) + (accessor-place-form (%accessor-place-form dd dsd 'instance)) + (dsd-type (dsd-type dsd))) + (values (lambda () + `(lambda (instance) + ,instance-type-decl + (truly-the ,dsd-type ,accessor-place-form))) + (lambda () + `(lambda (new-value instance) + (declare (type ,dsd-type new-value)) + ,instance-type-decl + (setf ,accessor-place-form new-value)))))) + +;;; Return a LAMBDA form which can be used to set a slot. +(defun slot-setter-lambda-form (dd dsd) + (funcall (nth-value 1 + (slot-accessor-inline-expansion-designators dd dsd)))) ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities @@ -857,9 +890,7 @@ (%compiler-set-up-layout dd inherits) - (let* ((dd-name (dd-name dd)) - (dtype (dd-declarable-type dd)) - (class (sb!xc:find-class dd-name))) + (let* ((dtype (dd-declarable-type dd))) (let ((copier-name (dd-copier-name dd))) (when copier-name @@ -894,7 +925,7 @@ (dsd-type (dsd-type dsd))) (when accessor-name (multiple-value-bind (reader-designator writer-designator) - (accessor-inline-expansion-designators dd dsd) + (slot-accessor-inline-expansion-designators dd dsd) (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type) ,accessor-name)) (setf (info :function :inline-expansion-designator accessor-name) @@ -1094,53 +1125,6 @@ (res))) -;;;; slot accessors for raw slots - -;;; Return info about how to read/write a slot in the value stored in -;;; OBJECT. This is also used by constructors (since we can't safely -;;; use the accessor function, since some slots are read-only). If -;;; supplied, DATA is a variable holding the raw-data vector. -;;; -;;; returned values: -;;; 1. accessor function name (SETFable) -;;; 2. index to pass to accessor. -;;; 3. object form to pass to accessor -(defun slot-accessor-form (defstruct slot object &optional data) - (let ((rtype (dsd-raw-type slot))) - (values - (ecase rtype - (single-float '%raw-ref-single) - (double-float '%raw-ref-double) - #!+long-float - (long-float '%raw-ref-long) - (complex-single-float '%raw-ref-complex-single) - (complex-double-float '%raw-ref-complex-double) - #!+long-float - (complex-long-float '%raw-ref-complex-long) - (unsigned-byte 'aref) - ((t) '%instance-ref)) - (case rtype - #!+long-float - (complex-long-float - (truncate (dsd-index slot) #!+x86 6 #!+sparc 8)) - #!+long-float - (long-float - (truncate (dsd-index slot) #!+x86 3 #!+sparc 4)) - (double-float - (ash (dsd-index slot) -1)) - (complex-double-float - (ash (dsd-index slot) -2)) - (complex-single-float - (ash (dsd-index slot) -1)) - (t - (dsd-index slot))) - (cond - ((eq rtype t) object) - (data) - (t - `(truly-the (simple-array (unsigned-byte 32) (*)) - (%instance-ref ,object ,(dd-raw-index defstruct)))))))) - ;;; These functions are called to actually make a constructor after we ;;; have processed the arglist. The correct variant (according to the ;;; DD-TYPE) should be called. The function is defined with the @@ -1152,23 +1136,25 @@ ;;; various weird places, whereas STRUCTURE structures have ;;; a LAYOUT slot. ;;; * We really want to use LIST to make list structures, instead of -;;; MAKE-LIST/(SETF ELT). +;;; MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an +;;; analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed +;;; structures can have arbitrary subtypes of VECTOR, not necessarily +;;; SIMPLE-VECTOR.) ;;; * STRUCTURE structures can have raw slots that must also be -;;; allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM -;;; to compute how to set the slots, which deals with raw slots. +;;; allocated and indirectly referenced. (defun create-vector-constructor (dd cons-name arglist vars types values) (let ((temp (gensym)) (etype (dd-element-type dd))) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var)) + (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var)) vars types)) (let ((,temp (make-array ,(dd-length dd) :element-type ',(dd-element-type dd)))) - ,@(mapcar #'(lambda (x) - `(setf (aref ,temp ,(cdr x)) ',(car x))) + ,@(mapcar (lambda (x) + `(setf (aref ,temp ,(cdr x)) ',(car x))) (find-name-indices dd)) - ,@(mapcar #'(lambda (dsd value) - `(setf (aref ,temp ,(dsd-index dsd)) ,value)) + ,@(mapcar (lambda (dsd value) + `(setf (aref ,temp ,(dsd-index dsd)) ,value)) (dd-slots dd) values) ,temp)))) (defun create-list-constructor (dd cons-name arglist vars types values) @@ -1179,33 +1165,32 @@ (setf (elt vals (dsd-index dsd)) val)) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) - vars types)) + (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) (list ,@vals)))) (defun create-structure-constructor (dd cons-name arglist vars types values) - (let* ((temp (gensym)) - (raw-index (dd-raw-index dd)) - (n-raw-data (when raw-index (gensym)))) + (let* ((instance (gensym "INSTANCE")) + (raw-index (dd-raw-index dd))) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) + (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) - (let ((,temp (truly-the ,(dd-name dd) - (%make-instance ,(dd-length dd)))) - ,@(when n-raw-data - `((,n-raw-data - (make-array ,(dd-raw-length dd) - :element-type '(unsigned-byte 32)))))) - (setf (%instance-layout ,temp) - (%delayed-get-compiler-layout ,(dd-name dd))) - ,@(when n-raw-data - `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data))) + (let ((,instance (truly-the ,(dd-name dd) + (%make-instance-with-layout + (%delayed-get-compiler-layout ,(dd-name dd)))))) + (declare (optimize (safety 0))) ; Suppress redundant slot type checks. + ,@(when raw-index + `((setf (%instance-ref ,instance ,raw-index) + (make-array ,(dd-raw-length dd) + :element-type '(unsigned-byte 32))))) ,@(mapcar (lambda (dsd value) - (multiple-value-bind (accessor index data) - (slot-accessor-form dd dsd temp n-raw-data) - `(setf (,accessor ,data ,index) ,value))) + ;; (Note that we can't in general use the + ;; ordinary named slot setter function here + ;; because the slot might be :READ-ONLY, so we + ;; whip up new LAMBDA representations of slot + ;; setters for the occasion.) + `(,(slot-setter-lambda-form dd dsd) ,value ,instance)) (dd-slots dd) values) - ,temp)))) + ,instance)))) ;;; Create a default (non-BOA) keyword constructor. (defun create-keyword-constructor (defstruct creator) @@ -1252,9 +1237,16 @@ (dolist (arg opt) (cond ((consp arg) (destructuring-bind - (name &optional (def (nth-value 1 (get-slot name)))) + ;; FIXME: this shares some logic (though not + ;; code) with the &key case below (and it + ;; looks confusing) -- factor out the logic + ;; if possible. - CSR, 2002-04-19 + (name + &optional + (def (nth-value 1 (get-slot name))) + (supplied-test nil supplied-test-p)) arg - (arglist `(,name ,def)) + (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types (get-slot name)))) (t @@ -1269,14 +1261,20 @@ (arglist '&key) (dolist (key keys) (if (consp key) - (destructuring-bind (wot &optional (def nil def-p)) key + (destructuring-bind (wot + &optional + (def nil def-p) + (supplied-test nil supplied-test-p)) + key (let ((name (if (consp wot) (destructuring-bind (key var) wot (declare (ignore key)) var) wot))) - (multiple-value-bind (type slot-def) (get-slot name) - (arglist `(,wot ,(if def-p def slot-def))) + (multiple-value-bind (type slot-def) + (get-slot name) + (arglist `(,wot ,(if def-p def slot-def) + ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types type)))) (do-default key)))) @@ -1294,9 +1292,9 @@ (funcall creator defstruct (first boa) (arglist) (vars) (types) - (mapcar #'(lambda (slot) - (or (find (dsd-name slot) (vars) :test #'string=) - (dsd-default slot))) + (mapcar (lambda (slot) + (or (find (dsd-name slot) (vars) :test #'string=) + (dsd-default slot))) (dd-slots defstruct)))))) ;;; Grovel the constructor options, and decide what constructors (if @@ -1422,7 +1420,6 @@ :metaclass-name metaclass-name :metaclass-constructor metaclass-constructor :dd-type dd-type)) - (conc-name (concatenate 'string (symbol-name class-name) "-")) (dd-slots (dd-slots dd)) (dd-length (1+ (length slot-names))) (object-gensym (gensym "OBJECT"))