Permalink
Browse files

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.
  • Loading branch information...
1 parent 6075b05 commit 96bb2dc76dddb1a21b3886fa7522796879e9ed9d @nikodemus nikodemus committed May 28, 2008
View
@@ -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
View
@@ -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
@@ -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"
@@ -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
@@ -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
@@ -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)
@@ -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
Oops, something went wrong.

0 comments on commit 96bb2dc

Please sign in to comment.