From: Christophe Rhodes Date: Sun, 12 Jun 2005 14:02:34 +0000 (+0000) Subject: 0.9.1.38: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f3f677703e37f5a335b3be7fa64f7748ad969517;p=sbcl.git 0.9.1.38: Merge DFL raw-slots patch (sbcl-devel "raw slot changes" 2005-05-18) ... with an amalgam of ths' two mips versions; ... note in OPTIMIZATIONS about the negative index idea, and the disabledness of HPPA --- diff --git a/CREDITS b/CREDITS index 01ce3e1..1384e2f 100644 --- a/CREDITS +++ b/CREDITS @@ -596,7 +596,11 @@ Frederik Kuivinen: Arthur Lemmens: He found and fixed a number of SBCL bugs while partially porting - SBCL to bootstrap under Lispworks for Windows + SBCL to bootstrap under Lispworks for Windows. + +David Lichteblau: + He came up with a more memory-efficient representation for + structures with raw slots. Robert MacLachlan: He has continued to answer questions about, and contribute fixes to, @@ -687,6 +691,10 @@ Rudi Schlatte: string extractor that keeps function documentation in the manual current. +Thiemo Seufer: + He modernized the MIPS backend, fixing many bugs, and assisted in + cleaning up the C runtime code. + Julian Squires: He worked on Unicode support for the PowerPC platform. @@ -750,10 +758,12 @@ APD Alexey Dejneka PFD Paul F. Dietz NJF Nathan Froyd AL Arthur Lemmens +DFL David Lichteblau RAM Robert MacLachlan PRM Pierre Mai WHN William ("Bill") Newman CSR Christophe Rhodes +THS Thiemo Seufer NS Nikodemus Siivola PVE Peter Van Eynde PW Paul Werkowski diff --git a/NEWS b/NEWS index 428c0ae..78b18d7 100644 --- a/NEWS +++ b/NEWS @@ -25,6 +25,9 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: generic sense) arithmetic routines. (thanks to Thiemo Seufer) * optimization: direct conversion of (unsigned-byte 32) to floats on the PowerPC platform. + * optimization: structure instances with raw slots now use less + memory, and probably show better memory locality. (thanks to + David Lichteblau) * contrib improvement: it's harder to cause SOCKET-CLOSE to close() the wrong file descriptor; implementation of SOCKET-OPEN-P. (thanks to Tony Martinez) diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index eb2931f..a702c7d 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -224,3 +224,11 @@ Initialization of stack-allocated arrays is inefficient: we always fill the vector with zeroes, even when it is not needed (as for platforms with conservative GC or for arrays of unboxed objectes) and is performed later explicitely. +-------------------------------------------------------------------------------- +#28 +a. Accessing raw slots in structure instances is more inefficient than +it could be; if we placed raw slots before the header word, we would +not need to do arithmetic at runtime to access them. (But beware: +this would complicate handling of the interior pointer). + +b. (Also note that raw slots are currently disabled on HPPA) \ No newline at end of file diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c07596e..a44e070 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1109,6 +1109,13 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%RAW-SET-COMPLEX-DOUBLE" "%RAW-SET-COMPLEX-LONG" "%RAW-SET-COMPLEX-SINGLE" "%RAW-SET-DOUBLE" "%RAW-SET-LONG" "%RAW-SET-SINGLE" "%SCALB" "%SCALBN" + "%RAW-INSTANCE-REF/WORD" "%RAW-INSTANCE-SET/WORD" + "%RAW-INSTANCE-REF/SINGLE" "%RAW-INSTANCE-SET/SINGLE" + "%RAW-INSTANCE-REF/DOUBLE" "%RAW-INSTANCE-SET/DOUBLE" + "%RAW-INSTANCE-REF/COMPLEX-SINGLE" + "%RAW-INSTANCE-SET/COMPLEX-SINGLE" + "%RAW-INSTANCE-REF/COMPLEX-DOUBLE" + "%RAW-INSTANCE-SET/COMPLEX-DOUBLE" "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-FUN" "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS" "%SET-VECTOR-RAW-BITS" @@ -1221,6 +1228,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "IRRATIONAL" "JUST-DUMP-IT-NORMALLY" "KEY-INFO" "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" "LAYOUT-DEPTHOID" "LAYOUT-INVALID-ERROR" + "LAYOUT-N-UNTAGGED-SLOTS" #!+(or x86-64 x86) "%LEA" "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" "ANSI-STREAM" "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE" diff --git a/src/code/class.lisp b/src/code/class.lisp index 515f3b4..a3a8169 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -113,12 +113,6 @@ ;;; type checking and garbage collection. Whenever a class is ;;; incompatibly redefined, a new layout is allocated. If two object's ;;; layouts are EQ, then they are exactly the same type. -;;; -;;; KLUDGE: The genesis code has raw offsets of slots in this -;;; structure hardwired into it. It would be good to rewrite that code -;;; so that it looks up those offsets in the compiler's tables, but -;;; for now if you change this structure, lucky you, you get to grovel -;;; over the genesis code by hand.:-( -- WHN 19990820 (def!struct (layout ;; KLUDGE: A special hack keeps this from being ;; called when building code for the @@ -201,8 +195,11 @@ ;; substructure (and hence can be copied into read-only space by ;; PURIFY). ;; - ;; KLUDGE: This slot is known to the C runtime support code. - (pure nil :type (member t nil 0))) + ;; This slot is known to the C runtime support code. + (pure nil :type (member t nil 0)) + ;; Number of raw words at the end. + ;; This slot is known to the C runtime support code. + (n-untagged-slots 0 :type index)) (def!method print-object ((layout layout) stream) (print-unreadable-object (layout stream :type t :identity t) @@ -278,16 +275,19 @@ ;;; preexisting class slot value is OK, and if it's not initialized, ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This ;;; is no longer true, :UNINITIALIZED used instead. -(declaim (ftype (function (layout classoid index simple-vector layout-depthoid) +(declaim (ftype (function (layout classoid index simple-vector layout-depthoid + index) layout) init-or-check-layout)) -(defun init-or-check-layout (layout classoid length inherits depthoid) +(defun init-or-check-layout + (layout classoid length inherits depthoid nuntagged) (cond ((eq (layout-invalid layout) :uninitialized) ;; There was no layout before, we just created one which ;; we'll now initialize with our information. (setf (layout-length layout) length (layout-inherits layout) inherits (layout-depthoid layout) depthoid + (layout-n-untagged-slots layout) nuntagged (layout-classoid layout) classoid (layout-invalid layout) nil)) ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this @@ -299,7 +299,7 @@ ;; information, and we'll now check that old information ;; which was known with certainty is consistent with current ;; information which is known with certainty. - (check-layout layout classoid length inherits depthoid))) + (check-layout layout classoid length inherits depthoid nuntagged))) layout) ;;; In code for the target Lisp, we don't use dump LAYOUTs using the @@ -338,7 +338,8 @@ ',(layout-classoid layout) ',(layout-length layout) ',(layout-inherits layout) - ',(layout-depthoid layout))))) + ',(layout-depthoid layout) + ',(layout-n-untagged-slots layout))))) ;;; If LAYOUT's slot values differ from the specified slot values in ;;; any interesting way, then give a warning and return T. @@ -347,10 +348,11 @@ simple-string index simple-vector - layout-depthoid)) + layout-depthoid + index)) redefine-layout-warning)) (defun redefine-layout-warning (old-context old-layout - context length inherits depthoid) + context length inherits depthoid nuntagged) (declare (type layout old-layout) (type simple-string old-context context)) (let ((name (layout-proper-name old-layout))) (or (let ((old-inherits (layout-inherits old-layout))) @@ -386,6 +388,15 @@ old-context old-length context length) t)) + (let ((old-nuntagged (layout-n-untagged-slots old-layout))) + (unless (= old-nuntagged nuntagged) + (warn "change in instance layout of class ~S:~% ~ + ~A untagged slots: ~W~% ~ + ~A untagged slots: ~W" + name + old-context old-nuntagged + context nuntagged) + t)) (unless (= (layout-depthoid old-layout) depthoid) (warn "change in the inheritance structure of class ~S~% ~ between the ~A definition and the ~A definition" @@ -395,12 +406,13 @@ ;;; Require that LAYOUT data be consistent with CLASS, LENGTH, ;;; INHERITS, and DEPTHOID. (declaim (ftype (function - (layout classoid index simple-vector layout-depthoid)) + (layout classoid index simple-vector layout-depthoid index)) check-layout)) -(defun check-layout (layout classoid length inherits depthoid) +(defun check-layout (layout classoid length inherits depthoid nuntagged) (aver (eq (layout-classoid layout) classoid)) (when (redefine-layout-warning "current" layout - "compile time" length inherits depthoid) + "compile time" length inherits depthoid + nuntagged) ;; Classic CMU CL had more options here. There are several reasons ;; why they might want more options which are less appropriate for ;; us: (1) It's hard to fit the classic CMU CL flexible approach @@ -425,16 +437,18 @@ ;;; Used by the loader to forward-reference layouts for classes whose ;;; definitions may not have been loaded yet. This allows type tests ;;; to be loaded when the type definition hasn't been loaded yet. -(declaim (ftype (function (symbol index simple-vector layout-depthoid) layout) +(declaim (ftype (function (symbol index simple-vector layout-depthoid index) + layout) find-and-init-or-check-layout)) -(defun find-and-init-or-check-layout (name length inherits depthoid) +(defun find-and-init-or-check-layout (name length inherits depthoid nuntagged) (let ((layout (find-layout name))) (init-or-check-layout layout (or (find-classoid name nil) (layout-classoid layout)) length inherits - depthoid))) + depthoid + nuntagged))) ;;; Record LAYOUT as the layout for its class, adding it as a subtype ;;; of all superclasses. This is the operation that "installs" a @@ -480,6 +494,7 @@ (layout-inherits destruct-layout) (layout-inherits layout) (layout-depthoid destruct-layout)(layout-depthoid layout) (layout-length destruct-layout) (layout-length layout) + (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout) (layout-info destruct-layout) (layout-info layout) (classoid-layout classoid) destruct-layout) (setf (layout-invalid layout) nil @@ -1335,7 +1350,8 @@ NIL is returned when no such class exists." (find-and-init-or-check-layout name 0 inherits-vector - depthoid) + depthoid + 0) :invalidate nil))))) (/show0 "done with loop over *BUILT-IN-CLASSES*")) @@ -1379,7 +1395,7 @@ NIL is returned when no such class exists." (classoid-layout (find-classoid x))) inherits-list))) #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits) - (register-layout (find-and-init-or-check-layout name 0 inherits -1) + (register-layout (find-and-init-or-check-layout name 0 inherits -1 0) :invalidate nil)))) (/show0 "done defining temporary STANDARD-CLASSes")) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 39b93b0..29c854a 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -315,7 +315,8 @@ "new" (layout-length layout) (layout-inherits layout) - (layout-depthoid layout)) + (layout-depthoid layout) + (layout-n-untagged-slots layout)) (register-layout layout :invalidate t)) ((not (classoid-layout class)) (register-layout layout))) diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index 000e8e6..ea47a7c 100644 --- a/src/code/defsetfs.lisp +++ b/src/code/defsetfs.lisp @@ -39,6 +39,11 @@ ;;; from defstruct.lisp (in-package "SB!KERNEL") (defsetf %instance-ref %instance-set) +(defsetf %raw-instance-ref/word %raw-instance-set/word) +(defsetf %raw-instance-ref/single %raw-instance-set/single) +(defsetf %raw-instance-ref/double %raw-instance-set/double) +(defsetf %raw-instance-ref/complex-single %raw-instance-set/complex-single) +(defsetf %raw-instance-ref/complex-double %raw-instance-set/complex-double) (defsetf %raw-ref-single %raw-set-single) (defsetf %raw-ref-double %raw-set-double) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 6508d2c..2ed87b4 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -108,7 +108,8 @@ (slots () :type list) ;; a list of (NAME . INDEX) pairs for accessors of included structures (inherited-accessor-alist () :type list) - ;; number of elements we've allocated (See also RAW-LENGTH.) + ;; number of elements we've allocated (See also RAW-LENGTH, which is not + ;; included in LENGTH.) (length 0 :type index) ;; General kind of implementation. (type 'structure :type (member structure vector list @@ -132,11 +133,7 @@ ;; option was given with no argument, or 0 if no PRINT-OBJECT option ;; was given (print-object 0 :type (or cons symbol (member 0))) - ;; the index of the raw data vector and the number of words in it, - ;; or NIL and 0 if not allocated (either because this structure - ;; has no raw slots, or because we're still parsing it and haven't - ;; run across any raw slots yet) - (raw-index nil :type (or index null)) + ;; The number of untagged slots at the end. (raw-length 0 :type index) ;; the value of the :PURE option, or :UNSPECIFIED. This is only ;; meaningful if DD-CLASS-P = T. @@ -192,14 +189,12 @@ ;; If this object does not describe a raw slot, this value is T. ;; ;; If this object describes a raw slot, this value is the type of the - ;; value that the raw slot holds. Mostly. (KLUDGE: If the raw slot has - ;; type (UNSIGNED-BYTE 32), the value here is UNSIGNED-BYTE, not - ;; (UNSIGNED-BYTE 32).) + ;; value that the raw slot holds. (raw-type t :type (member t single-float double-float #!+long-float long-float complex-single-float complex-double-float #!+long-float complex-long-float - unsigned-byte)) + sb!vm:word)) (read-only nil :type (member t nil))) (def!method print-object ((x defstruct-slot-description) stream) (print-unreadable-object (x stream :type t) @@ -215,59 +210,75 @@ ;;;; shared machinery for inline and out-of-line slot accessor functions +;;; Classic comment preserved for entertainment value: +;;; +;;; "A lie can travel halfway round the world while the truth is +;;; putting on its shoes." -- Mark Twain + (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;; 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.) + ;; (Non-raw slots are in the ordinary place you'd expect, directly + ;; indexed off the instance pointer. Raw slots are indexed from the end + ;; of the instance and skipped by GC.) (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? + ;; What operator is used 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)) + ;; How many words are each value of this type? + (n-words (missing-arg) :type (and index (integer 1)) :read-only t) + ;; Necessary alignment in units of words. Note that instances + ;; themselves are aligned by exactly two words, so specifying more + ;; than two words here would not work. + (alignment 1 :type (integer 1 2) :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)))) + #!+hppa + nil + #!-hppa + (let ((double-float-alignment + ;; white list of architectures that can load unaligned doubles: + #!+(or x86 x86-64 ppc) 1 + ;; at least sparc, mips and alpha can't: + #!-(or x86 x86-64 ppc) 2)) + (list + (make-raw-slot-data :raw-type 'sb!vm:word + :accessor-name '%raw-instance-ref/word + :n-words 1) + (make-raw-slot-data :raw-type 'single-float + :accessor-name '%raw-instance-ref/single + ;; KLUDGE: On 64 bit architectures, we + ;; could pack two SINGLE-FLOATs into the + ;; same word if raw slots were indexed + ;; using bytes instead of words. However, + ;; I don't personally find optimizing + ;; SINGLE-FLOAT memory usage worthwile + ;; enough. And the other datatype that + ;; would really benefit is (UNSIGNED-BYTE + ;; 32), but that is a subtype of FIXNUM, so + ;; we store it unraw anyway. :-( -- DFL + :n-words 1) + (make-raw-slot-data :raw-type 'double-float + :accessor-name '%raw-instance-ref/double + :alignment double-float-alignment + :n-words (/ 8 sb!vm:n-word-bytes)) + (make-raw-slot-data :raw-type 'complex-single-float + :accessor-name '%raw-instance-ref/complex-single + :n-words (/ 8 sb!vm:n-word-bytes)) + (make-raw-slot-data :raw-type 'complex-double-float + :accessor-name '%raw-instance-ref/complex-double + :alignment double-float-alignment + :n-words (/ 16 sb!vm:n-word-bytes)) + #!+long-float + (make-raw-slot-data :raw-type long-float + :accessor-name '%raw-instance-ref/long + :n-words #!+x86 3 #!+sparc 4) + #!+long-float + (make-raw-slot-data :raw-type complex-long-float + :accessor-name '%raw-instance-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) @@ -691,63 +702,42 @@ slot)) ;;; When a value of type TYPE is stored in a structure, should it be -;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where -;;; 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 ((and (sb!xc:subtypep type 'sb!vm:word) - (multiple-value-bind (fixnum? fixnum-certain?) - (sb!xc:subtypep type 'fixnum) - ;; (The extra test for FIXNUM-CERTAIN? here is - ;; intended for bootstrapping the system. In - ;; particular, in sbcl-0.6.2, we set up LAYOUT before - ;; FIXNUM is defined, and so could bogusly end up - ;; putting INDEX-typed values into raw slots if we - ;; didn't test FIXNUM-CERTAIN?.) - (and (not fixnum?) fixnum-certain?))) - (values t 'unsigned-byte 1)) - ((sb!xc:subtypep type 'single-float) - (values t 'single-float 1)) - ((sb!xc:subtypep type 'double-float) - (values t 'double-float 2)) - #!+long-float - ((sb!xc:subtypep type 'long-float) - (values t 'long-float #!+x86 3 #!+sparc 4)) - ((sb!xc:subtypep type '(complex single-float)) - (values t 'complex-single-float 2)) - ((sb!xc:subtypep type '(complex double-float)) - (values t 'complex-double-float 4)) - #!+long-float - ((sb!xc:subtypep type '(complex long-float)) - (values t 'complex-long-float #!+x86 6 #!+sparc 8)) - (t - (values nil nil nil)))) +;;; stored in a raw slot? Return the matching RAW-SLOT-DATA structure +;; if TYPE should be stored in a raw slot, or NIL if not. +(defun structure-raw-slot-data (type) + (multiple-value-bind (fixnum? fixnum-certain?) + (sb!xc:subtypep type 'fixnum) + ;; (The extra test for FIXNUM-CERTAIN? here is intended for + ;; bootstrapping the system. In particular, in sbcl-0.6.2, we set up + ;; LAYOUT before FIXNUM is defined, and so could bogusly end up + ;; putting INDEX-typed values into raw slots if we didn't test + ;; FIXNUM-CERTAIN?.) + (if (or fixnum? (not fixnum-certain?)) + nil + (dolist (data *raw-slot-data-list*) + (when (sb!xc:subtypep type (raw-slot-data-raw-type data)) + (return data)))))) ;;; Allocate storage for a DSD in DD. This is where we decide whether -;;; a slot is raw or not. If raw, and we haven't allocated a raw-index -;;; yet for the raw data vector, then do it. Raw objects are aligned -;;; on the unit of their size. +;;; a slot is raw or not. Raw objects are aligned on the unit of their size. (defun allocate-1-slot (dd dsd) - (multiple-value-bind (raw? raw-type words) - (if (eq (dd-type dd) 'structure) - (structure-raw-slot-type-and-size (dsd-type dsd)) - (values nil nil nil)) - (cond ((not raw?) - (setf (dsd-index dsd) (dd-length dd)) - (incf (dd-length dd))) - (t - (unless (dd-raw-index dd) - (setf (dd-raw-index dd) (dd-length dd)) - (incf (dd-length dd))) - (let ((off (rem (dd-raw-length dd) words))) - (unless (zerop off) - (incf (dd-raw-length dd) (- words off)))) - (setf (dsd-raw-type dsd) raw-type) - (setf (dsd-index dsd) (dd-raw-length dd)) - (incf (dd-raw-length dd) words)))) + (let ((rsd + (if (eq (dd-type dd) 'structure) + (structure-raw-slot-data (dsd-type dsd)) + nil))) + (cond + ((null rsd) + (setf (dsd-index dsd) (dd-length dd)) + (incf (dd-length dd))) + (t + (let* ((words (raw-slot-data-n-words rsd)) + (alignment (raw-slot-data-alignment rsd)) + (off (rem (dd-raw-length dd) alignment))) + (unless (zerop off) + (incf (dd-raw-length dd) (- alignment off))) + (setf (dsd-raw-type dsd) (raw-slot-data-raw-type rsd)) + (setf (dsd-index dsd) (dd-raw-length dd)) + (incf (dd-raw-length dd) words))))) (values)) (defun typed-structure-info-or-lose (name) @@ -795,7 +785,6 @@ (cons included-name mc)))) (when (eq (dd-pure dd) :unspecified) (setf (dd-pure dd) (dd-pure included-structure))) - (setf (dd-raw-index dd) (dd-raw-index included-structure)) (setf (dd-raw-length dd) (dd-raw-length included-structure))) (setf (dd-inherited-accessor-alist dd) @@ -898,8 +887,7 @@ ;;; Return a form describing the writable place used for this slot ;;; in the instance named INSTANCE-NAME. (defun %accessor-place-form (dd dsd instance-name) - (let (;; the operator that we'll use to access a typed slot or, in - ;; the case of a raw slot, to read the vector of raw slots + (let (;; the operator that we'll use to access a typed slot (ref (ecase (dd-type dd) (structure '%instance-ref) (list 'nth-but-with-sane-arg-order) @@ -910,26 +898,8 @@ (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)) - (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 sb!vm:word (*)) - ,raw-vector-bare-form)) - raw-vector-bare-form))) - `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index))))))) + (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data))) + `(,raw-slot-accessor ,instance-name ,(dsd-index dsd)))))) ;;; Return source transforms for the reader and writer functions of ;;; the slot described by DSD. They should be inline expanded, but @@ -1192,7 +1162,9 @@ (let ((new-layout (make-layout :classoid class :inherits inherits :depthoid (length inherits) - :length (dd-length info) + :length (+ (dd-length info) + (dd-raw-length info)) + :n-untagged-slots (dd-raw-length info) :info info)) (old-layout (or compiler-layout old-layout))) (cond @@ -1211,7 +1183,8 @@ new-context (layout-length new-layout) (layout-inherits new-layout) - (layout-depthoid new-layout)) + (layout-depthoid new-layout) + (layout-n-untagged-slots new-layout)) (values class new-layout old-layout)) (t (let ((old-info (layout-info old-layout))) @@ -1319,18 +1292,13 @@ (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) (list ,@vals)))) (defun create-structure-constructor (dd cons-name arglist vars types values) - (let* ((instance (gensym "INSTANCE")) - (raw-index (dd-raw-index dd))) + (let* ((instance (gensym "INSTANCE"))) `(defun ,cons-name ,arglist (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) (let ((,instance (truly-the ,(dd-name dd) (%make-instance-with-layout (%delayed-get-compiler-layout ,(dd-name dd)))))) - ,@(when raw-index - `((setf (%instance-ref ,instance ,raw-index) - (make-array ,(dd-raw-length dd) - :element-type 'sb!vm:word)))) ,@(mapcar (lambda (dsd value) ;; (Note that we can't in general use the ;; ordinary named slot setter function here diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index f48bf3e..d72d5f4 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -76,7 +76,7 @@ ;;; versions which break binary compatibility. But it certainly should ;;; be incremented for release versions which break binary ;;; compatibility. -(def!constant +fasl-file-version+ 56) +(def!constant +fasl-file-version+ 57) ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so) ;;; 38: (2003-01-05) changed names of internal SORT machinery ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to @@ -121,6 +121,7 @@ ;;; FIND-FOREIGN-SYMBOL-IN-TABLE &co. ;;; 56: (2005-05-22) Something between 0.9.0.1 and 0.9.0.14. My money is ;;; on 0.9.0.6 (MORE CASE CONSISTENCY). +;;; 57: (2005-06-12) Raw slot rearrangement in 0.9.1.38 ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 89bafa3..6a44362 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -142,18 +142,25 @@ (let* ((size (clone-arg)) (res (%make-instance size))) (declare (type index size)) - (do ((n (1- size) (1- n))) - ((minusp n)) - (declare (type index-or-minus-1 n)) - (setf (%instance-ref res n) (pop-stack))) + (let* ((layout (pop-stack)) + (nuntagged (layout-n-untagged-slots layout)) + (ntagged (- size nuntagged))) + (setf (%instance-ref res 0) layout) + (dotimes (n (1- ntagged)) + (declare (type index n)) + (setf (%instance-ref res (1+ n)) (pop-stack))) + (dotimes (n nuntagged) + (declare (type index n)) + (setf (%raw-instance-ref/word res (- nuntagged n 1)) (pop-stack)))) res)) (define-fop (fop-layout 45) - (let ((length (pop-stack)) + (let ((nuntagged (pop-stack)) + (length (pop-stack)) (depthoid (pop-stack)) (inherits (pop-stack)) (name (pop-stack))) - (find-and-init-or-check-layout name length inherits depthoid))) + (find-and-init-or-check-layout name length inherits depthoid nuntagged))) (define-fop (fop-end-group 64 :stackp nil) (/show0 "THROWing FASL-GROUP-END") diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 7cf0795..22d7199 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -31,6 +31,48 @@ (defun %instance-set (instance index new-value) (setf (%instance-ref instance index) new-value)) +#!-hppa +(progn + (defun %raw-instance-ref/word (instance index) + (declare (type index index)) + (%raw-instance-ref/word instance index)) + (defun %raw-instance-set/word (instance index new-value) + (declare (type index index) + (type sb!vm:word new-value)) + (%raw-instance-set/word instance index new-value)) + + (defun %raw-instance-ref/single (instance index) + (declare (type index index)) + (%raw-instance-ref/single instance index)) + (defun %raw-instance-set/single (instance index new-value) + (declare (type index index) + (type single-float new-value)) + (%raw-instance-set/single instance index new-value)) + + (defun %raw-instance-ref/double (instance index) + (declare (type index index)) + (%raw-instance-ref/double instance index)) + (defun %raw-instance-set/double (instance index new-value) + (declare (type index index) + (type double-float new-value)) + (%raw-instance-set/double instance index new-value)) + + (defun %raw-instance-ref/complex-single (instance index) + (declare (type index index)) + (%raw-instance-ref/complex-single instance index)) + (defun %raw-instance-set/complex-single (instance index new-value) + (declare (type index index) + (type (complex single-float) new-value)) + (%raw-instance-set/complex-single instance index new-value)) + + (defun %raw-instance-ref/complex-double (instance index) + (declare (type index index)) + (%raw-instance-ref/complex-double instance index)) + (defun %raw-instance-set/complex-double (instance index new-value) + (declare (type index index) + (type (complex double-float) new-value)) + (%raw-instance-set/complex-double instance index new-value))) + (defun %raw-ref-single (vec index) (declare (type index index)) (%raw-ref-single vec index)) @@ -136,7 +178,14 @@ ;;; service function for structure constructors (defun %make-instance-with-layout (layout) - (let ((result (%make-instance (layout-length layout)))) + ;; Make sure the object ends at a two-word boundary. Note that this does + ;; not affect the amount of memory used, since the allocator would add the + ;; same padding anyway. However, raw slots are indexed from the length of + ;; the object as indicated in the header, so the pad word needs to be + ;; included in that length to guarantee proper alignment of raw double float + ;; slots, necessary for (at least) the SPARC backend. + (let* ((length (layout-length layout)) + (result (%make-instance (+ length (mod (1+ length) 2))))) (setf (%instance-layout result) layout) result)) @@ -255,6 +304,9 @@ ;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler ;;; thing, putting in the type checks unconditionally.) +;;; KLUDGE: Why use this closure approach at all? The macrology in +;;; SLOT-ACCESSOR-FUNS seems to be half stub, half OAOOM to me. --DFL + ;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN). (defun slot-accessor-funs (dd dsd) @@ -292,21 +344,12 @@ ,@(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))) + (raw-slot-data-accessor-name rtd))) `((equal dsd-raw-type ',raw-type) #+sb-xc (/show0 "in raw slot case") - (let ((raw-index (dd-raw-index dd))) - (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) - scaled-dsd-index) - ,instance-type-check-form)))))) + (%slotplace-accessor-funs + (,accessor-name instance dsd-index) + ,instance-type-check-form)))) *raw-slot-data-list*) ;; oops (t @@ -378,28 +421,24 @@ (declare (type structure-object structure)) (let* ((len (%instance-length structure)) (res (%make-instance len)) - (layout (%instance-layout structure))) + (layout (%instance-layout structure)) + (nuntagged (layout-n-untagged-slots layout))) (declare (type index len)) (when (layout-invalid layout) (error "attempt to copy an obsolete structure:~% ~S" structure)) ;; Copy ordinary slots. - (dotimes (i len) + (dotimes (i (- len nuntagged)) (declare (type index i)) (setf (%instance-ref res i) (%instance-ref structure i))) ;; Copy raw slots. - (let ((raw-index (dd-raw-index (layout-info layout)))) - (when raw-index - (let* ((data (%instance-ref structure raw-index)) - (raw-len (length 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)))))) + (dotimes (i nuntagged) + (declare (type index i)) + (setf (%raw-instance-ref/word res i) + (%raw-instance-ref/word structure i))) res)) diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index 35fdcdc..cbc2267 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -289,13 +289,16 @@ (name (classoid-name classoid)) (result (mix (sxhash name) (the fixnum 79867)))) (declare (type fixnum result)) - (dotimes (i (min depthoid (1- length))) + (dotimes (i (min depthoid (- length 1 (layout-n-untagged-slots layout)))) (declare (type fixnum i)) (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT (declare (type fixnum j)) (mixf result (psxhash (%instance-ref key j) (1- depthoid))))) + ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+ + ;; is pretty low currently, so they might not make it into the hash + ;; value anyway.) result)) (defun list-psxhash (key depthoid) diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp index 3220e7d..1757d9c 100644 --- a/src/compiler/alpha/cell.lisp +++ b/src/compiler/alpha/cell.lisp @@ -388,3 +388,284 @@ (define-mutator-accessors words-consed :ub32 nil)) ); #+gengc progn + + + +;;;; raw instance slot accessors + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst ldl + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (inst mskll value 4 value))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst stl + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (move value result))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst lds + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg))) + (:arg-types * positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst sts + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result value) + (inst fmove value result)))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (inst ldt + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg))) + (:arg-types * positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (inst stt + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result value) + (inst fmove value result)))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (inst lds + (complex-double-reg-real-tn value) + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (inst lds + (complex-double-reg-imag-tn value) + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag) + lip))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg))) + (:arg-types * positive-fixnum complex-single-float) + (:results (result :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst sts + value-real + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-real value-real) + (inst fmove value-real result-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst sts + value-imag + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-imag value-imag) + (inst fmove value-imag result-imag))))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 4 n-word-bytes) offset) + (inst addq object offset lip) + (inst ldt + (complex-double-reg-real-tn value) + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (inst ldt + (complex-double-reg-imag-tn value) + (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag) + lip))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg))) + (:arg-types * positive-fixnum complex-double-float) + (:results (result :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 4 n-word-bytes) offset) + (inst addq object offset lip) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst stt + value-real + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-real value-real) + (inst fmove value-real result-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst stt + value-imag + (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-imag value-imag) + (inst fmove value-imag result-imag))))) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 610c1db..6bfc35c 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1315,14 +1315,20 @@ (error "attempt to dump invalid structure:~% ~S~%How did this happen?" struct))) (note-potential-circularity struct file) - (do ((index 0 (1+ index)) - (length (%instance-length struct)) - (circ (fasl-output-circularity-table file))) - ((= index length) + (aver (%instance-ref struct 0)) + (do* ((length (%instance-length struct)) + (ntagged (- length (layout-n-untagged-slots (%instance-ref struct 0)))) + (circ (fasl-output-circularity-table file)) + ;; last slot first on the stack, so that the layout is on top: + (index (1- length) (1- index))) + ((minusp index) (dump-fop* length fop-small-struct fop-struct file)) - (let* ((obj (%instance-ref struct index)) + (let* ((obj (if (>= index ntagged) + (%raw-instance-ref/word struct (- length index 1)) + (%instance-ref struct index))) (ref (gethash obj circ))) (cond (ref + (aver (not (zerop index))) (push (make-circularity :type :struct-set :object struct :index index @@ -1347,4 +1353,5 @@ (sub-dump-object (layout-inherits obj) file) (sub-dump-object (layout-depthoid obj) file) (sub-dump-object (layout-length obj) file) + (sub-dump-object (layout-n-untagged-slots obj) file) (dump-fop 'fop-layout file)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ba452c3..4da74cc 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -378,6 +378,15 @@ (ash -1 (1+ sb!vm:n-positive-fixnum-bits))) (ash bits (- 1 sb!vm:n-lowtag-bits))))) +(defun descriptor-word-sized-integer (des) + ;; Extract an (unsigned-byte 32), from either its fixnum or bignum + ;; representation. + (let ((lowtag (descriptor-lowtag des))) + (if (or (= lowtag sb!vm:even-fixnum-lowtag) + (= lowtag sb!vm:odd-fixnum-lowtag)) + (make-random-descriptor (descriptor-fixnum des)) + (read-wordindexed des 1)))) + ;;; common idioms (defun descriptor-bytes (des) (gspace-bytes (descriptor-intuit-gspace des))) @@ -844,7 +853,7 @@ core and return a descriptor to it." ;;; FIXME: This information should probably be pulled out of the ;;; cross-compiler's tables at genesis time instead of inserted by ;;; hand here as a bare numeric constant. -(defconstant target-layout-length 16) +(defconstant target-layout-length 17) ;;; Return a list of names created from the cold layout INHERITS data ;;; in X. @@ -862,9 +871,10 @@ core and return a descriptor to it." (descriptor-bits des))))) (res)))) -(declaim (ftype (function (symbol descriptor descriptor descriptor) descriptor) +(declaim (ftype (function (symbol descriptor descriptor descriptor descriptor) + descriptor) make-cold-layout)) -(defun make-cold-layout (name length inherits depthoid) +(defun make-cold-layout (name length inherits depthoid nuntagged) (let ((result (allocate-boxed-object *dynamic* ;; KLUDGE: Why 1+? -- WHN 19990901 (1+ target-layout-length) @@ -944,14 +954,16 @@ core and return a descriptor to it." (write-wordindexed result (+ base 3) depthoid) (write-wordindexed result (+ base 4) length) (write-wordindexed result (+ base 5) *nil-descriptor*) ; info - (write-wordindexed result (+ base 6) *nil-descriptor*)) ; pure + (write-wordindexed result (+ base 6) *nil-descriptor*) ; pure + (write-wordindexed result (+ base 7) nuntagged)) (setf (gethash name *cold-layouts*) (list result name (descriptor-fixnum length) (listify-cold-inherits inherits) - (descriptor-fixnum depthoid))) + (descriptor-fixnum depthoid) + (descriptor-fixnum nuntagged))) (setf (gethash (descriptor-bits result) *cold-layout-names*) name) result)) @@ -968,7 +980,9 @@ core and return a descriptor to it." (number-to-core target-layout-length) (vector-in-core) ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT.. - (number-to-core 4))) + (number-to-core 4) + ;; no raw slots in LAYOUT: + (number-to-core 0))) (write-wordindexed *layout-layout* sb!vm:instance-slots-offset *layout-layout*) @@ -982,22 +996,26 @@ core and return a descriptor to it." (make-cold-layout 't (number-to-core 0) (vector-in-core) + (number-to-core 0) (number-to-core 0))) (i-layout (make-cold-layout 'instance (number-to-core 0) (vector-in-core t-layout) - (number-to-core 1))) + (number-to-core 1) + (number-to-core 0))) (so-layout (make-cold-layout 'structure-object (number-to-core 1) (vector-in-core t-layout i-layout) - (number-to-core 2))) + (number-to-core 2) + (number-to-core 0))) (bso-layout (make-cold-layout 'structure!object (number-to-core 1) (vector-in-core t-layout i-layout so-layout) - (number-to-core 3))) + (number-to-core 3) + (number-to-core 0))) (layout-inherits (vector-in-core t-layout i-layout so-layout @@ -1944,19 +1962,28 @@ core and return a descriptor to it." (let* ((size (clone-arg)) (result (allocate-boxed-object *dynamic* (1+ size) - sb!vm:instance-pointer-lowtag))) + sb!vm:instance-pointer-lowtag)) + (layout (pop-stack)) + (nuntagged + (descriptor-fixnum + (read-wordindexed layout (+ sb!vm:instance-slots-offset 16)))) + (ntagged (- size nuntagged))) (write-memory result (make-other-immediate-descriptor size sb!vm:instance-header-widetag)) - (do ((index (1- size) (1- index))) - ((minusp index)) + (write-wordindexed result sb!vm:instance-slots-offset layout) + (do ((index 1 (1+ index))) + ((eql index size)) (declare (fixnum index)) (write-wordindexed result (+ index sb!vm:instance-slots-offset) - (pop-stack))) + (if (>= index ntagged) + (descriptor-word-sized-integer (pop-stack)) + (pop-stack)))) result)) (define-cold-fop (fop-layout) - (let* ((length-des (pop-stack)) + (let* ((nuntagged-des (pop-stack)) + (length-des (pop-stack)) (depthoid-des (pop-stack)) (cold-inherits (pop-stack)) (name (pop-stack)) @@ -1974,16 +2001,18 @@ core and return a descriptor to it." old-name old-length old-inherits-list - old-depthoid) + old-depthoid + old-nuntagged) old (declare (type descriptor old-layout-descriptor)) - (declare (type index old-length)) + (declare (type index old-length old-nuntagged)) (declare (type fixnum old-depthoid)) (declare (type list old-inherits-list)) (aver (eq name old-name)) (let ((length (descriptor-fixnum length-des)) (inherits-list (listify-cold-inherits cold-inherits)) - (depthoid (descriptor-fixnum depthoid-des))) + (depthoid (descriptor-fixnum depthoid-des)) + (nuntagged (descriptor-fixnum nuntagged-des))) (unless (= length old-length) (error "cold loading a reference to class ~S when the compile~%~ time length was ~S and current length is ~S" @@ -2003,10 +2032,17 @@ core and return a descriptor to it." depthoid is ~S" name depthoid - old-depthoid))) + old-depthoid)) + (unless (= nuntagged old-nuntagged) + (error "cold loading a reference to class ~S when the compile~%~ + time number of untagged slots was ~S and is currently ~S" + name + nuntagged + old-nuntagged))) old-layout-descriptor) ;; Make a new definition from scratch. - (make-cold-layout name length-des cold-inherits depthoid-des)))) + (make-cold-layout name length-des cold-inherits depthoid-des + nuntagged-des)))) ;;;; cold fops for loading symbols @@ -2777,6 +2813,23 @@ core and return a descriptor to it." (terpri))) (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) +(defun write-structure-object (dd) + (flet ((cstring (designator) + (substitute #\_ #\- (string-downcase (string designator))))) + (format t "#ifndef LANGUAGE_ASSEMBLY~2%") + (format t "struct ~A {~%" (cstring (dd-name dd))) + (format t " lispobj header;~%") + (format t " lispobj layout;~%") + (dolist (slot (dd-slots dd)) + (when (eq t (dsd-raw-type slot)) + (format t " lispobj ~A;~%" (cstring (dsd-name slot))))) + (unless (oddp (+ (dd-length dd) (dd-raw-length dd))) + (format t " long raw_slot_padding;~%")) + (dotimes (n (dd-raw-length dd)) + (format t " long raw~D;~%" (- (dd-raw-length dd) n 1))) + (format t "};~2%") + (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))) + (defun write-static-symbols () (dolist (symbol (cons nil sb!vm:*static-symbols*)) ;; FIXME: It would be nice to use longer names than NIL and @@ -3230,6 +3283,11 @@ initially undefined function references:~2%") (format t "~&#include \"~A.h\"~%" (string-downcase (string (sb!vm:primitive-object-name obj))))))) + (dolist (class '(hash-table layout)) + (out-to + (string-downcase (string class)) + (write-structure-object + (sb!kernel:layout-info (sb!kernel:find-layout class))))) (out-to "static-symbols" (write-static-symbols)) (when core-file-name diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 98bebdc..1f3f2ae 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -121,6 +121,32 @@ (unsafe)) (defknown %layout-invalid-error (t layout) nil) +(defknown %raw-instance-ref/word (instance index) sb!vm:word + (flushable)) +(defknown %raw-instance-set/word (instance index sb!vm:word) sb!vm:word + (unsafe)) +(defknown %raw-instance-ref/single (instance index) single-float + (flushable)) +(defknown %raw-instance-set/single (instance index single-float) single-float + (unsafe)) +(defknown %raw-instance-ref/double (instance index) double-float + (flushable)) +(defknown %raw-instance-set/double (instance index double-float) double-float + (unsafe)) +(defknown %raw-instance-ref/complex-single (instance index) + (complex single-float) + (flushable)) +(defknown %raw-instance-set/complex-single + (instance index (complex single-float)) + (complex single-float) + (unsafe)) +(defknown %raw-instance-ref/complex-double (instance index) + (complex double-float) + (flushable)) +(defknown %raw-instance-set/complex-double + (instance index (complex double-float)) + (complex double-float) + (unsafe)) (sb!xc:deftype raw-vector () '(simple-array sb!vm:word (*))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index b85fdb1..2144cbd 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -288,7 +288,10 @@ #+sb-xc-host structure!object #-sb-xc-host instance (when (emit-make-load-form value) - (dotimes (i (%instance-length value)) + (dotimes (i (- (%instance-length value) + #+sb-xc-host 0 + #-sb-xc-host (layout-n-untagged-slots + (%instance-ref value 0)))) (grovel (%instance-ref value i))))) (t (compiler-error diff --git a/src/compiler/mips/cell.lisp b/src/compiler/mips/cell.lisp index a9eb189..7a80016 100644 --- a/src/compiler/mips/cell.lisp +++ b/src/compiler/mips/cell.lisp @@ -292,4 +292,348 @@ (descriptor-reg any-reg null zero) * code-header-set) + +;;;; raw instance slot accessors +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst lw value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (unsigned-reg) :target result)) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst sw value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (unless (location= result value) + (move result value)))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst lwc1 value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst swc1 value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (unless (location= result value) + (inst fmove :single result value)))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1 value lip immediate-offset)) + (:little-endian (inst lwc1-odd value lip immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1-odd value lip immediate-offset)) + (:little-endian (inst lwc1 value lip immediate-offset)))))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1 value lip immediate-offset)) + (:little-endian (inst swc1-odd value lip immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1-odd value lip immediate-offset)) + (:little-endian (inst swc1 value lip immediate-offset)))) + (unless (location= result value) + (inst fmove :double result value)))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (inst lwc1 + (complex-single-reg-real-tn value) + lip + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (inst lwc1 + (complex-single-reg-imag-tn value) + lip + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:results (result :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst swc1 + value-real + lip + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (unless (location= result-real value-real) + (inst fmove :single result-real value-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst swc1 + value-imag + lip + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (unless (location= result-imag value-imag) + (inst fmove :single result-imag value-imag))))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 4 n-word-bytes)) + (inst addu lip offset object) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1 + (complex-double-reg-real-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1-odd + (complex-double-reg-real-tn value) + lip + immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1-odd + (complex-double-reg-real-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1 + (complex-double-reg-real-tn value) + lip + immediate-offset)))) + (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1 + (complex-double-reg-imag-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1-odd + (complex-double-reg-imag-tn value) + lip + immediate-offset)))) + (let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1-odd + (complex-double-reg-imag-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1 + (complex-double-reg-imag-tn value) + lip + immediate-offset)))))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:results (result :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 4 n-word-bytes)) + (inst addu lip offset object) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1 + value-real + lip + immediate-offset)) + (:little-endian (inst swc1-odd + value-real + lip + immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1-odd + value-real + lip + immediate-offset)) + (:little-endian (inst swc1 + value-real + lip + immediate-offset)))) + (unless (location= result-real value-real) + (inst fmove :double result-real value-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1 + value-imag + lip + immediate-offset)) + (:little-endian (inst swc1-odd + value-imag + lip + immediate-offset)))) + (let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1-odd + value-imag + lip + immediate-offset)) + (:little-endian (inst swc1 + value-imag + lip + immediate-offset)))) + (unless (location= result-imag value-imag) + (inst fmove :double result-imag value-imag))))) diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index 428b0b6..d1dc086 100644 --- a/src/compiler/ppc/cell.lisp +++ b/src/compiler/ppc/cell.lisp @@ -292,3 +292,250 @@ (:policy :fast-safe) (:variant 0 other-pointer-lowtag)) + + +;;;; raw instance slot accessors + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst lwzx value object offset))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst stwx value object offset) + (move result value))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst lfsx value object offset))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst stfsx value object offset) + (unless (location= result value) + (inst frsp result value)))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst lfdx value object offset))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst stfdx value object offset) + (unless (location= result value) + (inst fmr result value)))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst lfsx (complex-single-reg-real-tn value) object offset) + (inst addi offset offset n-word-bytes) + (inst lfsx (complex-single-reg-imag-tn value) object offset))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst stfsx value-real object offset) + (unless (location= result-real value-real) + (inst frsp result-real value-real))) + (inst addi offset offset n-word-bytes) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst stfsx value-imag object offset) + (unless (location= result-imag value-imag) + (inst frsp result-imag value-imag))))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (- instance-slots-offset 4) n-word-bytes) + instance-pointer-lowtag)) + (inst lfdx (complex-double-reg-real-tn value) object offset) + (inst addi offset offset (* 2 n-word-bytes)) + (inst lfdx (complex-double-reg-imag-tn value) object offset))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srwi offset offset n-widetag-bits) + (inst slwi offset offset 2) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (- instance-slots-offset 4) n-word-bytes) + instance-pointer-lowtag)) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst stfdx value-real object offset) + (unless (location= result-real value-real) + (inst fmr result-real value-real))) + (inst addi offset offset (* 2 n-word-bytes)) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst stfdx value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmr result-imag value-imag))))) diff --git a/src/compiler/sparc/cell.lisp b/src/compiler/sparc/cell.lisp index 3cad61b..0888f32 100644 --- a/src/compiler/sparc/cell.lisp +++ b/src/compiler/sparc/cell.lisp @@ -287,3 +287,250 @@ (:policy :fast-safe) (:variant 0 other-pointer-lowtag)) + + +;;;; raw instance slot accessors + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst ld value object offset))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst st value object offset) + (move result value))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst ldf value object offset))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (inst stf value object offset) + (unless (location= result value) + (inst fmovs result value)))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst lddf value object offset))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst stdf value object offset) + (unless (location= result value) + (move-double-reg result value)))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst ldf (complex-single-reg-real-tn value) object offset) + (inst add offset offset n-word-bytes) + (inst ldf (complex-single-reg-imag-tn value) object offset))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst stf value-real object offset) + (unless (location= result-real value-real) + (inst fmovs result-real value-real))) + (inst add offset offset n-word-bytes) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst stf value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmovs result-imag value-imag))))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (- instance-slots-offset 4) n-word-bytes) + instance-pointer-lowtag)) + (inst lddf (complex-double-reg-real-tn value) object offset) + (inst add offset offset (* 2 n-word-bytes)) + (inst lddf (complex-double-reg-imag-tn value) object offset))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset offset n-widetag-bits) + (inst sll offset offset 2) + (inst sub offset offset index) + (inst add + offset + offset + (- (* (- instance-slots-offset 4) n-word-bytes) + instance-pointer-lowtag)) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst stdf value-real object offset) + (unless (location= result-real value-real) + (move-double-reg result-real value-real))) + (inst add offset offset (* 2 n-word-bytes)) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst stdf value-imag object offset) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 031167b..4be9484 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -486,3 +486,282 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (any-reg descriptor-reg) * code-header-set) + + + +;;;; raw instance slot accessors + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst mov + value + (make-ea :qword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (unsigned-reg) :target result)) + (:arg-types * tagged-num unsigned-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst mov + (make-ea :qword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (move result value))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movss + value + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * positive-fixnum single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movss + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (unless (location= result value) + (inst movss result value)))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movsd + value + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * positive-fixnum double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movsd + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (unless (location= result value) + (inst movsd result value)))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((real-tn (complex-single-reg-real-tn value))) + (inst movss + real-tn + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (inst movss + imag-tn + (make-ea :dword + :base object + :index tmp + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + 4 + (- instance-pointer-lowtag))))))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst movss (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value-real) + (unless (location= value-real result-real) + (inst movss result-real value-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst movss (make-ea :dword + :base object + :index tmp + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + 4 + (- instance-pointer-lowtag))) + value-imag) + (unless (location= value-imag result-imag) + (inst movss result-imag value-imag))))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((real-tn (complex-double-reg-real-tn value))) + (inst movsd + real-tn + (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (inst movsd + imag-tn + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst movsd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + value-real) + (unless (location= value-real result-real) + (inst movsd result-real value-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst movsd (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value-imag) + (unless (location= value-imag result-imag) + (inst movsd result-imag value-imag))))) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 63a74ef..016a85e 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -489,3 +489,340 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (any-reg descriptor-reg) * code-header-set) + + + +;;;; raw instance slot accessors + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (inst mov + value + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (unsigned-reg) :target result)) + (:arg-types * tagged-num unsigned-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (inst mov + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (move result value))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (with-empty-tn@fp-top(value) + (inst fld + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * tagged-num single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (unless (zerop (tn-offset value)) + (inst fxch value)) + (inst fst + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (cond + ((zerop (tn-offset value)) + (unless (zerop (tn-offset result)) + (inst fst result))) + ((zerop (tn-offset result)) + (inst fst value)) + (t + (unless (location= value result) + (inst fst result)) + (inst fxch value))))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (with-empty-tn@fp-top(value) + (inst fldd + (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)))))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * tagged-num double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (unless (zerop (tn-offset value)) + (inst fxch value)) + (inst fstd + (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag))) + (cond + ((zerop (tn-offset value)) + (unless (zerop (tn-offset result)) + (inst fstd result))) + ((zerop (tn-offset result)) + (inst fstd value)) + (t + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((real-tn (complex-single-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fld (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fld (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) + n-word-bytes) + instance-pointer-lowtag))))))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fst (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fst result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fst (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fst value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fst result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst fxch value-imag) + (inst fst (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) + n-word-bytes) + instance-pointer-lowtag))) + (unless (location= value-imag result-imag) + (inst fst result-imag)) + (inst fxch value-imag)))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 7 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((real-tn (complex-double-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 4) + n-word-bytes) + instance-pointer-lowtag))))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))))))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 20 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fstd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 4) + n-word-bytes) + instance-pointer-lowtag))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 4) + n-word-bytes) + instance-pointer-lowtag))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index eaa7ad0..41b4390 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -650,15 +650,8 @@ (defun make-defstruct-allocation-function (class) (let ((dd (get-structure-dd (class-name class)))) (lambda () - (let ((instance (%make-instance (dd-length dd))) - (raw-index (dd-raw-index dd))) - (setf (%instance-layout instance) - (sb-kernel::compiler-layout-or-lose (dd-name dd))) - (when raw-index - (setf (%instance-ref instance raw-index) - (make-array (dd-raw-length dd) - :element-type '(unsigned-byte 32)))) - instance)))) + (sb-kernel::%make-instance-with-layout + (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after ((class structure-class) diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index c083096..8e8b3fa 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -41,6 +41,7 @@ #include "gc.h" #include "genesis/primitive-objects.h" #include "genesis/static-symbols.h" +#include "genesis/layout.h" #include "gc-internal.h" #ifdef LISP_FEATURE_SPARC @@ -643,6 +644,24 @@ scav_boxed(lispobj *where, lispobj object) return 1; } +static long +scav_instance(lispobj *where, lispobj object) +{ + lispobj nuntagged; + long ntotal = HeaderValue(object); + lispobj layout = ((struct instance *)native_pointer(where))->slots[0]; + + if (!layout) + return 1; + if (forwarding_pointer_p(native_pointer(layout))) + layout = (lispobj) forwarding_pointer_value(native_pointer(layout)); + + nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots; + scavenge(where + 1, ntotal - fixnum_value(nuntagged)); + + return ntotal + 1; +} + static lispobj trans_boxed(lispobj object) { @@ -1708,7 +1727,7 @@ gc_init_tables(void) scavtab[CHARACTER_WIDETAG] = scav_immediate; scavtab[SAP_WIDETAG] = scav_unboxed; scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate; - scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed; + scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance; #ifdef LISP_FEATURE_SPARC scavtab[FDEFN_WIDETAG] = scav_boxed; #else diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 3657381..6f59ffe 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -44,6 +44,7 @@ #include "genesis/vector.h" #include "genesis/weak-pointer.h" #include "genesis/simple-fun.h" +#include "genesis/hash-table.h" /* forward declarations */ long gc_find_freeish_pages(long *restart_page_ptr, long nbytes, int unboxed); @@ -1712,7 +1713,7 @@ scav_vector(lispobj *where, lispobj object) unsigned long kv_length; lispobj *kv_vector; unsigned long length = 0; /* (0 = dummy to stop GCC warning) */ - lispobj *hash_table; + struct hash_table *hash_table; lispobj empty_symbol; unsigned long *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */ unsigned long *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */ @@ -1745,8 +1746,10 @@ scav_vector(lispobj *where, lispobj object) } hash_table = (lispobj *)native_pointer(where[2]); /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/ - if (widetag_of(hash_table[0]) != INSTANCE_HEADER_WIDETAG) { - lose("hash table not instance (%x at %x)", hash_table[0], hash_table); + if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) { + lose("hash table not instance (%x at %x)", + hash_table->header, + hash_table); } /* Scavenge element 1, which should be some internal symbol that @@ -1765,19 +1768,19 @@ scav_vector(lispobj *where, lispobj object) /* Scavenge hash table, which will fix the positions of the other * needed objects. */ - scavenge(hash_table, 16); + scavenge(hash_table, sizeof(struct hash_table) / sizeof(lispobj)); /* Cross-check the kv_vector. */ - if (where != (lispobj *)native_pointer(hash_table[9])) { - lose("hash_table table!=this table %x", hash_table[9]); + if (where != (lispobj *)native_pointer(hash_table->table)) { + lose("hash_table table!=this table %x", hash_table->table); } /* WEAK-P */ - weak_p_obj = hash_table[10]; + weak_p_obj = hash_table->weak_p; /* index vector */ { - lispobj index_vector_obj = hash_table[13]; + lispobj index_vector_obj = hash_table->index_vector; if (is_lisp_pointer(index_vector_obj) && (widetag_of(*(lispobj *)native_pointer(index_vector_obj)) == @@ -1793,7 +1796,7 @@ scav_vector(lispobj *where, lispobj object) /* next vector */ { - lispobj next_vector_obj = hash_table[14]; + lispobj next_vector_obj = hash_table->next_vector; if (is_lisp_pointer(next_vector_obj) && (widetag_of(*(lispobj *)native_pointer(next_vector_obj)) == @@ -1809,11 +1812,7 @@ scav_vector(lispobj *where, lispobj object) /* maybe hash vector */ { - /* FIXME: This bare "15" offset should become a symbolic - * expression of some sort. And all the other bare offsets - * too. And the bare "16" in scavenge(hash_table, 16). And - * probably other stuff too. Ugh.. */ - lispobj hash_vector_obj = hash_table[15]; + lispobj hash_vector_obj = hash_table->hash_vector; if (is_lisp_pointer(hash_vector_obj) && (widetag_of(*(lispobj *)native_pointer(hash_vector_obj)) == @@ -1876,8 +1875,8 @@ scav_vector(lispobj *where, lispobj object) /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/ index_vector[old_index] = next_vector[i]; /* Link it into the needing rehash chain. */ - next_vector[i] = fixnum_value(hash_table[11]); - hash_table[11] = make_fixnum(i); + next_vector[i] = fixnum_value(hash_table->needing_rehash); + hash_table->needing_rehash = make_fixnum(i); /*SHOW("P2");*/ } else { unsigned prior = index_vector[old_index]; @@ -1893,8 +1892,8 @@ scav_vector(lispobj *where, lispobj object) /* Link it into the needing rehash * chain. */ next_vector[next] = - fixnum_value(hash_table[11]); - hash_table[11] = make_fixnum(next); + fixnum_value(hash_table->needing_rehash); + hash_table->needing_rehash = make_fixnum(next); /*SHOW("/P3");*/ break; } diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 8a95542..992df23 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -33,6 +33,7 @@ #include "thread.h" #include "genesis/primitive-objects.h" #include "genesis/static-symbols.h" +#include "genesis/layout.h" #define PRINTNOISE @@ -1392,6 +1393,18 @@ pscav(lispobj *addr, long nwords, boolean constant) count = pscav_fdefn((struct fdefn *)addr); break; + case INSTANCE_HEADER_WIDETAG: + { + struct instance *instance = (struct instance *) addr; + struct layout *layout + = (struct layout *) native_pointer(instance->slots[0]); + long nuntagged = fixnum_value(layout->n_untagged_slots); + long nslots = HeaderValue(*addr); + pscav(addr + 1, nslots - nuntagged, constant); + count = CEILING(1 + nslots, 2); + } + break; + default: count = 1; break; diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index f1b06b5..6102a14 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -349,13 +349,13 @@ ;;;; some other raw slot). (defstruct manyraw - (a (expt 2 30) :type (unsigned-byte 32)) + (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits)) (b 0.1 :type single-float) (c 0.2d0 :type double-float) (d #c(0.3 0.3) :type (complex single-float)) unraw-slot-just-for-variety (e #c(0.4d0 0.4d0) :type (complex double-float)) - (aa (expt 2 30) :type (unsigned-byte 32)) + (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits)) (bb 0.1 :type single-float) (cc 0.2d0 :type double-float) (dd #c(0.3 0.3) :type (complex single-float)) @@ -391,6 +391,94 @@ (assert (eql (manyraw-cc copy) 0.22d0)) (assert (eql (manyraw-dd copy) #c(0.33 0.33))) (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0)))) + + +;;;; Since GC treats raw slots specially now, let's try this with more objects +;;;; and random values as a stress test. + +(setf *manyraw* nil) + +(defconstant +n-manyraw+ 10) +(defconstant +m-manyraw+ 1000) + +(defun check-manyraws (manyraws) + (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+))) + (loop + for m in (reverse manyraws) + for i from 0 + do + ;; Compare the tagged reference values with raw reffer results. + (destructuring-bind (j a b c d e) + (manyraw-unraw-slot-just-for-variety m) + (assert (eql i j)) + (assert (= (manyraw-a m) a)) + (assert (= (manyraw-b m) b)) + (assert (= (manyraw-c m) c)) + (assert (= (manyraw-d m) d)) + (assert (= (manyraw-e m) e))) + ;; Test the funny out-of-line OAOOM-style closures, too. + (mapcar (lambda (fn value) + (assert (= (funcall fn m) value))) + (list #'manyraw-a + #'manyraw-b + #'manyraw-c + #'manyraw-d + #'manyraw-e) + (cdr (manyraw-unraw-slot-just-for-variety m))))) + +(defstruct (manyraw-subclass (:include manyraw)) + (stolperstein 0 :type (unsigned-byte 32))) + +;;; create lots of manyraw objects, triggering GC every now and then +(dotimes (y +n-manyraw+) + (dotimes (x +m-manyraw+) + (let ((a (random (expt 2 32))) + (b (random most-positive-single-float)) + (c (random most-positive-double-float)) + (d (complex + (random most-positive-single-float) + (random most-positive-single-float))) + (e (complex + (random most-positive-double-float) + (random most-positive-double-float)))) + (push (funcall (if (zerop (mod x 3)) + #'make-manyraw-subclass + #'make-manyraw) + :unraw-slot-just-for-variety + (list (+ x (* y +m-manyraw+)) a b c d e) + :a a + :b b + :c c + :d d + :e e) + *manyraw*))) + (room) + (sb-ext:gc)) +(check-manyraws *manyraw*) + +;;; try a full GC, too +(sb-ext:gc :full t) +(check-manyraws *manyraw*) + +;;; fasl dumper and loader also have special handling of raw slots, so +;;; dump all of them into a fasl +(defmethod make-load-form ((self manyraw) &optional env) + self env + :sb-just-dump-it-normally) +(with-open-file (s "tmp-defstruct.manyraw.lisp" + :direction :output + :if-exists :supersede) + (write-string "(defun dumped-manyraws () '#.*manyraw*)" s)) +(compile-file "tmp-defstruct.manyraw.lisp") + +;;; nuke the objects and try another GC just to be extra careful +(setf *manyraw* nil) +(sb-ext:gc :full t) + +;;; re-read the dumped structures and check them +(load "tmp-defstruct.manyraw.fasl") +(check-manyraws (dumped-manyraws)) + ;;;; miscellaneous old bugs diff --git a/version.lisp-expr b/version.lisp-expr index 5e98092..c0500a2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.37" +"0.9.1.38"