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,
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.
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
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)
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
"%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"
"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"
;;; 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
;; 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)
;;; 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
;; 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
',(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.
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)))
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"
;;; 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
;;; 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
(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
(find-and-init-or-check-layout name
0
inherits-vector
- depthoid)
+ depthoid
+ 0)
:invalidate nil)))))
(/show0 "done with loop over *BUILT-IN-CLASSES*"))
(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"))
"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)))
;;; 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)
(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
;; 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.
;; 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)
\f
;;;; 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)))))
\f
;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
;;;; close personal friend SB!XC:DEFSTRUCT)
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)
(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)
;;; 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)
(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
(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
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)))
(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
;;; 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
;;; 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*))
(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")
(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))
;;; 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))
\f
;;; 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)
,@(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
(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))
\f
(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)
(define-mutator-accessors words-consed :ub32 nil))
); #+gengc progn
+
+
+\f
+;;;; 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)))))
(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
(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))
(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)))
;;; 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.
(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)
(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))
(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*)
(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
(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))
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"
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))))
\f
;;;; cold fops for loading symbols
(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
(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
(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 (*)))
#+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
(descriptor-reg any-reg null zero) * code-header-set)
+\f
+;;;; 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)))))
(:policy :fast-safe)
(:variant 0 other-pointer-lowtag))
+
+\f
+;;;; 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)))))
(:policy :fast-safe)
(:variant 0 other-pointer-lowtag))
+
+\f
+;;;; 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)))))
(define-full-setter code-header-set * 0 other-pointer-lowtag
(any-reg descriptor-reg) * code-header-set)
+
+
+\f
+;;;; 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)))))
(define-full-setter code-header-set * 0 other-pointer-lowtag
(any-reg descriptor-reg) * code-header-set)
+
+
+\f
+;;;; 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))))
(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)
#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
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)
{
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
#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);
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) */
}
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
/* 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)) ==
/* 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)) ==
/* 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)) ==
/*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];
/* 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;
}
#include "thread.h"
#include "genesis/primitive-objects.h"
#include "genesis/static-symbols.h"
+#include "genesis/layout.h"
#define PRINTNOISE
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;
;;;; 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))
(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))))
+
+\f
+;;;; 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))
+
\f
;;;; miscellaneous old bugs
;;; 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"
projects / sbcl.git / commitdiff