diff options
author | Kirill Ponomarev <krion@FreeBSD.org> | 2021-08-06 20:50:43 +0000 |
---|---|---|
committer | Kirill Ponomarev <krion@FreeBSD.org> | 2021-08-06 20:52:12 +0000 |
commit | 969aedb5b1a5200865ef81bdf5fccb998a810f20 (patch) | |
tree | 851f64e52bab9ad92a3ac8541c0974b172f198ea /lang/sbcl | |
parent | f7f39a72b191ea1a7625866090e7ec14a5023093 (diff) | |
download | ports-969aedb5b1a5200865ef81bdf5fccb998a810f20.tar.gz ports-969aedb5b1a5200865ef81bdf5fccb998a810f20.zip |
Diffstat (limited to 'lang/sbcl')
-rw-r--r-- | lang/sbcl/Makefile | 1 | ||||
-rw-r--r-- | lang/sbcl/files/patch_seq.lisp | 143 | ||||
-rw-r--r-- | lang/sbcl/files/patch_tests_seq.pure.lisp | 21 |
3 files changed, 165 insertions, 0 deletions
diff --git a/lang/sbcl/Makefile b/lang/sbcl/Makefile index 2ee01f02b9bf..beaa1ee7940e 100644 --- a/lang/sbcl/Makefile +++ b/lang/sbcl/Makefile @@ -5,6 +5,7 @@ PORTNAME= sbcl DISTVERSION= 2.1.7 DISTVERSIONSUFFIX= -source +PORTREVISION= 1 PORTEPOCH= 1 CATEGORIES= lang lisp MASTER_SITES= SF/${PORTNAME}/${PORTNAME}/${DISTVERSION} \ diff --git a/lang/sbcl/files/patch_seq.lisp b/lang/sbcl/files/patch_seq.lisp new file mode 100644 index 000000000000..a8b45f2311d0 --- /dev/null +++ b/lang/sbcl/files/patch_seq.lisp @@ -0,0 +1,143 @@ +--- work/sbcl-2.1.7/src/code/seq.lisp 2021-07-30 10:42:09.000000000 +0200 ++++ /home/krion/sbcl/src/code/seq.lisp 2021-08-06 22:34:09.026438000 +0200 +@@ -722,52 +722,53 @@ + collect `(eq ,tag ,(sb-vm:saetp-typecode saetp))))) + + ;;;; REPLACE +-(defun vector-replace (vector1 vector2 start1 start2 end1 diff) +- (declare ((or (eql -1) index) start1 start2 end1) +- (optimize (sb-c::insert-array-bounds-checks 0)) +- ((integer -1 1) diff)) +- (let ((tag1 (%other-pointer-widetag vector1)) +- (tag2 (%other-pointer-widetag vector2))) +- (macrolet ((copy (&body body) +- `(do ((index1 start1 (+ index1 diff)) +- (index2 start2 (+ index2 diff))) +- ((= index1 end1)) +- (declare (fixnum index1 index2)) +- ,@body))) +- (when (= tag1 tag2) +- (when (= tag1 sb-vm:simple-vector-widetag) +- (copy (setf (svref vector1 index1) (svref vector2 index2))) +- (return-from vector-replace vector1)) +- (let ((copier (sb-vm::blt-copier-for-widetag tag1))) +- (when (functionp copier) +- ;; VECTOR1 = destination, VECTOR2 = source, but copier wants FROM, TO +- (funcall copier vector2 start2 vector1 start1 (- end1 start1)) +- (return-from vector-replace vector1)))) +- (let ((getter (the function (svref %%data-vector-reffers%% tag2))) +- (setter (the function (svref %%data-vector-setters%% tag1)))) +- (copy (funcall setter vector1 index1 (funcall getter vector2 index2)))))) +- vector1) + + ;;; If we are copying around in the same vector, be careful not to copy the + ;;; same elements over repeatedly. We do this by copying backwards. ++;;; Bounding indices were checked for validity by DEFINE-SEQUENCE-TRAVERSER. + (defmacro vector-replace-from-vector () +- `(let ((nelts (min (- target-end target-start) +- (- source-end source-start)))) +- (with-array-data ((data1 target-sequence) (start1 target-start) (end1)) +- (declare (ignore end1)) +- (let ((end1 (the fixnum (+ start1 nelts)))) +- (if (and (eq target-sequence source-sequence) +- (> target-start source-start)) +- (let ((end (the fixnum (1- end1)))) +- (vector-replace data1 data1 +- end +- (the fixnum (- end +- (- target-start source-start))) +- (1- start1) +- -1)) +- (with-array-data ((data2 source-sequence) (start2 source-start) (end2)) +- (declare (ignore end2)) +- (vector-replace data1 data2 start1 start2 end1 1))))) ++ `(locally ++ (declare (optimize (safety 0))) ++ (let ((nelts (min (- target-end target-start) ++ (- source-end source-start)))) ++ (when (plusp nelts) ++ (with-array-data ((data1 target-sequence) (start1 target-start) (end1)) ++ (progn end1) ++ (with-array-data ((data2 source-sequence) (start2 source-start) (end2)) ++ (progn end2) ++ (let ((tag1 (%other-pointer-widetag data1)) ++ (tag2 (%other-pointer-widetag data2))) ++ (block replace ++ (when (= tag1 tag2) ++ (when (= tag1 sb-vm:simple-vector-widetag) ; rely on the transform ++ (replace (truly-the simple-vector data1) ++ (truly-the simple-vector data2) ++ :start1 start1 :end1 (truly-the index (+ start1 nelts)) ++ :start2 start2 :end2 (truly-the index (+ start2 nelts))) ++ (return-from replace)) ++ (let ((copier (sb-vm::blt-copier-for-widetag tag1))) ++ (when (functionp copier) ++ ;; these copiers figure out which direction to step. ++ ;; arg order is FROM, TO which is the opposite of REPLACE. ++ (funcall copier data2 start2 data1 start1 nelts) ++ (return-from replace)))) ++ ;; General case is just like the code emitted by TRANSFORM-REPLACE ++ ;; but using the getter and setter. ++ (let ((getter (the function (svref %%data-vector-reffers%% tag2))) ++ (setter (the function (svref %%data-vector-setters%% tag1)))) ++ (cond ((and (eq data1 data2) (> start1 start2)) ++ (do ((i (the (or (eql -1) index) (+ start1 nelts -1)) (1- i)) ++ (j (the (or (eql -1) index) (+ start2 nelts -1)) (1- j))) ++ ((< i start1)) ++ (declare (index i j)) ++ (funcall setter data1 i (funcall getter data2 j)))) ++ (t ++ (do ((i start1 (1+ i)) ++ (j start2 (1+ j)) ++ (end (the index (+ start1 nelts)))) ++ ((>= i end)) ++ (declare (index i j)) ++ (funcall setter data1 i (funcall getter data2 j)))))))))))) + target-sequence)) + + (defmacro list-replace-from-list () +@@ -819,44 +820,6 @@ + target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) (car source-sequence)))) +- +-;;;; The support routines for REPLACE are used by compiler transforms, so we +-;;;; worry about dealing with END being supplied or defaulting to NIL +-;;;; at this level. +- +-(defun list-replace-from-list* (target-sequence source-sequence target-start +- target-end source-start source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (list-replace-from-list)) +- +-(defun list-replace-from-vector* (target-sequence source-sequence target-start +- target-end source-start source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (list-replace-from-vector)) +- +-(defun vector-replace-from-list* (target-sequence source-sequence target-start +- target-end source-start source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (vector-replace-from-list)) +- +-(defun vector-replace-from-vector* (target-sequence source-sequence +- target-start target-end source-start +- source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (vector-replace-from-vector)) +- +-#+sb-unicode +-(defun simple-character-string-replace-from-simple-character-string* +- (target-sequence source-sequence +- target-start target-end source-start source-end) +- (declare (type (simple-array character (*)) target-sequence source-sequence)) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (vector-replace-from-vector)) + + (define-sequence-traverser replace + (target-sequence1 source-sequence2 &rest args &key start1 end1 start2 end2) diff --git a/lang/sbcl/files/patch_tests_seq.pure.lisp b/lang/sbcl/files/patch_tests_seq.pure.lisp new file mode 100644 index 000000000000..059e6d57fa3e --- /dev/null +++ b/lang/sbcl/files/patch_tests_seq.pure.lisp @@ -0,0 +1,21 @@ +--- work/sbcl-2.1.7/tests/seq.pure.lisp 2021-07-30 10:42:10.000000000 +0200 ++++ /home/krion/sbcl/tests/seq.pure.lisp 2021-08-06 22:34:09.303934000 +0200 +@@ -584,3 +584,18 @@ + ;; Try all other numeric array types + (dolist (y arrays) + (assert (equalp x y))))))) ++ ++;; lp#1938598 ++(with-test (:name :vector-replace-self) ++ ;; example 1 ++ (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) ++ (declare (notinline replace)) ++ (vector-push-extend #\_ string) ++ ;; also test it indirectly ++ (replace string string :start1 1 :start2 0)) ++ ;; example 2 ++ (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) ++ (declare (notinline replace)) ++ (loop for char across "tset" do (vector-push-extend char string)) ++ (replace string string :start2 1 :start1 2) ++ (assert (string= string "tsse")))) |