Menu
▾
▴
[Sbcl-commits] master: Faster MAP[-INTO] when (> SPEED SPACE)
|
From: Paul K. <pk...@us...> - 2011-06-21 00:44:54
|
The branch "master" has been updated in SBCL:
via 65a29e8b22383bda1d4ac20796c9b56529c02a6e (commit)
from 74a2974b2fd2fd94bd0b58d828f846a24cbdf3d7 (commit)
- Log -----------------------------------------------------------------
commit 65a29e8b22383bda1d4ac20796c9b56529c02a6e
Author: Paul Khuong <pv...@pv...>
Date: Mon Jun 20 20:44:07 2011 -0400
Faster MAP[-INTO] when (> SPEED SPACE)
Expand into WITH-ARRAY-DATA for non-simple vectors in such cases,
and avoid hairy vector accesses.
Also make sure to exploit that in conset code.
---
NEWS | 2 +
src/compiler/constraint.lisp | 1 +
src/compiler/seqtran.lisp | 77 +++++++++++++++++++++++++++++++----------
3 files changed, 61 insertions(+), 19 deletions(-)
diff --git a/NEWS b/NEWS
index f73e8fb..f052c31 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,8 @@ changes relative to sbcl-1.0.49:
COMPILATION-SPEED > SPEED.
* optimization: extracting bits of a single-float on x86-64 has been
optimized. (lp#555201)
+ * optimization: MAP and MAP-INTO are more efficient for non-simple vectors,
+ when (> SPEED SPACE).
* 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/constraint.lisp b/src/compiler/constraint.lisp
index 88a8252..5056510 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -427,6 +427,7 @@
(when ,constraints
(let ((,min (conset-min ,conset))
(,max (conset-max ,conset)))
+ (declare (optimize speed))
(map nil (lambda (constraint)
(declare (type constraint constraint))
(let ((number (constraint-number constraint)))
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 67ecb5a..d086e3e 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -126,14 +126,15 @@
;;; MAP-INTO. RESULT and BODY are forms, which can use variables
;;; FUNCALL-RESULT, containing the result of application of FUN, and
;;; INDEX, containing the current position in sequences.
-(defun build-sequence-iterator (seqs seq-names &key result into body)
+(defun build-sequence-iterator (seqs seq-names &key result into body fast)
(declare (type list seqs seq-names)
(type symbol into))
(collect ((bindings)
(declarations)
(vector-lengths)
(tests)
- (places))
+ (places)
+ (around))
(let ((found-vector-p nil))
(flet ((process-vector (length)
(unless found-vector-p
@@ -150,10 +151,22 @@
(declarations `(type list ,index))
(places `(car ,index))
(tests `(endp ,index))))
- ((csubtypep type (specifier-type 'vector))
+ ((or (csubtypep type (specifier-type '(simple-array * 1)))
+ (and (not fast)
+ (csubtypep type (specifier-type 'vector))))
(process-vector `(length ,seq-name))
(places `(locally (declare (optimize (insert-array-bounds-checks 0)))
(aref ,seq-name index))))
+ ((csubtypep type (specifier-type 'vector))
+ (let ((data (gensym "DATA"))
+ (start (gensym "START"))
+ (end (gensym "END")))
+ (around `(with-array-data ((,data ,seq-name)
+ (,start)
+ (,end (length ,seq-name)))))
+ (process-vector `(- ,end ,start))
+ (places `(locally (declare (optimize (insert-array-bounds-checks 0)))
+ (aref ,data (truly-the index (+ index ,start)))))))
(t
(give-up-ir1-transform
"can't determine sequence argument type"))))
@@ -162,12 +175,18 @@
(when found-vector-p
(bindings `(length (min ,@(vector-lengths))))
(tests `(>= index length)))
- `(do (,@(bindings))
- ((or ,@(tests)) ,result)
- (declare ,@(declarations))
- (let ((funcall-result (funcall fun ,@(places))))
- (declare (ignorable funcall-result))
- ,body)))))
+ (let ((body `(do (,@(bindings))
+ ((or ,@(tests)) ,result)
+ (declare ,@(declarations))
+ (let ((funcall-result (funcall fun ,@(places))))
+ (declare (ignorable funcall-result))
+ ,body))))
+ (if (around)
+ (reduce (lambda (wrap body) (append wrap (list body)))
+ (around)
+ :from-end t
+ :initial-value body)
+ body)))))
;;; Try to compile %MAP efficiently when we can determine sequence
;;; argument types at compile time.
@@ -182,7 +201,7 @@
;;; the reader, because the code is complicated enough already and I
;;; don't happen to need that functionality right now. -- WHN 20000410
(deftransform %map ((result-type fun seq &rest seqs) * *
- :policy (>= speed space))
+ :node node :policy (>= speed space))
"open code"
(unless (constant-lvar-p result-type)
(give-up-ir1-transform "RESULT-TYPE argument not constant"))
@@ -244,25 +263,45 @@
,(build-sequence-iterator
seqs seq-args
:result result
- :body push-dacc))))))))))
+ :body push-dacc
+ :fast (policy node (> speed space))))))))))))
;;; MAP-INTO
(deftransform map-into ((result fun &rest seqs)
(vector * &rest *)
- *)
+ * :node node)
"open code"
(let ((seqs-names (mapcar (lambda (x)
(declare (ignore x))
(gensym))
seqs)))
`(lambda (result fun ,@seqs-names)
- ,(build-sequence-iterator
- seqs seqs-names
- :result '(when (array-has-fill-pointer-p result)
- (setf (fill-pointer result) index))
- :into 'result
- :body '(locally (declare (optimize (insert-array-bounds-checks 0)))
- (setf (aref result index) funcall-result)))
+ ,(if (and (policy node (> speed space))
+ (not (csubtypep (lvar-type result)
+ (specifier-type '(simple-array * 1)))))
+ (let ((data (gensym "DATA"))
+ (start (gensym "START"))
+ (end (gensym "END")))
+ `(with-array-data ((,data result)
+ (,start)
+ (,end))
+ (declare (ignore ,end))
+ ,(build-sequence-iterator
+ seqs seqs-names
+ :result '(when (array-has-fill-pointer-p result)
+ (setf (fill-pointer result) index))
+ :into 'result
+ :body `(locally (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref ,data (truly-the index (+ index ,start)))
+ funcall-result))
+ :fast t)))
+ (build-sequence-iterator
+ seqs seqs-names
+ :result '(when (array-has-fill-pointer-p result)
+ (setf (fill-pointer result) index))
+ :into 'result
+ :body '(locally (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref result index) funcall-result))))
result)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|