From 9ed1517375b86e4df9d886f930ce1a42bcc31ce2 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Thu, 9 Mar 2006 12:58:44 +0000 Subject: [PATCH] 0.9.10.25: Port dynamic-extent vector support from x86 to x86-64. --- NEWS | 2 + src/assembly/x86-64/array.lisp | 24 +---------- src/compiler/x86-64/alloc.lisp | 90 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 95 insertions(+), 23 deletions(-) diff --git a/NEWS b/NEWS index 69c4092..37c364f 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,8 @@ changes in sbcl-0.9.11 relative to sbcl-0.9.10: more complex forms, including calls to constant-foldable standardized functions and some special forms beyond QUOTE. * fixed bug: occasional GC crashes on Solaris/x86 + * optimization: x86-64 supports stack allocation of results of simple + calls of MAKE-ARRAY, bound to variables, declared DYNAMIC-EXTENT changes in sbcl-0.9.10 relative to sbcl-0.9.9: * new feature: new SAVE-LISP-AND-DIE keyword argument :EXECUTABLE can diff --git a/src/assembly/x86-64/array.lisp b/src/assembly/x86-64/array.lisp index 226dbcb..98bb8a5 100644 --- a/src/assembly/x86-64/array.lisp +++ b/src/assembly/x86-64/array.lisp @@ -12,28 +12,8 @@ (in-package "SB!VM") -;;;; allocation +;;;; Note: On other platforms ALLOCATE-VECTOR is an assembly routine, +;;;; but on X86-64 it is a VOP. -(define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type unsigned-reg eax-offset) - (:arg length any-reg ebx-offset) - (:arg words any-reg ecx-offset) - (:res result descriptor-reg edx-offset)) - (inst mov result (+ (1- (ash 1 n-lowtag-bits)) - (* vector-data-offset n-word-bytes))) - (inst add result words) - (inst and result (lognot lowtag-mask)) - (pseudo-atomic - (allocation result result) - (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag)) - (storew type result 0 other-pointer-lowtag) - (storew length result vector-length-slot other-pointer-lowtag)) - (inst ret)) - ;;;; Note: CMU CL had assembly language primitives for hashing strings, ;;;; but SBCL doesn't. diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index bcc7a74..7138cdd 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -74,6 +74,96 @@ ;;;; special-purpose inline allocators +;;; ALLOCATE-VECTOR +(define-vop (allocate-vector-on-heap) + (:args (type :scs (unsigned-reg)) + (length :scs (any-reg)) + (words :scs (any-reg))) + (:results (result :scs (descriptor-reg) :from :load)) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum) + (:policy :fast-safe) + (:generator 100 + (inst lea result (make-ea :byte :base words :disp + (+ (1- (ash 1 n-lowtag-bits)) + (* vector-data-offset n-word-bytes)))) + (inst and result (lognot lowtag-mask)) + (pseudo-atomic + (allocation result result) + (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag)) + (storew type result 0 other-pointer-lowtag) + (storew length result vector-length-slot other-pointer-lowtag)))) + +(define-vop (allocate-vector-on-stack) + (:args (type :scs (unsigned-reg)) + (length :scs (any-reg)) + (words :scs (any-reg) :target ecx)) + (:temporary (:sc any-reg :offset ecx-offset :from (:argument 2)) ecx) + (:temporary (:sc any-reg :offset eax-offset :from (:argument 2)) zero) + (:temporary (:sc any-reg :offset edi-offset :from (:argument 0)) res) + (:results (result :scs (descriptor-reg) :from :load)) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum) + (:translate allocate-vector) + (:policy :fast-safe) + (:node-var node) + (:generator 100 + (inst lea result (make-ea :byte :base words :disp + (+ (1- (ash 1 n-lowtag-bits)) + (* vector-data-offset n-word-bytes)))) + (inst and result (lognot lowtag-mask)) + ;; FIXME: It would be good to check for stack overflow here. + (move ecx words) + (inst shr ecx n-fixnum-tag-bits) + (allocation result result node t) + (inst cld) + (inst lea res + (make-ea :byte :base result :disp (* vector-data-offset n-word-bytes))) + (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag)) + (storew type result 0 other-pointer-lowtag) + (storew length result vector-length-slot other-pointer-lowtag) + (inst xor zero zero) + (inst rep) + (inst stos zero))) + +(in-package "SB!C") + +(defoptimizer (allocate-vector stack-allocate-result) + ((type length words) node) + (ecase (policy node stack-allocate-vector) + (0 nil) + ((1 2) + ;; a vector object should fit in one page + (values-subtypep (lvar-derived-type words) + (load-time-value + (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-size* + sb!vm:n-word-bytes) + sb!vm:vector-data-offset)))))) + (3 t))) + +(defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) + (let ((args (basic-combination-args call)) + (template (template-or-lose (if (awhen (node-lvar call) + (lvar-dynamic-extent it)) + 'sb!vm::allocate-vector-on-stack + 'sb!vm::allocate-vector-on-heap)))) + (dolist (arg args) + (setf (lvar-info arg) + (make-ir2-lvar (primitive-type (lvar-type arg))))) + (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) + (ltn-default-call call) + (return-from allocate-vector-ltn-annotate-optimizer (values))) + (setf (basic-combination-info call) template) + (setf (node-tail-p call) nil) + + (dolist (arg args) + (annotate-1-value-lvar arg)))) + +(in-package "SB!VM") + +;;; (define-vop (allocate-code-object) (:args (boxed-arg :scs (any-reg) :target boxed) (unboxed-arg :scs (any-reg) :target unboxed)) diff --git a/version.lisp-expr b/version.lisp-expr index 1b8cfd9..c5f2b3f 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".) -"0.9.10.24" +"0.9.10.25" -- 1.7.10.4