From 6b7bbf81c281587766961638f44f2a0a9f8f0d98 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Sun, 27 Apr 2003 13:58:59 +0000 Subject: [PATCH] Borrow SBCL's new deftransform for map-into to speed up map-into. --- compiler/fndb.lisp | 7 ++++++- compiler/seqtran.lisp | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 38 insertions(+), 2 deletions(-) diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index e72e45933..99428b6c5 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.112 2003/04/26 19:34:52 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.113 2003/04/27 13:58:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -416,6 +416,11 @@ ; :derive-type 'type-spec-arg1 Nope... (map nil ...) returns null, not nil. ) +(defknown map-into (sequence callable &rest sequence) + sequence + (call) + :derive-type #'result-type-first-arg) + ;;; Returns predicate result... (defknown some (callable sequence &rest sequence) t (foldable flushable call)) diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp index 79fba8c07..ead63aeb6 100644 --- a/compiler/seqtran.lisp +++ b/compiler/seqtran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.26 2003/04/21 15:56:31 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.27 2003/04/27 13:58:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -70,6 +70,37 @@ (def-source-transform mapcon (function list &rest more-lists) (mapper-transform function (cons list more-lists) :nconc nil)) + +;;; MAP-INTO +(deftransform map-into ((result fun &rest seqs) + (vector * &rest *) + *) + "open code" + (let ((seqs-names (mapcar (lambda (x) + (declare (ignore x)) + (gensym)) + seqs))) + `(lambda (result fun ,@seqs-names) + (let ((length (array-dimension result 0)) + (i 0)) + (declare (type index i)) + (declare (ignorable i)) + ,(cond ((null seqs) + `(dotimes (j length (setq i length)) + (setf (aref result j) (funcall fun)))) + (t + `(block nil + (map nil + (lambda (,@seqs-names) + (when (= i length) (return)) + (setf (aref result i) + (funcall fun ,@seqs-names)) + (incf i)) + ,@seqs-names)))) + (when (array-has-fill-pointer-p result) + (setf (fill-pointer result) i)) + result)))) + (deftransform elt ((s i) ((simple-array * (*)) *) * :when :both) '(aref s i)) -- GitLab