0.9.1.38:

	Merge DFL raw-slots patch (sbcl-devel "raw slot changes"
	2005-05-18)
	... with an amalgam of ths' two mips versions;
	... note in OPTIMIZATIONS about the negative index idea, and the
		disabledness of HPPA

diff --git a/CREDITS b/CREDITS
index 01ce3e1..1384e2f 100644 (file)
--- a/CREDITS
+++ b/CREDITS
@@ -596,7 +596,11 @@ Frederik Kuivinen:
 
 Arthur Lemmens:
   He found and fixed a number of SBCL bugs while partially porting
 
 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, 
 
 Robert MacLachlan:
   He has continued to answer questions about, and contribute fixes to, 

@@ -687,6 +691,10 @@ Rudi Schlatte:
   string extractor that keeps function documentation in the manual
   current.
 
   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.
 
 Julian Squires:
   He worked on Unicode support for the PowerPC platform.
 

@@ -750,10 +758,12 @@ APD  Alexey Dejneka
 PFD  Paul F. Dietz
 NJF  Nathan Froyd
 AL   Arthur Lemmens
 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
 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
 NS   Nikodemus Siivola
 PVE  Peter Van Eynde
 PW   Paul Werkowski

diff --git a/NEWS b/NEWS
index 428c0ae..78b18d7 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,9 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1:
     generic sense) arithmetic routines.  (thanks to Thiemo Seufer)
   * optimization: direct conversion of (unsigned-byte 32) to floats on
     the PowerPC platform.
     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)
   * contrib improvement: it's harder to cause SOCKET-CLOSE to close()
     the wrong file descriptor; implementation of SOCKET-OPEN-P.
     (thanks to Tony Martinez)

diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS
index eb2931f..a702c7d 100644 (file)
--- a/OPTIMIZATIONS
+++ b/OPTIMIZATIONS
@@ -224,3 +224,11 @@ Initialization of stack-allocated arrays is inefficient: we always
 fill the vector with zeroes, even when it is not needed (as for
 platforms with conservative GC or for arrays of unboxed objectes) and
 is performed later explicitely.
 fill the vector with zeroes, even when it is not needed (as for
 platforms with conservative GC or for arrays of unboxed objectes) and
 is performed later explicitely.

+--------------------------------------------------------------------------------
+#28
+a. Accessing raw slots in structure instances is more inefficient than
+it could be; if we placed raw slots before the header word, we would
+not need to do arithmetic at runtime to access them.  (But beware:
+this would complicate handling of the interior pointer).
+
+b. (Also note that raw slots are currently disabled on HPPA)
\ No newline at end of file

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index c07596e..a44e070 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1109,6 +1109,13 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%RAW-SET-COMPLEX-DOUBLE" "%RAW-SET-COMPLEX-LONG"
                "%RAW-SET-COMPLEX-SINGLE" "%RAW-SET-DOUBLE"
                "%RAW-SET-LONG" "%RAW-SET-SINGLE" "%SCALB" "%SCALBN"
                "%RAW-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"
                "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-FUN"
                "%SET-FUNCALLABLE-INSTANCE-INFO"
                "%SET-RAW-BITS" "%SET-VECTOR-RAW-BITS"

@@ -1221,6 +1228,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "IRRATIONAL" "JUST-DUMP-IT-NORMALLY" "KEY-INFO"
                "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE"
                "LAYOUT-DEPTHOID" "LAYOUT-INVALID-ERROR"
                "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"
                #!+(or x86-64 x86) "%LEA"
                "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" "ANSI-STREAM"
                "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE"

diff --git a/src/code/class.lisp b/src/code/class.lisp
index 515f3b4..a3a8169 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -113,12 +113,6 @@
 ;;; type checking and garbage collection. Whenever a class is
 ;;; incompatibly redefined, a new layout is allocated. If two object's
 ;;; layouts are EQ, then they are exactly the same type.
 ;;; 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
 (def!struct (layout
             ;; KLUDGE: A special hack keeps this from being
             ;; called when building code for the

@@ -201,8 +195,11 @@
   ;; substructure (and hence can be copied into read-only space by
   ;; PURIFY).
   ;;
   ;; 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)
 
 (def!method print-object ((layout layout) stream)
   (print-unreadable-object (layout stream :type t :identity t)

@@ -278,16 +275,19 @@
 ;;; preexisting class slot value is OK, and if it's not initialized,
 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
 ;;; is no longer true, :UNINITIALIZED used instead.
 ;;; 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))
                          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
   (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
               (layout-classoid layout) classoid
               (layout-invalid layout) nil))
        ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this

@@ -299,7 +299,7 @@
         ;; information, and we'll now check that old information
         ;; which was known with certainty is consistent with current
         ;; information which is known with certainty.
         ;; 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)
 
 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the

@@ -338,7 +338,8 @@
                            ',(layout-classoid layout)
                            ',(layout-length layout)
                            ',(layout-inherits layout)
                            ',(layout-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.
 
 ;;; If LAYOUT's slot values differ from the specified slot values in
 ;;; any interesting way, then give a warning and return T.

@@ -347,10 +348,11 @@
                           simple-string
                           index
                           simple-vector
                           simple-string
                           index
                           simple-vector

-                          layout-depthoid))
+                          layout-depthoid
+                          index))

                redefine-layout-warning))
 (defun redefine-layout-warning (old-context old-layout
                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)))
   (declare (type layout old-layout) (type simple-string old-context context))
   (let ((name (layout-proper-name old-layout)))
     (or (let ((old-inherits (layout-inherits old-layout)))

@@ -386,6 +388,15 @@
                  old-context old-length
                  context length)
            t))
                  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"
        (unless (= (layout-depthoid old-layout) depthoid)
          (warn "change in the inheritance structure of class ~S~%  ~
                  between the ~A definition and the ~A definition"

@@ -395,12 +406,13 @@
 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
 ;;; INHERITS, and DEPTHOID.
 (declaim (ftype (function
 ;;; 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))
                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
   (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
     ;; Classic CMU CL had more options here. There are several reasons
     ;; why they might want more options which are less appropriate for
     ;; us: (1) It's hard to fit the classic CMU CL flexible approach

@@ -425,16 +437,18 @@
 ;;; Used by the loader to forward-reference layouts for classes whose
 ;;; definitions may not have been loaded yet. This allows type tests
 ;;; to be loaded when the type definition hasn't been loaded yet.
 ;;; 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))
                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
   (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
 
 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
 ;;; of all superclasses. This is the operation that "installs" a

@@ -480,6 +494,7 @@
              (layout-inherits destruct-layout) (layout-inherits layout)
              (layout-depthoid destruct-layout)(layout-depthoid layout)
              (layout-length destruct-layout) (layout-length layout)
              (layout-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
              (layout-info destruct-layout) (layout-info layout)
              (classoid-layout classoid) destruct-layout)
        (setf (layout-invalid layout) nil

@@ -1335,7 +1350,8 @@ NIL is returned when no such class exists."
           (find-and-init-or-check-layout name
                                          0
                                          inherits-vector
           (find-and-init-or-check-layout name
                                          0
                                          inherits-vector

-                                         depthoid)
+                                         depthoid
+                                         0)

           :invalidate nil)))))
   (/show0 "done with loop over *BUILT-IN-CLASSES*"))
 
           :invalidate nil)))))
   (/show0 "done with loop over *BUILT-IN-CLASSES*"))
 

@@ -1379,7 +1395,7 @@ NIL is returned when no such class exists."
                             (classoid-layout (find-classoid x)))
                           inherits-list)))
        #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
                             (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"))
 
                         :invalidate nil))))
   (/show0 "done defining temporary STANDARD-CLASSes"))
 

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 39b93b0..29c854a 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -315,7 +315,8 @@
                                      "new"
                                      (layout-length layout)
                                      (layout-inherits layout)
                                      "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)))
             (register-layout layout :invalidate t))
            ((not (classoid-layout class))
             (register-layout layout)))

diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp
index 000e8e6..ea47a7c 100644 (file)
--- a/src/code/defsetfs.lisp
+++ b/src/code/defsetfs.lisp
@@ -39,6 +39,11 @@
 ;;; from defstruct.lisp
 (in-package "SB!KERNEL")
 (defsetf %instance-ref %instance-set)
 ;;; 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)
 
 (defsetf %raw-ref-single %raw-set-single)
 (defsetf %raw-ref-double %raw-set-double)
 

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 6508d2c..2ed87b4 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -108,7 +108,8 @@
   (slots () :type list)
   ;; a list of (NAME . INDEX) pairs for accessors of included structures
   (inherited-accessor-alist () :type list)
   (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
   (length 0 :type index)
   ;; General kind of implementation.
   (type 'structure :type (member structure vector list

@@ -132,11 +133,7 @@
   ;; option was given with no argument, or 0 if no PRINT-OBJECT option
   ;; was given
   (print-object 0 :type (or cons symbol (member 0)))
   ;; 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.
   (raw-length 0 :type index)
   ;; the value of the :PURE option, or :UNSPECIFIED. This is only
   ;; meaningful if DD-CLASS-P = T.

@@ -192,14 +189,12 @@
   ;; If this object does not describe a raw slot, this value is T.
   ;;
   ;; If this object describes a raw slot, this value is the type of the
   ;; 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
   (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)
   (read-only nil :type (member t nil)))
 (def!method print-object ((x defstruct-slot-description) stream)
   (print-unreadable-object (x stream :type t)

@@ -215,59 +210,75 @@
 \f
 ;;;; shared machinery for inline and out-of-line slot accessor functions
 
 \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
     ;;
 (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)
     (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)
     (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*
 
   (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)
 \f
 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
 ;;;; close personal friend SB!XC:DEFSTRUCT)

@@ -691,63 +702,42 @@
     slot))
 
 ;;; When a value of type TYPE is stored in a structure, should it be
     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
 
 ;;; 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)
 (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)
   (values))
 
 (defun typed-structure-info-or-lose (name)

@@ -795,7 +785,6 @@
                  (cons included-name mc))))
        (when (eq (dd-pure dd) :unspecified)
          (setf (dd-pure dd) (dd-pure included-structure)))
                  (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)
        (setf (dd-raw-length dd) (dd-raw-length included-structure)))
 
       (setf (dd-inherited-accessor-alist dd)

@@ -898,8 +887,7 @@
 ;;; Return a form describing the writable place used for this slot
 ;;; in the instance named INSTANCE-NAME.
 (defun %accessor-place-form (dd dsd instance-name)
 ;;; 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)
        (ref (ecase (dd-type dd)
               (structure '%instance-ref)
               (list 'nth-but-with-sane-arg-order)

@@ -910,26 +898,8 @@
        (let* ((raw-slot-data (find raw-type *raw-slot-data-list*
                                    :key #'raw-slot-data-raw-type
                                    :test #'equal))
        (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
 
 ;;; Return source transforms for the reader and writer functions of
 ;;; the slot described by DSD. They should be inline expanded, but

@@ -1192,7 +1162,9 @@
     (let ((new-layout (make-layout :classoid class
                                   :inherits inherits
                                   :depthoid (length inherits)
     (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
                                   :info info))
          (old-layout (or compiler-layout old-layout)))
       (cond

@@ -1211,7 +1183,8 @@
                                 new-context
                                 (layout-length new-layout)
                                 (layout-inherits new-layout)
                                 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)))
        (values class new-layout old-layout))
        (t
        (let ((old-info (layout-info old-layout)))

@@ -1319,18 +1292,13 @@
        (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
        (list ,@vals))))
 (defun create-structure-constructor (dd cons-name arglist vars types values)
        (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))))))
     `(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
         ,@(mapcar (lambda (dsd value)
                     ;; (Note that we can't in general use the
                     ;; ordinary named slot setter function here

diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp
index f48bf3e..d72d5f4 100644 (file)
--- a/src/code/early-fasl.lisp
+++ b/src/code/early-fasl.lisp
@@ -76,7 +76,7 @@
 ;;; versions which break binary compatibility. But it certainly should
 ;;; be incremented for release versions which break binary
 ;;; compatibility.
 ;;; 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
 ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
 ;;; 38: (2003-01-05) changed names of internal SORT machinery
 ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to

@@ -121,6 +121,7 @@
 ;;;     FIND-FOREIGN-SYMBOL-IN-TABLE &co.
 ;;; 56: (2005-05-22) Something between 0.9.0.1 and 0.9.0.14. My money is
 ;;;     on 0.9.0.6 (MORE CASE CONSISTENCY).
 ;;;     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*))
 
 ;;; the conventional file extension for our fasl files
 (declaim (type simple-string *fasl-file-type*))

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 89bafa3..6a44362 100644 (file)
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -142,18 +142,25 @@
   (let* ((size (clone-arg))
         (res (%make-instance size)))
     (declare (type index size))
   (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)
     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)))
        (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")
 
 (define-fop (fop-end-group 64 :stackp nil)
   (/show0 "THROWing FASL-GROUP-END")

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 7cf0795..22d7199 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -31,6 +31,48 @@
 (defun %instance-set (instance index new-value)
   (setf (%instance-ref instance index) new-value))
 
 (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))
 (defun %raw-ref-single (vec index)
   (declare (type index index))
   (%raw-ref-single vec index))

@@ -136,7 +178,14 @@
 
 ;;; service function for structure constructors
 (defun %make-instance-with-layout (layout)
 
 ;;; 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
     (setf (%instance-layout result) layout)
     result))
 \f

@@ -255,6 +304,9 @@
 ;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler
 ;;; thing, putting in the type checks unconditionally.)
 
 ;;; 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)
 
 ;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN).
 (defun slot-accessor-funs (dd dsd)
 

@@ -292,21 +344,12 @@
                     ,@(mapcar (lambda (rtd)
                                 (let ((raw-type (raw-slot-data-raw-type rtd))
                                       (accessor-name
                     ,@(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")
                                   `((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
                               *raw-slot-data-list*)
                     ;; oops
                     (t

@@ -378,28 +421,24 @@
   (declare (type structure-object structure))
   (let* ((len (%instance-length structure))
         (res (%make-instance len))
   (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.
 
     (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.
       (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
 
     res))
 \f

diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp
index 35fdcdc..cbc2267 100644 (file)
--- a/src/code/target-sxhash.lisp
+++ b/src/code/target-sxhash.lisp
@@ -289,13 +289,16 @@
         (name (classoid-name classoid))
         (result (mix (sxhash name) (the fixnum 79867))))
     (declare (type fixnum result))
         (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)))))
       (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)
     result))
 
 (defun list-psxhash (key depthoid)

diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp
index 3220e7d..1757d9c 100644 (file)
--- a/src/compiler/alpha/cell.lisp
+++ b/src/compiler/alpha/cell.lisp
@@ -388,3 +388,284 @@
   (define-mutator-accessors words-consed :ub32 nil))
 
 ); #+gengc progn
   (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)))))

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 610c1db..6bfc35c 100644 (file)
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -1315,14 +1315,20 @@
       (error "attempt to dump invalid structure:~%  ~S~%How did this happen?"
             struct)))
   (note-potential-circularity struct file)
       (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))
        (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
           (ref (gethash obj circ)))
       (cond (ref

+            (aver (not (zerop index)))

             (push (make-circularity :type :struct-set
                                     :object struct
                                     :index index
             (push (make-circularity :type :struct-set
                                     :object struct
                                     :index index

@@ -1347,4 +1353,5 @@
   (sub-dump-object (layout-inherits obj) file)
   (sub-dump-object (layout-depthoid obj) file)
   (sub-dump-object (layout-length obj) file)
   (sub-dump-object (layout-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))
   (dump-fop 'fop-layout file))

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index ba452c3..4da74cc 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -378,6 +378,15 @@
                 (ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
         (ash bits (- 1 sb!vm:n-lowtag-bits)))))
 
                 (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)))
 ;;; common idioms
 (defun descriptor-bytes (des)
   (gspace-bytes (descriptor-intuit-gspace des)))

@@ -844,7 +853,7 @@ core and return a descriptor to it."
 ;;; FIXME: This information should probably be pulled out of the
 ;;; cross-compiler's tables at genesis time instead of inserted by
 ;;; hand here as a bare numeric constant.
 ;;; 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.
 
 ;;; Return a list of names created from the cold layout INHERITS data
 ;;; in X.

@@ -862,9 +871,10 @@ core and return a descriptor to it."
                   (descriptor-bits des)))))
       (res))))
 
                   (descriptor-bits des)))))
       (res))))
 

-(declaim (ftype (function (symbol descriptor descriptor descriptor) descriptor)
+(declaim (ftype (function (symbol descriptor descriptor descriptor descriptor)
+                         descriptor)

                make-cold-layout))
                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)
   (let ((result (allocate-boxed-object *dynamic*
                                       ;; KLUDGE: Why 1+? -- WHN 19990901
                                       (1+ target-layout-length)

@@ -944,14 +954,16 @@ core and return a descriptor to it."
       (write-wordindexed result (+ base 3) depthoid)
       (write-wordindexed result (+ base 4) length)
       (write-wordindexed result (+ base 5) *nil-descriptor*) ; info
       (write-wordindexed result (+ base 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)
 
     (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))
     (setf (gethash (descriptor-bits result) *cold-layout-names*) name)
 
     result))

@@ -968,7 +980,9 @@ core and return a descriptor to it."
                          (number-to-core target-layout-length)
                          (vector-in-core)
                          ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
                          (number-to-core 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*)
   (write-wordindexed *layout-layout*
                     sb!vm:instance-slots-offset
                     *layout-layout*)

@@ -982,22 +996,26 @@ core and return a descriptor to it."
          (make-cold-layout 't
                            (number-to-core 0)
                            (vector-in-core)
          (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 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)
         (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)
         (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
         (layout-inherits (vector-in-core t-layout
                                          i-layout
                                          so-layout

@@ -1944,19 +1962,28 @@ core and return a descriptor to it."
   (let* ((size (clone-arg))
         (result (allocate-boxed-object *dynamic*
                                        (1+ size)
   (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))
     (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)
       (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)
     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))
         (depthoid-des (pop-stack))
         (cold-inherits (pop-stack))
         (name (pop-stack))

@@ -1974,16 +2001,18 @@ core and return a descriptor to it."
           old-name
           old-length
           old-inherits-list
           old-name
           old-length
           old-inherits-list

-          old-depthoid)
+          old-depthoid
+          old-nuntagged)

          old
        (declare (type descriptor old-layout-descriptor))
          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))
        (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"
          (unless (= length old-length)
            (error "cold loading a reference to class ~S when the compile~%~
                     time length was ~S and current length is ~S"

@@ -2003,10 +2032,17 @@ core and return a descriptor to it."
                     depthoid is ~S"
                   name
                   depthoid
                     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.
        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
 
 \f
 ;;;; cold fops for loading symbols
 

@@ -2777,6 +2813,23 @@ core and return a descriptor to it."
       (terpri)))
     (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
 
       (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
 (defun write-static-symbols ()
   (dolist (symbol (cons nil sb!vm:*static-symbols*))
     ;; FIXME: It would be nice to use longer names than NIL and

@@ -3230,6 +3283,11 @@ initially undefined function references:~2%")
                    (format t "~&#include \"~A.h\"~%"
                            (string-downcase 
                             (string (sb!vm:primitive-object-name obj)))))))
                    (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
        (out-to "static-symbols" (write-static-symbols))
        
       (when core-file-name

diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 98bebdc..1f3f2ae 100644 (file)
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -121,6 +121,32 @@
   (unsafe))
 (defknown %layout-invalid-error (t layout) nil)
 
   (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:deftype raw-vector () '(simple-array sb!vm:word (*)))
 

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index b85fdb1..2144cbd 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -288,7 +288,10 @@
                    #+sb-xc-host structure!object
                    #-sb-xc-host instance
                    (when (emit-make-load-form value)
                    #+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
                        (grovel (%instance-ref value i)))))
                   (t
                    (compiler-error

diff --git a/src/compiler/mips/cell.lisp b/src/compiler/mips/cell.lisp
index a9eb189..7a80016 100644 (file)
--- a/src/compiler/mips/cell.lisp
+++ b/src/compiler/mips/cell.lisp
@@ -292,4 +292,348 @@
   (descriptor-reg any-reg null zero) * code-header-set)
 
 
   (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)))))

diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp
index 428b0b6..d1dc086 100644 (file)
--- a/src/compiler/ppc/cell.lisp
+++ b/src/compiler/ppc/cell.lisp
@@ -292,3 +292,250 @@
   (:policy :fast-safe)
   (:variant 0 other-pointer-lowtag))
 
   (: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)))))

diff --git a/src/compiler/sparc/cell.lisp b/src/compiler/sparc/cell.lisp
index 3cad61b..0888f32 100644 (file)
--- a/src/compiler/sparc/cell.lisp
+++ b/src/compiler/sparc/cell.lisp
@@ -287,3 +287,250 @@
   (:policy :fast-safe)
   (:variant 0 other-pointer-lowtag))
 
   (: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)))))

diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 031167b..4be9484 100644 (file)
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -486,3 +486,282 @@
 
 (define-full-setter code-header-set * 0 other-pointer-lowtag
   (any-reg descriptor-reg) * code-header-set)
 
 (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)))))

diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 63a74ef..016a85e 100644 (file)
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -489,3 +489,340 @@
 
 (define-full-setter code-header-set * 0 other-pointer-lowtag
   (any-reg descriptor-reg) * code-header-set)
 
 (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))))

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index eaa7ad0..41b4390 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -650,15 +650,8 @@
 (defun make-defstruct-allocation-function (class)
   (let ((dd (get-structure-dd (class-name class))))
     (lambda ()
 (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)
 
 (defmethod shared-initialize :after
     ((class structure-class)

diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c
index c083096..8e8b3fa 100644 (file)
--- a/src/runtime/gc-common.c
+++ b/src/runtime/gc-common.c
@@ -41,6 +41,7 @@
 #include "gc.h"
 #include "genesis/primitive-objects.h"
 #include "genesis/static-symbols.h"
 #include "gc.h"
 #include "genesis/primitive-objects.h"
 #include "genesis/static-symbols.h"

+#include "genesis/layout.h"

 #include "gc-internal.h"
 
 #ifdef LISP_FEATURE_SPARC
 #include "gc-internal.h"
 
 #ifdef LISP_FEATURE_SPARC

@@ -643,6 +644,24 @@ scav_boxed(lispobj *where, lispobj object)
     return 1;
 }
 
     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)
 {
 static lispobj
 trans_boxed(lispobj object)
 {

@@ -1708,7 +1727,7 @@ gc_init_tables(void)
     scavtab[CHARACTER_WIDETAG] = scav_immediate;
     scavtab[SAP_WIDETAG] = scav_unboxed;
     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
     scavtab[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
 #ifdef LISP_FEATURE_SPARC
     scavtab[FDEFN_WIDETAG] = scav_boxed;
 #else

diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c
index 3657381..6f59ffe 100644 (file)
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -44,6 +44,7 @@
 #include "genesis/vector.h"
 #include "genesis/weak-pointer.h"
 #include "genesis/simple-fun.h"
 #include "genesis/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);
 
 /* forward declarations */
 long gc_find_freeish_pages(long *restart_page_ptr, long nbytes, int unboxed);

@@ -1712,7 +1713,7 @@ scav_vector(lispobj *where, lispobj object)
     unsigned long kv_length;
     lispobj *kv_vector;
     unsigned long length = 0; /* (0 = dummy to stop GCC warning) */
     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) */
     lispobj empty_symbol;
     unsigned long *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */
     unsigned long *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */

@@ -1745,8 +1746,10 @@ scav_vector(lispobj *where, lispobj object)
     }
     hash_table = (lispobj *)native_pointer(where[2]);
     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
     }
     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 element 1, which should be some internal symbol that

@@ -1765,19 +1768,19 @@ scav_vector(lispobj *where, lispobj object)
 
     /* Scavenge hash table, which will fix the positions of the other
      * needed objects. */
 
     /* Scavenge hash table, 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. */
 
     /* 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 */

-    weak_p_obj = hash_table[10];
+    weak_p_obj = hash_table->weak_p;

 
     /* index vector */
     {
 
     /* 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)) ==
 
        if (is_lisp_pointer(index_vector_obj) &&
            (widetag_of(*(lispobj *)native_pointer(index_vector_obj)) ==

@@ -1793,7 +1796,7 @@ scav_vector(lispobj *where, lispobj object)
 
     /* next vector */
     {
 
     /* 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)) ==
 
        if (is_lisp_pointer(next_vector_obj) &&
            (widetag_of(*(lispobj *)native_pointer(next_vector_obj)) ==

@@ -1809,11 +1812,7 @@ scav_vector(lispobj *where, lispobj object)
 
     /* maybe hash vector */
     {
 
     /* 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)) ==
 
        if (is_lisp_pointer(hash_vector_obj) &&
            (widetag_of(*(lispobj *)native_pointer(hash_vector_obj)) ==

@@ -1876,8 +1875,8 @@ scav_vector(lispobj *where, lispobj object)
                            /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/
                            index_vector[old_index] = next_vector[i];
                            /* Link it into the needing rehash chain. */
                            /*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];
                            /*SHOW("P2");*/
                        } else {
                            unsigned prior = index_vector[old_index];

@@ -1893,8 +1892,8 @@ scav_vector(lispobj *where, lispobj object)
                                    /* Link it into the needing rehash
                                     * chain. */
                                    next_vector[next] =
                                    /* 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;
                                }
                                    /*SHOW("/P3");*/
                                    break;
                                }

diff --git a/src/runtime/purify.c b/src/runtime/purify.c
index 8a95542..992df23 100644 (file)
--- a/src/runtime/purify.c
+++ b/src/runtime/purify.c
@@ -33,6 +33,7 @@
 #include "thread.h"
 #include "genesis/primitive-objects.h"
 #include "genesis/static-symbols.h"
 #include "thread.h"
 #include "genesis/primitive-objects.h"
 #include "genesis/static-symbols.h"

+#include "genesis/layout.h"

 
 #define PRINTNOISE
 
 
 #define PRINTNOISE
 

@@ -1392,6 +1393,18 @@ pscav(lispobj *addr, long nwords, boolean constant)
                count = pscav_fdefn((struct fdefn *)addr);
                break;
 
                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;
               default:
                 count = 1;
                 break;

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index f1b06b5..6102a14 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -349,13 +349,13 @@
 ;;;; some other raw slot).
 
 (defstruct manyraw
 ;;;; 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))
   (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))
   (bb 0.1 :type single-float)
   (cc 0.2d0 :type double-float)
   (dd #c(0.3 0.3) :type (complex single-float))

@@ -391,6 +391,94 @@
   (assert (eql (manyraw-cc copy) 0.22d0))
   (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
   (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
   (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
 
 \f
 ;;;; miscellaneous old bugs
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 5e98092..c0500a2 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; 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"