;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.18 relative to 1.0.17:
+ * optimization: structure allocation has been improved
+ ** constructors created by non-toplevel DEFSTRUCTs are ~40% faster.
+ ** out of line constructors are ~10% faster.
+ ** inline constructors are ~15% faster.
+ ** inline constructors are capable of dynamic extent allocation
+ (generally on x86 and x86-64, in some cases on other platforms
+ as well.)
+
changes in sbcl-1.0.17 relative to 1.0.16:
* temporary regression: user code can no longer allocate closure
variable storage on stack, due to bug 419 without explicitly
# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
if [ "$sbcl_arch" = "x86" ]; then
printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
- printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop' >> $ltf
+ printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop :raw-instance-init-vops' >> $ltf
printf ' :stack-allocatable-closures :alien-callbacks :cycle-counter' >> $ltf
case "$sbcl_os" in
linux | freebsd | netbsd | openbsd | sunos | darwin | win32)
fi
elif [ "$sbcl_arch" = "x86-64" ]; then
printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf
- printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop' >> $ltf
+ printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop :raw-instance-init-vops' >> $ltf
printf ' :stack-allocatable-closures :alien-callbacks :cycle-counter' >> $ltf
elif [ "$sbcl_arch" = "mips" ]; then
printf ' :linkage-table' >> $ltf
"NOTE-FIXUP"
"DEF-CASSER"
"DEF-REFFER"
+ "EMIT-CONSTANT"
"EMIT-NOP"
"DEF-SETTER"
"FIXED-ALLOC"
#!+long-float "%LONG-FLOAT"
"%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE"
"%MAKE-RATIO" "%MAKE-LISP-OBJ"
+ "%MAKE-INSTANCE"
+ "%MAKE-STRUCTURE-INSTANCE"
+ "%MAKE-STRUCTURE-INSTANCE-ALLOCATOR"
"%MAP" "%MAP-TO-SIMPLE-VECTOR-ARITY-1"
"%MAP-TO-LIST-ARITY-1" "%MAP-TO-NIL-ON-SEQUENCE"
"%MAP-TO-NIL-ON-SIMPLE-VECTOR" "%MAP-TO-NIL-ON-VECTOR"
"MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE" "MAKE-NULL-LEXENV"
"MAKE-NUMERIC-TYPE"
"MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
- "MAKE-UNPORTABLE-FLOAT" "%MAKE-INSTANCE"
+ "MAKE-UNPORTABLE-FLOAT"
"MAKE-SHORT-VALUES-TYPE" "MAKE-SINGLE-VALUE-TYPE"
"MAKE-VALUE-CELL" "MAKE-VALUES-TYPE"
"MAPC-MEMBER-TYPE-MEMBERS" "MAPCAR-MEMBER-TYPE-MEMBERS"
(error "Class is not a structure class: ~S" name))
(t res))))
+(defun compiler-layout-ready-p (name)
+ (let ((layout (info :type :compiler-layout name)))
+ (and layout (typep (layout-info layout) 'defstruct-description))))
+
+(sb!xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
+ `(truly-the ,(dd-name dd)
+ ,(if (compiler-layout-ready-p (dd-name dd))
+ `(%make-structure-instance ,dd ,slot-specs ,@slot-vars)
+ ;; Non-toplevel defstructs don't have a layout at compile time,
+ ;; so we need to construct the actual function at runtime -- but
+ ;; we cache it at the call site, so that we don't perform quite
+ ;; so horribly.
+ `(let* ((cell (load-time-value (list nil)))
+ (fun (car cell)))
+ (if (functionp fun)
+ (funcall fun ,@slot-vars)
+ (funcall (setf (car cell)
+ (%make-structure-instance-allocator ,dd ,slot-specs))
+ ,@slot-vars))))))
+
+(declaim (ftype (sfunction (defstruct-description list) function)
+ %Make-structure-instance-allocator))
+(defun %make-structure-instance-allocator (dd slot-specs)
+ (let ((vars (make-gensym-list (length slot-specs))))
+ (values (compile nil `(lambda (,@vars)
+ (%make-structure-instance-macro ,dd ',slot-specs ,@vars))))))
+
;;; Delay looking for compiler-layout until the constructor is being
;;; compiled, since it doesn't exist until after the EVAL-WHEN
;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
(raw-type (missing-arg) :type (or symbol cons) :read-only t)
;; What operator is used to access a slot of this type?
(accessor-name (missing-arg) :type symbol :read-only t)
+ (init-vop (missing-arg) :type symbol :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
(list
(make-raw-slot-data :raw-type 'sb!vm:word
:accessor-name '%raw-instance-ref/word
+ :init-vop 'sb!vm::raw-instance-init/word
:n-words 1)
(make-raw-slot-data :raw-type 'single-float
:accessor-name '%raw-instance-ref/single
+ :init-vop 'sb!vm::raw-instance-init/single
;; KLUDGE: On 64 bit architectures, we
;; could pack two SINGLE-FLOATs into the
;; same word if raw slots were indexed
:n-words 1)
(make-raw-slot-data :raw-type 'double-float
:accessor-name '%raw-instance-ref/double
+ :init-vop 'sb!vm::raw-instance-init/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
+ :init-vop 'sb!vm::raw-instance-init/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
+ :init-vop 'sb!vm::raw-instance-init/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
+ :init-vop 'sb!vm::raw-instance-init/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
+ :init-vop 'sb!vm::raw-instance-init/complex-long
:n-words #!+x86 6 #!+sparc 8)))))
\f
;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
:destruct-layout old-layout))))
(values))
+(declaim (inline dd-layout-length))
+(defun dd-layout-length (dd)
+ (+ (dd-length dd) (dd-raw-length dd)))
+
+(declaim (ftype (sfunction (defstruct-description) index) dd-instance-length))
+(defun dd-instance-length (dd)
+ ;; 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 ((layout-length (dd-layout-length dd)))
+ (declare (index layout-length))
+ (+ layout-length (mod (1+ layout-length) 2))))
+
;;; This is called when we are about to define a structure class. It
;;; returns a (possibly new) class object and the layout which should
;;; be used for the new definition (may be the current layout, and
(let ((new-layout (make-layout :classoid class
:inherits inherits
:depthoid (length inherits)
- :length (+ (dd-length info)
- (dd-raw-length info))
+ :length (dd-layout-length info)
:n-untagged-slots (dd-raw-length info)
:info info))
(old-layout (or compiler-layout old-layout)))
(loop for dsd in (dd-slots dd) and val in values do
(setf (elt vals (dsd-index dsd))
(if (eq val '.do-not-initialize-slot.) 0 val)))
-
`(defun ,cons-name ,arglist
(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")))
+ ;; The difference between the two implementations here is that on all
+ ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
+ ;; must be able to deal with immediate values as well -- unlike
+ ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
+ ;; some additional cleverness we might manage without them and just a single
+ ;; implementation here, though -- figure out a way to ensure that on those
+ ;; platforms we always still get a non-immediate TN in every case...
+ ;;
+ ;; Until someone does that, this means that instances with raw slots can be
+ ;; DX allocated only on platforms with those additional VOPs.
+ #!+raw-instance-init-vops
+ (let* ((slot-values nil)
+ (slot-specs
+ (mapcan (lambda (dsd value)
+ (unless (eq value '.do-not-initialize-slot.)
+ (push value slot-values)
+ (list (list* :slot (dsd-raw-type dsd) (dsd-index dsd)))))
+ (dd-slots dd)
+ values)))
`(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))))))
- ,@(mapcar (lambda (dsd value)
- ;; (Note that we can't in general use the
- ;; ordinary named slot setter function here
- ;; because the slot might be :READ-ONLY, so we
- ;; whip up new LAMBDA representations of slot
- ;; setters for the occasion.)
- (unless (eq value '.do-not-initialize-slot.)
- `(,(slot-setter-lambda-form dd dsd) ,value ,instance)))
- (dd-slots dd)
- values)
- ,instance))))
+ (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
+ (%make-structure-instance-macro ,dd ',slot-specs ,@(reverse slot-values))))
+ #!-raw-instance-init-vops
+ (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values)
+ (mapc (lambda (dsd value)
+ (unless (eq value '.do-not-initialize-slot.)
+ (let ((raw-type (dsd-raw-type dsd)))
+ (cond ((eq t raw-type)
+ (push value slot-values)
+ (push (list* :slot raw-type (dsd-index dsd)) slot-specs))
+ (t
+ (push value raw-values)
+ (push dsd raw-slots))))))
+ (dd-slots dd)
+ values)
+ `(defun ,cons-name ,arglist
+ (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
+ ,(if raw-slots
+ `(let ((,instance (%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))
+ ,@(mapcar (lambda (dsd value)
+ ;; (Note that we can't in general use the
+ ;; ordinary named slot setter function here
+ ;; because the slot might be :READ-ONLY, so we
+ ;; whip up new LAMBDA representations of slot
+ ;; setters for the occasion.)
+ `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
+ raw-slots
+ raw-values)
+ ,instance)
+ `(%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))))
;;; Create a default (non-BOA) keyword constructor.
(defun create-keyword-constructor (defstruct creator)
(multiple-value-bind (raw-maker-form raw-reffer-operator)
(ecase dd-type
(structure
- (values `(let ((,object-gensym (%make-instance ,dd-length)))
- (setf (%instance-layout ,object-gensym)
- ,delayed-layout-form)
- ,object-gensym)
+ (values `(%make-structure-instance-macro ,dd nil)
'%instance-ref))
(funcallable-structure
(values `(let ((,object-gensym
(defun (setf funcallable-instance-fun) (new-value fin)
(setf (%funcallable-instance-function fin) new-value))
-
-;;; service function for structure constructors
-(defun %make-instance-with-layout (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
;;;; target-only parts of the DEFSTRUCT top level code
(ir2-convert-setter node block name offset lowtag)))))
name)
-(defun %def-alloc (name words variable-length-p header lowtag inits)
+(defun %def-alloc (name words allocation-style header lowtag inits)
(let ((info (fun-info-or-lose name)))
(setf (fun-info-ir2-convert info)
- (if variable-length-p
- (lambda (node block)
+ (ecase allocation-style
+ (:var-alloc
+ (lambda (node block)
(ir2-convert-variable-allocation node block name words header
- lowtag inits))
- (lambda (node block)
- (ir2-convert-fixed-allocation node block name words header
- lowtag inits)))))
+ lowtag inits)))
+ (:fixed-alloc
+ (lambda (node block)
+ (ir2-convert-fixed-allocation node block name words header
+ lowtag inits)))
+ (:structure-alloc
+ (lambda (node block)
+ (ir2-convert-structure-allocation node block name words header
+ lowtag inits))))))
name)
(defun %def-casser (name offset lowtag)
(flushable))
(defknown %make-instance (index) instance
- (unsafe))
+ (flushable))
+(defknown %make-structure-instance (defstruct-description list &rest t) instance
+ (flushable always-translatable))
(defknown %instance-layout (instance) layout
(foldable flushable))
(defknown %set-instance-layout (instance layout) layout
(in-package "SB!C")
+(def-alloc %make-structure-instance 1 :structure-alloc
+ sb!vm:instance-header-widetag sb!vm:instance-pointer-lowtag
+ nil)
+
+(defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args))
+ t)
+
(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
(let* ((lvar (node-lvar node))
(locs (lvar-result-tns lvar
res)
(move-lvar-result node block locs lvar)))
-(defun emit-inits (node block name result lowtag inits args)
+(defun emit-inits (node block name object lowtag inits args)
(let ((unbound-marker-tn nil)
(funcallable-instance-tramp-tn nil))
(dolist (init inits)
(let ((kind (car init))
(slot (cdr init)))
- (vop set-slot node block result
- (ecase kind
- (:arg
- (aver args)
- (lvar-tn node block (pop args)))
- (:unbound
- (or unbound-marker-tn
- (setf unbound-marker-tn
- (let ((tn (make-restricted-tn
- nil
- (sc-number-or-lose 'sb!vm::any-reg))))
- (vop make-unbound-marker node block tn)
- tn))))
- (:null
- (emit-constant nil))
- (:funcallable-instance-tramp
- (or funcallable-instance-tramp-tn
- (setf funcallable-instance-tramp-tn
- (let ((tn (make-restricted-tn
- nil
- (sc-number-or-lose 'sb!vm::any-reg))))
- (vop make-funcallable-instance-tramp node block tn)
- tn)))))
- name slot lowtag))))
- (aver (null args)))
+ (case kind
+ (:slot
+ (let ((raw-type (pop slot))
+ (arg-tn (lvar-tn node block (pop args))))
+ (macrolet ((make-case ()
+ `(ecase raw-type
+ ((t)
+ (vop set-slot node block object arg-tn
+ name (+ sb!vm:instance-slots-offset slot) lowtag))
+ ,@(mapcar (lambda (rsd)
+ `(,(sb!kernel::raw-slot-data-raw-type rsd)
+ (vop ,(sb!kernel::raw-slot-data-init-vop rsd)
+ node block
+ object arg-tn slot)))
+ #!+raw-instance-init-vops
+ sb!kernel::*raw-slot-data-list*
+ #!-raw-instance-init-vops
+ nil))))
+ (make-case))))
+ (:dd
+ (vop set-slot node block object
+ (emit-constant (sb!kernel::dd-layout-or-lose slot))
+ name sb!vm:instance-slots-offset lowtag))
+ (otherwise
+ (vop set-slot node block object
+ (ecase kind
+ (:arg
+ (aver args)
+ (lvar-tn node block (pop args)))
+ (:unbound
+ (or unbound-marker-tn
+ (setf unbound-marker-tn
+ (let ((tn (make-restricted-tn
+ nil
+ (sc-number-or-lose 'sb!vm::any-reg))))
+ (vop make-unbound-marker node block tn)
+ tn))))
+ (:null
+ (emit-constant nil))
+ (:funcallable-instance-tramp
+ (or funcallable-instance-tramp-tn
+ (setf funcallable-instance-tramp-tn
+ (let ((tn (make-restricted-tn
+ nil
+ (sc-number-or-lose 'sb!vm::any-reg))))
+ (vop make-funcallable-instance-tramp node block tn)
+ tn)))))
+ name slot lowtag))))))
+ (unless (null args)
+ (bug "Leftover args: ~S" args)))
(defun emit-fixed-alloc (node block name words type lowtag result lvar)
(let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar))))
(emit-inits node block name result lowtag inits args)
(move-lvar-result node block locs lvar)))
+(defoptimizer ir2-convert-structure-allocation
+ ((dd slot-specs &rest args) node block name words type lowtag inits)
+ (let* ((lvar (node-lvar node))
+ (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
+ (result (first locs)))
+ (aver (constant-lvar-p dd))
+ (aver (constant-lvar-p slot-specs))
+ (let* ((c-dd (lvar-value dd))
+ (c-slot-specs (lvar-value slot-specs))
+ (words (+ (sb!kernel::dd-instance-length c-dd) words)))
+ (emit-fixed-alloc node block name words type lowtag result lvar)
+ (emit-inits node block name result lowtag `((:dd . ,c-dd) ,@c-slot-specs) args)
+ (move-lvar-result node block locs lvar))))
+
;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
;;; cut it for symbols, where under certain compilation options
;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
(constants `(def!constant ,size ,offset))
(exports size)))
(when alloc-trans
- (forms `(def-alloc ,alloc-trans ,offset ,variable-length-p ,widetag
- ,lowtag ',(inits))))
+ (forms `(def-alloc ,alloc-trans ,offset
+ ,(if variable-length-p :var-alloc :fixed-alloc)
+ ,widetag
+ ,lowtag ',(inits))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(%define-primitive-object
`(%def-reffer ',name ,offset ,lowtag))
(defmacro def-setter (name offset lowtag)
`(%def-setter ',name ,offset ,lowtag))
-(defmacro def-alloc (name words variable-length-p header lowtag inits)
- `(%def-alloc ',name ,words ,variable-length-p ,header ,lowtag ,inits))
+(defmacro def-alloc (name words alloc-style header lowtag inits)
+ `(%def-alloc ',name ,words ,alloc-style ,header ,lowtag ,inits))
#!+compare-and-swap-vops
(defmacro def-casser (name offset lowtag)
`(%def-casser ',name ,offset ,lowtag))
(inst mov (make-ea-for-raw-slot object index tmp) value)
(move result value)))
+(define-vop (raw-instance-init/word)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg)))
+ (:arg-types * unsigned-num)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 4
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (inst mov (make-ea-for-raw-slot object index tmp) value)))
+
(define-vop (raw-instance-ref/single)
(:translate %raw-instance-ref/single)
(:policy :fast-safe)
(unless (location= result value)
(inst movss result value))))
+(define-vop (raw-instance-init/single)
+ (:translate %raw-instance-set/single)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (single-reg)))
+ (:arg-types * single-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 4
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (inst movss (make-ea-for-raw-slot object index tmp) value)))
+
(define-vop (raw-instance-ref/double)
(:translate %raw-instance-ref/double)
(:policy :fast-safe)
(unless (location= result value)
(inst movsd result value))))
+(define-vop (raw-instance-init/double)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (double-reg)))
+ (:arg-types * double-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 4
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (inst movsd (make-ea-for-raw-slot object index tmp) value)))
+
(define-vop (raw-instance-ref/complex-single)
(:translate %raw-instance-ref/complex-single)
(:policy :fast-safe)
(unless (location= value-imag result-imag)
(inst movss result-imag value-imag)))))
+(define-vop (raw-instance-init/complex-single)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (complex-single-reg)))
+ (:arg-types * complex-single-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 4
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (let ((value-real (complex-single-reg-real-tn value)))
+ (inst movss (make-ea-for-raw-slot object index tmp) value-real))
+ (let ((value-imag (complex-single-reg-imag-tn value)))
+ (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag))))
+
(define-vop (raw-instance-ref/complex-double)
(:translate %raw-instance-ref/complex-double)
(:policy :fast-safe)
(inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
(unless (location= value-imag result-imag)
(inst movsd result-imag value-imag)))))
+
+(define-vop (raw-instance-init/complex-double)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (complex-double-reg)))
+ (:arg-types * complex-double-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 4
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (let ((value-real (complex-double-reg-real-tn value)))
+ (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real))
+ (let ((value-imag (complex-double-reg-imag-tn value)))
+ (inst movsd (make-ea-for-raw-slot object index tmp) value-imag))))
;;;; raw instance slot accessors
(defun make-ea-for-raw-slot (object index instance-length n-words)
- (sc-case index
- (any-reg (make-ea :dword
- :base object
- :index instance-length
- :disp (- (* (- instance-slots-offset n-words)
- n-word-bytes)
- instance-pointer-lowtag)))
- (immediate (make-ea :dword :base object
- :index instance-length
- :scale 4
- :disp (- (* (- instance-slots-offset n-words)
- n-word-bytes)
- instance-pointer-lowtag
- (fixnumize (tn-value index)))))))
+ (flet ((make-ea-using-value (value)
+ (make-ea :dword :base object
+ :index instance-length
+ :scale 4
+ :disp (- (* (- instance-slots-offset n-words)
+ n-word-bytes)
+ instance-pointer-lowtag
+ (fixnumize value)))))
+ (if (typep index 'tn)
+ (sc-case index
+ (any-reg (make-ea :dword
+ :base object
+ :index instance-length
+ :disp (- (* (- instance-slots-offset n-words)
+ n-word-bytes)
+ instance-pointer-lowtag)))
+ (immediate (make-ea-using-value (tn-value index))))
+ (make-ea-using-value index))))
(define-vop (raw-instance-ref/word)
(:translate %raw-instance-ref/word)
(inst mov (make-ea-for-raw-slot object index tmp 1) value)
(move result value)))
+(define-vop (raw-instance-init/word)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg)))
+ (:arg-types * unsigned-num)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 5
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (inst mov (make-ea-for-raw-slot object index tmp 1) value)))
+
(define-vop (raw-instance-ref/single)
(:translate %raw-instance-ref/single)
(:policy :fast-safe)
(inst fst result))
(inst fxch value)))))
+(define-vop (raw-instance-init/single)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (single-reg)))
+ (:arg-types * single-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 5
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (with-tn@fp-top (value)
+ (inst fst (make-ea-for-raw-slot object index tmp 1)))))
+
(define-vop (raw-instance-ref/double)
(:translate %raw-instance-ref/double)
(:policy :fast-safe)
(inst fstd result))
(inst fxch value)))))
+(define-vop (raw-instance-init/double)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (double-reg)))
+ (:arg-types * double-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 5
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (with-tn@fp-top (value)
+ (inst fstd (make-ea-for-raw-slot object index tmp 2)))))
+
(define-vop (raw-instance-ref/complex-single)
(:translate %raw-instance-ref/complex-single)
(:policy :fast-safe)
(inst fst result-imag))
(inst fxch value-imag))))
+(define-vop (raw-instance-init/complex-single)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (complex-single-reg)))
+ (:arg-types * complex-single-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 5
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (let ((value-real (complex-single-reg-real-tn value)))
+ (with-tn@fp-top (value-real)
+ (inst fst (make-ea-for-raw-slot object index tmp 2))))
+ (let ((value-imag (complex-single-reg-imag-tn value)))
+ (with-tn@fp-top (value-imag)
+ (inst fst (make-ea-for-raw-slot object index tmp 1))))))
+
(define-vop (raw-instance-ref/complex-double)
(:translate %raw-instance-ref/complex-double)
(:policy :fast-safe)
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
+
+(define-vop (raw-instance-init/complex-double)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (complex-double-reg)))
+ (:arg-types * complex-double-float)
+ (:info index)
+ (:temporary (:sc unsigned-reg) tmp)
+ (:generator 20
+ (loadw tmp object 0 instance-pointer-lowtag)
+ (inst shr tmp n-widetag-bits)
+ (let ((value-real (complex-double-reg-real-tn value)))
+ (with-tn@fp-top (value-real)
+ (inst fstd (make-ea-for-raw-slot object index tmp 4))))
+ (let ((value-imag (complex-double-reg-imag-tn value)))
+ (with-tn@fp-top (value-imag)
+ (inst fstd (make-ea-for-raw-slot object index tmp 2))))))
;;; will probably be loading the wrong register!
(defmacro with-empty-tn@fp-top((tn) &body body)
`(progn
- (inst fstp ,tn)
- ,@body
- (unless (zerop (tn-offset ,tn))
- (inst fxch ,tn)))) ; save into new dest and restore st(0)
+ (inst fstp ,tn)
+ ,@body
+ (unless (zerop (tn-offset ,tn))
+ (inst fxch ,tn)))) ; save into new dest and restore st(0)
\f
;;;; instruction-like macros
(defun make-defstruct-allocation-function (class)
;; FIXME: Why don't we go class->layout->info == dd
(let ((dd (find-defstruct-description (class-name class))))
- (lambda ()
- (sb-kernel::%make-instance-with-layout
- (sb-kernel::compiler-layout-or-lose (dd-name dd))))))
+ (%make-structure-instance-allocator dd nil)))
(defmethod shared-initialize :after
((class structure-class) slot-names &key
(make-raw-slot-equalp-bug :a 1d0 :b 3s0))))
(assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
(make-raw-slot-equalp-bug :a 2d0 :b 2s0)))))
+
+;;; Check that all slot types (non-raw and raw) can be initialized with
+;;; constant arguments.
+(defstruct constant-arg-inits
+ (a 42 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float)
+ (f #c(5.0 5.0) :type (complex single-float))
+ (g #c(6.0d0 6.0d0) :type (complex double-float)))
+(defun test-constant-arg-inits ()
+ (let ((foo (make-constant-arg-inits)))
+ (declare (dynamic-extent foo))
+ (assert (eql 42 (constant-arg-inits-a foo)))
+ (assert (eql 1 (constant-arg-inits-b foo)))
+ (assert (eql 2 (constant-arg-inits-c foo)))
+ (assert (eql 3.0 (constant-arg-inits-d foo)))
+ (assert (eql 4.0d0 (constant-arg-inits-e foo)))
+ (assert (eql #c(5.0 5.0) (constant-arg-inits-f foo)))
+ (assert (eql #c(6.0d0 6.0d0) (constant-arg-inits-g foo)))))
+(make-constant-arg-inits)
(true v)
nil))
+;;; MAKE-STRUCTURE
+
+(declaim (inline make-fp-struct-1))
+(defstruct fp-struct-1
+ (s 0.0 :type single-float)
+ (d 0.0d0 :type double-float))
+
+(defun-with-dx test-fp-struct-1.1 (s d)
+ (let ((fp (make-fp-struct-1 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql 0.0d0 (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.2 (s d)
+ (let ((fp (make-fp-struct-1 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.3 (s d)
+ (let ((fp (make-fp-struct-1 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.4 (s d)
+ (let ((fp (make-fp-struct-1 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(test-fp-struct-1.1 123.456 876.243d0)
+(test-fp-struct-1.2 123.456 876.243d0)
+(test-fp-struct-1.3 123.456 876.243d0)
+(test-fp-struct-1.4 123.456 876.243d0)
+
+(declaim (inline make-fp-struct-2))
+(defstruct fp-struct-2
+ (d 0.0d0 :type double-float)
+ (s 0.0 :type single-float))
+
+(defun-with-dx test-fp-struct-2.1 (s d)
+ (let ((fp (make-fp-struct-2 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql 0.0d0 (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.2 (s d)
+ (let ((fp (make-fp-struct-2 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.3 (s d)
+ (let ((fp (make-fp-struct-2 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.4 (s d)
+ (let ((fp (make-fp-struct-2 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(test-fp-struct-2.1 123.456 876.243d0)
+(test-fp-struct-2.2 123.456 876.243d0)
+(test-fp-struct-2.3 123.456 876.243d0)
+(test-fp-struct-2.4 123.456 876.243d0)
+
+(declaim (inline make-cfp-struct-1))
+(defstruct cfp-struct-1
+ (s (complex 0.0) :type (complex single-float))
+ (d (complex 0.0d0) :type (complex double-float)))
+
+(defun-with-dx test-cfp-struct-1.1 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.2 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.3 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.4 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+
+(declaim (inline make-cfp-struct-2))
+(defstruct cfp-struct-2
+ (d (complex 0.0d0) :type (complex double-float))
+ (s (complex 0.0) :type (complex single-float)))
+
+(defun-with-dx test-cfp-struct-2.1 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.2 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.3 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.4 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+
+(declaim (inline make-foo1 make-foo2 make-foo3))
+(defstruct foo1 x)
+
+(defun-with-dx make-foo1-on-stack (x)
+ (let ((foo (make-foo1 :x x)))
+ (declare (dynamic-extent foo))
+ (assert (eql x (foo1-x foo)))))
+
+(defstruct foo2
+ (x 0.0 :type single-float)
+ (y 0.0d0 :type double-float)
+ a
+ b
+ c)
+
+(defmacro assert-eql (expected got)
+ `(let ((exp ,expected)
+ (got ,got))
+ (unless (eql exp got)
+ (error "Expected ~S, got ~S!" exp got))))
+
+(defun-with-dx make-foo2-on-stack (x y)
+ (let ((foo (make-foo2 :y y :c 'c)))
+ (declare (dynamic-extent foo))
+ (assert-eql 0.0 (foo2-x foo))
+ (assert-eql y (foo2-y foo))
+ (assert-eql 'c (foo2-c foo))
+ (assert-eql nil (foo2-b foo))))
+
+;;; Check that constants work out as argument for all relevant
+;;; slot types.
+(defstruct foo3
+ (a 0 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float))
+(defun-with-dx make-foo3-on-stack ()
+ (let ((foo (make-foo3)))
+ (declare (dynamic-extent foo))
+ (assert (eql 0 (foo3-a foo)))
+ (assert (eql 1 (foo3-b foo)))
+ (assert (eql 2 (foo3-c foo)))
+ (assert (eql 3.0 (foo3-d foo)))
+ (assert (eql 4.0d0 (foo3-e foo)))))
+
;;; Nested DX
(defun-with-dx nested-dx-lists ()
(assert-no-consing (dx-value-cell 13))
(assert-no-consing (cons-on-stack 42))
(assert-no-consing (make-array-on-stack))
+ (assert-no-consing (make-foo1-on-stack 123))
+ (#+raw-instance-init-vops assert-no-consing
+ #-raw-instance-init-vops progn
+ (make-foo2-on-stack 1.24 1.23d0))
+ (#+raw-instance-init-vops assert-no-consing
+ #-raw-instance-init-vops progn
+ (make-foo3-on-stack))
(assert-no-consing (nested-dx-conses))
(assert-no-consing (nested-dx-lists))
(assert-consing (nested-dx-not-used *a-cons*))
;;; 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".)
-"1.0.17.3"
+"1.0.17.4"
projects / sbcl.git / commitdiff