X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-defstruct.lisp;h=8f35d3ccfaf408f733457cbf40259a8b6247bf69;hb=2db3b6b4cb740d5b6512459c223859f747807b09;hp=803a61ffb29748bba7180ce3e668c0d24bf42c11;hpb=58a0e578e00abcb85940021d5ef3051c0b4c2082;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 803a61f..8f35d3c 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -133,8 +133,14 @@ (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 ;;; Catch attempts to mess up definitions of symbols in the CL package. (defun protect-cl (symbol) @@ -148,9 +154,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 +166,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 +216,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 +232,12 @@ (/show0 ":TYPE LIST case") #'listp)))) + (when (dd-doc dd) + (setf (fdocumentation (dd-name dd) 'type) + (dd-doc dd))) + (/show0 "leaving %TARGET-DEFSTRUCT") (values)) - ;;;; generating out-of-line slot accessor functions @@ -254,7 +267,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 +280,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. @@ -373,7 +390,7 @@ (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (class-name (layout-class layout))) (dd (layout-info layout))) (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) @@ -399,7 +416,7 @@ (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 (class-name (layout-class layout))) (dd (layout-info layout))) (descend-into (stream) (write-string "#S(" stream) @@ -430,15 +447,15 @@ (*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*)) + (default-structure-print x stream *current-level-in-print*)) (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)) + (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE + :sb-just-dump-it-normally)) ;;;; testing structure types @@ -447,9 +464,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)))