X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=391aae10f0ef8c0490cd2acc5ebce6a8eb28df94;hb=f3f1143a09fa2e50eec13614cc6b0306b2b11fad;hp=56190514113c9ededd92acb6fff5a451f19a413f;hpb=8af1983e6de2609fec800b6ac2bf3b12ff9c68b9;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 5619051..391aae1 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -49,7 +49,7 @@ ;; slow, so if anyone cares about performance of ;; non-toplevel DEFSTRUCTs, it should be rewritten to be ;; cleverer. -- WHN 2002-10-23 - (sb!c::compiler-note + (sb!c:compiler-notify "implementation limitation: ~ Non-toplevel DEFSTRUCT constructors are slow.") (with-unique-names (layout) @@ -455,7 +455,7 @@ (let ((inherited (accessor-inherited-data name defstruct))) (cond ((not inherited) - (stuff `(proclaim '(inline ,name (setf ,name)))) + (stuff `(declaim (inline ,name (setf ,name)))) ;; FIXME: The arguments in the next two DEFUNs should ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to ;; be the name of a special variable, things could get @@ -604,23 +604,27 @@ :index 0 :type t))) (multiple-value-bind (name default default-p type type-p read-only ro-p) - (cond - ((listp spec) - (destructuring-bind - (name - &optional (default nil default-p) - &key (type nil type-p) (read-only nil ro-p)) - spec - (values name - default default-p - (uncross type) type-p - read-only ro-p))) - (t - (when (keywordp spec) - (style-warn "Keyword slot name indicates probable syntax ~ - error in DEFSTRUCT: ~S." - spec)) - spec)) + (typecase spec + (symbol + (when (keywordp spec) + (style-warn "Keyword slot name indicates probable syntax ~ + error in DEFSTRUCT: ~S." + spec)) + spec) + (cons + (destructuring-bind + (name + &optional (default nil default-p) + &key (type nil type-p) (read-only nil ro-p)) + spec + (values name + default default-p + (uncross type) type-p + read-only ro-p))) + (t (error 'simple-program-error + :format-control "in DEFSTRUCT, ~S is not a legal slot ~ + description." + :format-arguments (list spec)))) (when (find name (dd-slots defstruct) :test #'string= @@ -681,12 +685,7 @@ ;;; ;;; 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 - ;; issues about the way that the cross-compiler handles them. - (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*)) - (values nil nil nil)) - ((and (sb!xc:subtypep type '(unsigned-byte 32)) + (cond ((and (sb!xc:subtypep type '(unsigned-byte 32)) (multiple-value-bind (fixnum? fixnum-certain?) (sb!xc:subtypep type 'fixnum) ;; (The extra test for FIXNUM-CERTAIN? here is @@ -806,9 +805,16 @@ (dsd-index included-slot)) (dd-inherited-accessor-alist dd) :test #'eq :key #'car)) - (parse-1-dsd dd - modified - (copy-structure included-slot))))))) + (let ((new-slot (parse-1-dsd dd + modified + (copy-structure included-slot)))) + (when (and (neq (dsd-type new-slot) (dsd-type included-slot)) + (not (subtypep (dsd-type included-slot) + (dsd-type new-slot))) + (dsd-safe-p included-slot)) + (setf (dsd-safe-p new-slot) nil) + ;; XXX: notify? + ))))))) ;;;; various helper functions for setting up DEFSTRUCTs @@ -885,29 +891,44 @@ (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-EXPANSION-DESIGNATOR ..)) for the reader -;;; and writer functions of the slot described by DSD. -(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)) + (let* ((raw-vector-bare-form + `(,ref ,instance-name ,(dd-raw-index dd))) + (raw-vector-form + (if (eq raw-type 'unsigned-byte) + (progn + (aver (= raw-n-words 1)) + (aver (eq raw-slot-accessor 'aref)) + ;; FIXME: when the 64-bit world rolls + ;; around, this will need to be reviewed, + ;; along with the whole RAW-SLOT thing. + `(truly-the (simple-array (unsigned-byte 32) (*)) + ,raw-vector-bare-form)) + raw-vector-bare-form))) + `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index))))))) + +;;; Return source transforms for the reader and writer functions of +;;; the slot described by DSD. They should be inline expanded, but +;;; source transforms work faster. +(defun slot-accessor-transforms (dd dsd) + (let ((accessor-place-form (%accessor-place-form dd dsd + `(the ,(dd-name dd) instance))) (dsd-type (dsd-type dsd)) (value-the (if (dsd-safe-p dsd) 'truly-the 'the))) - (values (lambda () `(lambda (instance) - ,instance-type-decl - (,value-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)))))) + (values (sb!c:source-transform-lambda (instance) + `(,value-the ,dsd-type ,(subst instance 'instance + accessor-place-form))) + (sb!c:source-transform-lambda (new-value instance) + (destructuring-bind (accessor-name &rest accessor-args) + accessor-place-form + `(,(info :setf :inverse accessor-name) + ,@(subst instance 'instance accessor-args) + (the ,dsd-type ,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)))) + `(lambda (new-value instance) + ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd)) + '(dummy new-value instance)))) ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities @@ -968,15 +989,15 @@ (let ((copier-name (dd-copier-name dd))) (when copier-name - (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name)))) + (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name)))) (let ((predicate-name (dd-predicate-name dd))) (when predicate-name - (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name)) + (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name)) ;; Provide inline expansion (or not). (ecase (dd-type dd) ((structure funcallable-structure) - ;; Let the predicate be inlined. + ;; Let the predicate be inlined. (setf (info :function :inline-expansion-designator predicate-name) (lambda () `(lambda (x) @@ -1002,25 +1023,18 @@ (cond ((not inherited) (multiple-value-bind (reader-designator writer-designator) - (slot-accessor-inline-expansion-designators dd dsd) - (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type) + (slot-accessor-transforms dd dsd) + (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type) ,accessor-name)) - (setf (info :function :inline-expansion-designator - accessor-name) - reader-designator - (info :function :inlinep accessor-name) - :inline) + (setf (info :function :source-transform accessor-name) + reader-designator) (unless (dsd-read-only dsd) (let ((setf-accessor-name `(setf ,accessor-name))) (sb!xc:proclaim - `(ftype (function (,dsd-type ,dtype) ,dsd-type) + `(ftype (sfunction (,dsd-type ,dtype) ,dsd-type) ,setf-accessor-name)) - (setf (info :function - :inline-expansion-designator - setf-accessor-name) - writer-designator - (info :function :inlinep setf-accessor-name) - :inline))))) + (setf (info :function :source-transform setf-accessor-name) + writer-designator))))) ((not (= (cdr inherited) (dsd-index dsd))) (style-warn "~@