Menu
▾
▴
[Sbcl-commits] master: Unboxed implicit value cells on x86[-64]
|
From: Paul K. <pk...@us...> - 2011-06-21 04:34:17
|
The branch "master" has been updated in SBCL:
via 99a669b8fc3624c6b5aa68580829f50288169c31 (commit)
from 56a2dbbb9d79a62db99cc4061e50fca74fcf907e (commit)
- Log -----------------------------------------------------------------
commit 99a669b8fc3624c6b5aa68580829f50288169c31
Author: Paul Khuong <pv...@pv...>
Date: Tue Jun 21 00:31:00 2011 -0400
Unboxed implicit value cells on x86[-64]
Implicit value cells are used for bindings that are only closed
over by dynamic-extent functions.
The logic would have to be somewhat modified on platforms with
NFP. As is, only implement support for unboxed implicit value
cells on x86oids (for signed and unsigned words, SAPs and float
reals and complexes).
---
NEWS | 2 +
src/compiler/x86-64/call.lisp | 73 +++++++++++++++++++++++
src/compiler/x86-64/vm.lisp | 4 -
src/compiler/x86/call.lisp | 131 +++++++++++++++++++++++++++++++++++++++++
src/compiler/x86/vm.lisp | 4 -
5 files changed, 206 insertions(+), 8 deletions(-)
diff --git a/NEWS b/NEWS
index b7fde0b..77866cb 100644
--- a/NEWS
+++ b/NEWS
@@ -17,6 +17,8 @@ changes relative to sbcl-1.0.49:
when (> SPEED SPACE).
* optimization: local call trampolines (x86 and x86-64) are emitted
inline.
+ * optimization: implicit value cells for dynamic-extent closed-over bindings
+ on x86 and x86-64 can hold unboxed values as well.
* meta-optimization: improved compilation speed, especially for large
functions. (lp#792363 and lp#394206)
* bug fix: bound derivation for floating point operations is now more
diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp
index ace16ff..b19771d 100644
--- a/src/compiler/x86-64/call.lisp
+++ b/src/compiler/x86-64/call.lisp
@@ -139,6 +139,79 @@
(storew value frame-pointer
(frame-word-offset (tn-offset variable-home-tn)))))
+(macrolet ((define-frame-op
+ (suffix sc stack-sc instruction
+ &optional (ea
+ `(make-ea :qword
+ :base frame-pointer
+ :disp (frame-byte-offset
+ (tn-offset variable-home-tn)))))
+ (let ((reffer (symbolicate 'ancestor-frame-ref '/ suffix))
+ (setter (symbolicate 'ancestor-frame-set '/ suffix)))
+ `(progn
+ (define-vop (,reffer ancestor-frame-ref)
+ (:results (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ (inst ,instruction value
+ ,ea)))
+ (define-vop (,setter ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ (inst ,instruction ,ea value)))))))
+ (define-frame-op double-float double-reg double-stack movsd)
+ (define-frame-op single-float single-reg single-stack movss)
+ (define-frame-op complex-double-float complex-double-reg complex-double-stack
+ movupd (ea-for-cdf-data-stack variable-home-tn frame-pointer))
+ (define-frame-op complex-single-float complex-single-reg complex-single-stack
+ movq (ea-for-csf-data-stack variable-home-tn frame-pointer))
+ (define-frame-op signed-byte-64 signed-reg signed-stack mov)
+ (define-frame-op unsigned-byte-64 unsigned-reg unsigned-stack mov)
+ (define-frame-op system-area-pointer sap-reg sap-stack mov))
+
+(defun primitive-type-indirect-cell-type (ptype)
+ (declare (type primitive-type ptype))
+ (macrolet ((foo (&body data)
+ `(case (primitive-type-name ptype)
+ ,@(loop for (name stack-sc ref set) in data
+ collect
+ `(,name
+ (load-time-value
+ (list (primitive-type-or-lose ',name)
+ (sc-or-lose ',stack-sc)
+ (lambda (node block fp value res)
+ (sb!c::vop ,ref node block
+ fp value res))
+ (lambda (node block fp new-val value)
+ (sb!c::vop ,set node block
+ fp new-val value)))))))))
+ (foo (double-float double-stack
+ ancestor-frame-ref/double-float
+ ancestor-frame-set/double-float)
+ (single-float single-stack
+ ancestor-frame-ref/single-float
+ ancestor-frame-set/single-float)
+ (complex-double-float complex-double-stack
+ ancestor-frame-ref/complex-double-float
+ ancestor-frame-set/complex-double-float)
+ (complex-single-float complex-single-stack
+ ancestor-frame-ref/complex-single-float
+ ancestor-frame-set/complex-single-float)
+ (signed-byte-64 signed-stack
+ ancestor-frame-ref/signed-byte-64
+ ancestor-frame-set/signed-byte-64)
+ (unsigned-byte-64 unsigned-stack
+ ancestor-frame-ref/unsigned-byte-64
+ ancestor-frame-set/unsigned-byte-64)
+ (unsigned-byte-63 unsigned-stack
+ ancestor-frame-ref/unsigned-byte-64
+ ancestor-frame-set/unsigned-byte-64)
+ (system-area-pointer sap-stack
+ ancestor-frame-ref/system-area-pointer
+ ancestor-frame-set/system-area-pointer))))
+
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
(:vop-var vop)
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index 77bd30e..63af4f9 100644
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -552,7 +552,3 @@
(!def-vm-support-routine combination-implementation-style (node)
(declare (type sb!c::combination node) (ignore node))
(values :default nil))
-
-(defun primitive-type-indirect-cell-type (ptype)
- (declare (ignore ptype))
- nil)
diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp
index 8e0db43..72936a3 100644
--- a/src/compiler/x86/call.lisp
+++ b/src/compiler/x86/call.lisp
@@ -139,6 +139,137 @@
(storew value frame-pointer
(frame-word-offset (tn-offset variable-home-tn)))))
+(macrolet ((define-frame-op
+ (suffix sc stack-sc instruction
+ &optional (ea
+ `(make-ea :dword
+ :base frame-pointer
+ :disp (frame-byte-offset
+ (tn-offset variable-home-tn)))))
+ (let ((reffer (symbolicate 'ancestor-frame-ref '/ suffix))
+ (setter (symbolicate 'ancestor-frame-set '/ suffix)))
+ `(progn
+ (define-vop (,reffer ancestor-frame-ref)
+ (:results (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ (inst ,instruction value
+ ,ea)))
+ (define-vop (,setter ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ (inst ,instruction ,ea value))))))
+ (define-x87-frame-op
+ (suffix sc stack-sc (load set)
+ &optional (ea
+ `(make-ea :dword
+ :base frame-pointer
+ :disp (frame-byte-offset
+ (tn-offset variable-home-tn)))))
+ (let ((reffer (symbolicate 'ancestor-frame-ref '/ suffix))
+ (setter (symbolicate 'ancestor-frame-set '/ suffix)))
+ `(progn
+ (define-vop (,reffer ancestor-frame-ref)
+ (:results (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ ,(if (symbolp load)
+ `(with-empty-tn@fp-top (value)
+ (inst ,load ,ea))
+ load)))
+ (define-vop (,setter ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (,sc)))
+ (:generator 4
+ (aver (sc-is variable-home-tn ,stack-sc))
+ ,(if (symbolp set)
+ `(with-tn@fp-top (value)
+ (inst ,set ,ea))
+ set)))))))
+ (define-frame-op signed-byte-32 signed-reg signed-stack mov)
+ (define-frame-op unsigned-byte-32 unsigned-reg unsigned-stack mov)
+ (define-frame-op system-area-pointer sap-reg sap-stack mov)
+
+ (define-x87-frame-op double-float double-reg double-stack
+ (fldd fstd) (make-ea :dword
+ :base frame-pointer
+ :disp (frame-byte-offset
+ (1+ (tn-offset variable-home-tn)))))
+ (define-x87-frame-op single-float single-reg single-stack
+ (fld fst))
+
+ (define-x87-frame-op complex-double-float complex-double-reg
+ complex-double-stack
+ ((let ((real (complex-double-reg-real-tn value))
+ (imag (complex-double-reg-imag-tn value)))
+ (with-empty-tn@fp-top (real)
+ (inst fldd (ea-for-cdf-real-stack variable-home-tn frame-pointer)))
+ (with-empty-tn@fp-top (imag)
+ (inst fldd (ea-for-cdf-imag-stack variable-home-tn frame-pointer))))
+ (let ((real (complex-double-reg-real-tn value))
+ (imag (complex-double-reg-imag-tn value)))
+ (with-tn@fp-top (real)
+ (inst fstd (ea-for-cdf-real-stack variable-home-tn frame-pointer)))
+ (with-tn@fp-top (imag)
+ (inst fstd (ea-for-cdf-imag-stack variable-home-tn frame-pointer))))))
+ (define-x87-frame-op complex-single-float complex-single-reg
+ complex-single-stack
+ ((let ((real (complex-single-reg-real-tn value))
+ (imag (complex-single-reg-imag-tn value)))
+ (with-empty-tn@fp-top (real)
+ (inst fld (ea-for-csf-real-stack variable-home-tn frame-pointer)))
+ (with-empty-tn@fp-top (imag)
+ (inst fld (ea-for-csf-imag-stack variable-home-tn frame-pointer))))
+ (let ((real (complex-single-reg-real-tn value))
+ (imag (complex-single-reg-imag-tn value)))
+ (with-tn@fp-top (real)
+ (inst fst (ea-for-csf-real-stack variable-home-tn frame-pointer)))
+ (with-tn@fp-top (imag)
+ (inst fst (ea-for-csf-imag-stack variable-home-tn frame-pointer)))))))
+
+(defun primitive-type-indirect-cell-type (ptype)
+ (declare (type primitive-type ptype))
+ (macrolet ((foo (&body data)
+ `(case (primitive-type-name ptype)
+ ,@(loop for (name stack-sc ref set) in data
+ collect
+ `(,name
+ (load-time-value
+ (list (primitive-type-or-lose ',name)
+ (sc-or-lose ',stack-sc)
+ (lambda (node block fp value res)
+ (sb!c::vop ,ref node block
+ fp value res))
+ (lambda (node block fp new-val value)
+ (sb!c::vop ,set node block
+ fp new-val value)))))))))
+ (foo (double-float double-stack
+ ancestor-frame-ref/double-float
+ ancestor-frame-set/double-float)
+ (single-float single-stack
+ ancestor-frame-ref/single-float
+ ancestor-frame-set/single-float)
+ (complex-double-float complex-double-stack
+ ancestor-frame-ref/complex-double-float
+ ancestor-frame-set/complex-double-float)
+ (complex-single-float complex-single-stack
+ ancestor-frame-ref/complex-single-float
+ ancestor-frame-set/complex-single-float)
+ (signed-byte-32 signed-stack
+ ancestor-frame-ref/signed-byte-32
+ ancestor-frame-set/signed-byte-32)
+ (unsigned-byte-32 unsigned-stack
+ ancestor-frame-ref/unsigned-byte-32
+ ancestor-frame-set/unsigned-byte-32)
+ (unsigned-byte-31 unsigned-stack
+ ancestor-frame-ref/unsigned-byte-32
+ ancestor-frame-set/unsigned-byte-32)
+ (system-area-pointer sap-stack
+ ancestor-frame-ref/system-area-pointer
+ ancestor-frame-set/system-area-pointer))))
+
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
(:vop-var vop)
diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp
index d2b7ba5..ae0b111 100644
--- a/src/compiler/x86/vm.lisp
+++ b/src/compiler/x86/vm.lisp
@@ -516,7 +516,3 @@
(%logbitp integer index))))
(t (values :default nil))))
(t (values :default nil)))))
-
-(defun primitive-type-indirect-cell-type (ptype)
- (declare (ignore ptype))
- nil)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
