From: Nikodemus Siivola Date: Wed, 28 May 2008 22:32:28 +0000 (+0000) Subject: 1.0.17.4: support for dynamic-extent structures X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=96bb2dc76dddb1a21b3886fa7522796879e9ed9d;p=sbcl.git 1.0.17.4: support for dynamic-extent structures * Replace %MAKE-INSTANCE-WITH-LAYOUT with %MAKE-STRUCTURE-INSTANCE, which has an IR2 transform that can handle both initialization and allocation of the structure. On x86 and x86-64 it can initialize all slots, whereas on other platforms it only does the layout and non-raw slots. (See RAW-INSTANCE-INIT/* below.) * EMIT-INITS needs two new kinds of inits to handle: :SLOT for instance slots, and :DD for the defstruct-description/layout. * DEF-ALLOC doesn't anymore use a simple boolean for denoting variable length allocation, but instead a keyword: either :VAR-ALLOC, :FIXED-ALLOC, or :STRUCTURE-ALLOC. * New VOPs: RAW-INSTANCE-INIT/* for all raw slot types, which are almost identical to RAW-INSTANCE-SET[-C]/* VOPs, except that they always have a constant index and do not return a result. Structures with raw slots can be stack allocated only on platforms that implement these VOPs, denoted in make-config.sh by the :RAW-INSTANCE-INIT-VOPS feature. ...we really could use a *VM-FEATURES* or something. --- diff --git a/NEWS b/NEWS index d6e2011..e37de68 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,13 @@ ;;;; -*- 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 diff --git a/make-config.sh b/make-config.sh index 7c6997d..e0e439d 100644 --- a/make-config.sh +++ b/make-config.sh @@ -282,7 +282,7 @@ cd "$original_dir" # 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) @@ -295,7 +295,7 @@ if [ "$sbcl_arch" = "x86" ]; then 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 129bfb6..c27b7b9 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -334,6 +334,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "NOTE-FIXUP" "DEF-CASSER" "DEF-REFFER" + "EMIT-CONSTANT" "EMIT-NOP" "DEF-SETTER" "FIXED-ALLOC" @@ -1210,6 +1211,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." #!+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" @@ -1392,7 +1396,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 97dc74e..c757550 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -26,6 +26,33 @@ (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 @@ -223,6 +250,7 @@ (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 @@ -242,9 +270,11 @@ (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 @@ -258,22 +288,27 @@ :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))))) ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its @@ -1142,6 +1177,22 @@ :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 @@ -1179,8 +1230,7 @@ (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))) @@ -1304,29 +1354,60 @@ (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) @@ -1632,10 +1713,7 @@ (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 diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index f179459..7db7029 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -151,19 +151,6 @@ (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)) ;;;; target-only parts of the DEFSTRUCT top level code diff --git a/src/compiler/fun-info-funs.lisp b/src/compiler/fun-info-funs.lisp index 600e735..d399be7 100644 --- a/src/compiler/fun-info-funs.lisp +++ b/src/compiler/fun-info-funs.lisp @@ -23,16 +23,22 @@ (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) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index ff95944..bd96d7b 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -111,7 +111,9 @@ (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 diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index e2deca6..19527a6 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -9,6 +9,13 @@ (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 @@ -46,37 +53,62 @@ 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)))) @@ -107,6 +139,20 @@ (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 diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 3bcb46c..096890f 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -119,8 +119,10 @@ (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 @@ -141,8 +143,8 @@ `(%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)) diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 2a02340..213c900 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -607,6 +607,17 @@ (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) @@ -678,6 +689,19 @@ (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) @@ -749,6 +773,17 @@ (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) @@ -840,6 +875,20 @@ (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) @@ -930,3 +979,17 @@ (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)))) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 241d434..73cfc6f 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -503,20 +503,24 @@ ;;;; 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) @@ -553,6 +557,17 @@ (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) @@ -600,6 +615,18 @@ (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) @@ -647,6 +674,18 @@ (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) @@ -713,6 +752,22 @@ (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) @@ -778,3 +833,19 @@ (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)))))) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index df6f856..5489a36 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -31,10 +31,10 @@ ;;; 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) ;;;; instruction-like macros diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ef3f7e3..a82dc8c 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -659,9 +659,7 @@ (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 diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index b80e723..3549268 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -715,3 +715,25 @@ (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) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index e27f5ae..10677ac 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -155,6 +155,190 @@ (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 () @@ -250,6 +434,13 @@ (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*)) diff --git a/version.lisp-expr b/version.lisp-expr index 4f98205..7a76638 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.17.3" +"1.0.17.4"