X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=33dc00d359210c34b90d164375e78e22af8b05f8;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=803a61ffb29748bba7180ce3e668c0d24bf42c11;hpb=58a0e578e00abcb85940021d5ef3051c0b4c2082;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 803a61f..33dc00d 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -133,8 +133,18 @@ (if (funcallable-instance-p new-value) (%funcallable-instance-lexenv new-value) new-value))) + +;;; service function for structure constructors +(defun %make-instance-with-layout (layout) + (let ((result (%make-instance (layout-length layout)))) + (setf (%instance-layout result) layout) + result)) -;;;; target-only parts of the DEFSTRUCT top-level code +;;;; target-only parts of the DEFSTRUCT top level code + +;;; A list of hooks designating functions of one argument, the +;;; classoid, to be called when a defstruct is evaluated. +(defvar *defstruct-hooks* nil) ;;; Catch attempts to mess up definitions of symbols in the CL package. (defun protect-cl (symbol) @@ -148,9 +158,7 @@ (/show0 "leaving PROTECT-CL") (values)) -;;; the part of %DEFSTRUCT which sets up out-of-line implementations -;;; of those structure functions which are sufficiently similar -;;; between structures that they can be closures +;;; the part of %DEFSTRUCT which makes sense only on the target SBCL ;;; ;;; (The "static" in the name is because it needs to be done not only ;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as @@ -162,28 +170,33 @@ (/show0 "entering %TARGET-DEFSTRUCT") + (remhash (dd-name dd) *typecheckfuns*) + ;; (Constructors aren't set up here, because constructors are ;; varied enough (possibly parsing any specified argument list) - ;; that we can't reasonably implement them as closures, and so + ;; that we can't reasonably implement them as closures, so we ;; implement them with DEFUN instead.) ;; Set FDEFINITIONs for slot accessors. (dolist (dsd (dd-slots dd)) (/show0 "doing FDEFINITION for slot accessor") (let ((accessor-name (dsd-accessor-name dsd))) - (/show0 "ACCESSOR-NAME=..") - (/hexstr accessor-name) - (protect-cl accessor-name) - (/hexstr "getting READER-FUN and WRITER-FUN") - (multiple-value-bind (reader-fun writer-fun) (slot-accessor-funs dd dsd) - (declare (type function reader-fun writer-fun)) - (/show0 "got READER-FUN and WRITER-FUN=..") - (/hexstr reader-fun) - (setf (symbol-function accessor-name) reader-fun) - (unless (dsd-read-only dsd) - (/show0 "setting FDEFINITION for WRITER-FUN=..") - (/hexstr writer-fun) - (setf (fdefinition `(setf ,accessor-name)) writer-fun))))) + ;; We mustn't step on any inherited accessors + (unless (accessor-inherited-data accessor-name dd) + (/show0 "ACCESSOR-NAME=..") + (/hexstr accessor-name) + (protect-cl accessor-name) + (/hexstr "getting READER-FUN and WRITER-FUN") + (multiple-value-bind (reader-fun writer-fun) + (slot-accessor-funs dd dsd) + (declare (type function reader-fun writer-fun)) + (/show0 "got READER-FUN and WRITER-FUN=..") + (/hexstr reader-fun) + (setf (symbol-function accessor-name) reader-fun) + (unless (dsd-read-only dsd) + (/show0 "setting FDEFINITION for WRITER-FUN=..") + (/hexstr writer-fun) + (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))) ;; Set FDEFINITION for copier. (when (dd-copier-name dd) @@ -207,11 +220,12 @@ ((structure funcallable-structure) (/show0 "with-LAYOUT case") (lambda (object) - (declare (optimize (speed 3) (safety 0))) - (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") - (/nohexstr object) - (/nohexstr layout) - (typep-to-layout object layout))) + (locally ; <- to keep SAFETY 0 from affecting arg count checking + (declare (optimize (speed 3) (safety 0))) + (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") + (/nohexstr object) + (/nohexstr layout) + (typep-to-layout object layout)))) ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST) ;; ;; FIXME: should handle the :NAMED T case in these cases @@ -222,9 +236,17 @@ (/show0 ":TYPE LIST case") #'listp)))) + (when (dd-doc dd) + (setf (fdocumentation (dd-name dd) 'type) + (dd-doc dd))) + + ;; the BOUNDP test here is to get past cold-init. + (when (boundp '*defstruct-hooks*) + (dolist (fun *defstruct-hooks*) + (funcall fun (find-classoid (dd-name dd))))) + (/show0 "leaving %TARGET-DEFSTRUCT") (values)) - ;;;; generating out-of-line slot accessor functions @@ -254,7 +276,7 @@ (dsd-raw-type (dsd-raw-type dsd))) #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code") ;; Map over all the possible RAW-TYPEs, compiling - ;; a different closure-function for each one, so + ;; a different closure function for each one, so ;; that once the COND over RAW-TYPEs happens (at ;; the time closure is allocated) there are no ;; more decisions to be made and things execute @@ -267,24 +289,28 @@ (,dd-ref-fun-name instance dsd-index) ,instance-type-check-form)) ;; raw slot cases - ,@(mapcar (lambda (raw-type-and-rawref-fun-name) - (destructuring-bind (raw-type - . rawref-fun-name) - raw-type-and-rawref-fun-name + ,@(mapcar (lambda (rtd) + (let ((raw-type (raw-slot-data-raw-type rtd)) + (accessor-name + (raw-slot-data-accessor-name rtd)) + (n-words (raw-slot-data-n-words rtd))) `((equal dsd-raw-type ',raw-type) #+sb-xc (/show0 "in raw slot case") (let ((raw-index (dd-raw-index dd))) - (%slotplace-accessor-funs - (,rawref-fun-name (,dd-ref-fun-name + (multiple-value-bind (scaled-dsd-index + misalignment) + (floor dsd-index ,n-words) + (aver (zerop misalignment)) + (%slotplace-accessor-funs + (,accessor-name (,dd-ref-fun-name instance raw-index) - dsd-index) - ,instance-type-check-form))))) - *raw-type->rawref-fun-name*) + scaled-dsd-index) + ,instance-type-check-form)))))) + *raw-slot-data-list*) ;; oops (t - (error "internal error: unexpected DSD-RAW-TYPE ~S" - dsd-raw-type)))))) + (bug "unexpected DSD-RAW-TYPE ~S" dsd-raw-type)))))) ;; code shared between DEFSTRUCT :TYPE LIST and ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed ;; structure" case, with no LAYOUTs and no raw slots. @@ -295,13 +321,21 @@ ;; through here. (%slotplace-accessor-funs (slotplace instance-type-check-form) (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form) - `(values (lambda (instance) - (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") - ,instance-type-check-form - (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") - ,slotplace) - (let ((typecheckfun (typespec-typecheckfun dsd-type))) - (lambda (new-value instance) + `(let ((typecheckfun (typespec-typecheckfun dsd-type))) + (values (if (dsd-safe-p dsd) + (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + ,slotplace) + (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + (let ((value ,slotplace)) + (funcall typecheckfun value) + value))) + (lambda (new-value instance) (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer") ,instance-type-check-form (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") @@ -311,7 +345,7 @@ (let ((dsd-index (dsd-index dsd)) (dsd-type (dsd-type dsd))) - + #+sb-xc (/show0 "got DSD-TYPE=..") #+sb-xc (/hexstr dsd-type) (ecase (dd-type dd) @@ -320,7 +354,7 @@ (structure #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE") (%native-slot-accessor-funs %instance-ref)) - + ;; structures with the :TYPE option ;; FIXME: Worry about these later.. @@ -361,20 +395,38 @@ (when raw-index (let* ((data (%instance-ref structure raw-index)) (raw-len (length data)) - (new (make-array raw-len :element-type '(unsigned-byte 32)))) - (declare (type (simple-array (unsigned-byte 32) (*)) data)) + (new (make-array raw-len :element-type 'sb!vm::word))) + (declare (type (simple-array sb!vm::word (*)) data)) (setf (%instance-ref res raw-index) new) (dotimes (i raw-len) (setf (aref new i) (aref data i)))))) res)) -;;; default PRINT-OBJECT and MAKE-LOAD-FORM methods +;;; default PRINT-OBJECT method (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (classoid-name (layout-classoid layout))) (dd (layout-info layout))) + ;; KLUDGE: during the build process with SB-SHOW, we can sometimes + ;; attempt to print out a PCL object (with null LAYOUT-INFO). + #!+sb-show + (when (null dd) + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO)")) + (return-from %default-structure-pretty-print nil)) + ;; the structure type doesn't count as a component for + ;; *PRINT-LEVEL* processing. We can likewise elide the logical + ;; block processing, since all we have to print is the type name. + ;; -- CSR, 2004-10-05 + (when (and dd (null (dd-slots dd))) + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream) + (return-from %default-structure-pretty-print nil)) (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) (let ((remaining-slots (dd-slots dd))) @@ -387,7 +439,7 @@ (pprint-pop) (let ((slot (pop remaining-slots))) (write-char #\: stream) - (output-symbol-name (dsd-%name slot) stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) (write-char #\space stream) (pprint-newline :miser stream) (output-object (funcall (fdefinition (dsd-accessor-name slot)) @@ -399,8 +451,13 @@ (pprint-newline :linear stream)))))))) (defun %default-structure-ugly-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (classoid-name (layout-classoid layout))) (dd (layout-info layout))) + (when (and dd (null (dd-slots dd))) + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream) + (return-from %default-structure-ugly-print nil)) (descend-into (stream) (write-string "#S(" stream) (prin1 name stream) @@ -417,7 +474,7 @@ (write-char #\space stream) (write-char #\: stream) (let ((slot (first remaining-slots))) - (output-symbol-name (dsd-%name slot) stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) (write-char #\space stream) (output-object (funcall (fdefinition (dsd-accessor-name slot)) @@ -430,15 +487,9 @@ (*print-pretty* (%default-structure-pretty-print structure stream)) (t - (%default-structure-ugly-print structure-stream)))) + (%default-structure-ugly-print structure stream)))) (def!method print-object ((x structure-object) stream) - (default-structure-print x stream *current-level*)) - -(defun make-load-form-saving-slots (object &key slot-names environment) - (declare (ignore object environment)) - (if slot-names - (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE - :just-dump-it-normally)) + (default-structure-print x stream *current-level-in-print*)) ;;;; testing structure types @@ -447,9 +498,11 @@ ;;; which have a handle on the type's LAYOUT. ;;; ;;; FIXME: This is fairly big, so it should probably become -;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so -;;; that the things which call it are all closures, so that it's -;;; expanded only in a small number of places. +;;; MAYBE-INLINE instead of INLINE, or its inlineness should become +;;; conditional (probably through DEFTRANSFORM) on (> SPEED SPACE). Or +;;; else we could fix things up so that the things which call it are +;;; all closures, so that it's expanded only in a small number of +;;; places. #!-sb-fluid (declaim (inline typep-to-layout)) (defun typep-to-layout (obj layout) (declare (type layout layout) (optimize (speed 3) (safety 0))) @@ -471,7 +524,7 @@ ((layout-invalid obj-layout) (/noshow0 "LAYOUT-INVALID case") (error 'layout-invalid - :expected-type (layout-class obj-layout) + :expected-type (layout-classoid obj-layout) :datum obj)) (t (let ((depthoid (layout-depthoid layout))) @@ -498,7 +551,7 @@ ,x ,(compiler-layout-or-lose class-name))) ((vector) - (let ((xx (gensym "X"))) + (with-unique-names (xx) `(let ((,xx ,x)) (declare (type vector ,xx)) ,@(when (dd-named dd) @@ -513,7 +566,7 @@ :format-arguments (list ',class-name ,xx))))) (values)))) ((list) - (let ((xx (gensym "X"))) + (with-unique-names (xx) `(let ((,xx ,x)) (declare (type list ,xx)) ,@(when (dd-named dd) @@ -533,7 +586,7 @@ (unless (typep-to-layout x layout) (error 'type-error :datum x - :expected-type (class-name (layout-class layout)))) + :expected-type (classoid-name (layout-classoid layout)))) (values)) (/show0 "target-defstruct.lisp end of file")