diff --git a/lang/sbcl/Makefile b/lang/sbcl/Makefile index 2ee01f02b9bf..beaa1ee7940e 100644 --- a/lang/sbcl/Makefile +++ b/lang/sbcl/Makefile @@ -1,164 +1,165 @@ # All *-sbcl ports and any other port with SBCL fasl files must get a # PORTREVISION bump when lang/sbcl is updated. The compiled fasl files are # pinned to exact versions of everything used to build them. PORTNAME= sbcl DISTVERSION= 2.1.7 DISTVERSIONSUFFIX= -source +PORTREVISION= 1 PORTEPOCH= 1 CATEGORIES= lang lisp MASTER_SITES= SF/${PORTNAME}/${PORTNAME}/${DISTVERSION} \ SF/${PORTNAME}/${PORTNAME}/${BOOTVERSION}:binaries DISTFILES= ${DISTNAME}${EXTRACT_SUFX} MAINTAINER= krion@FreeBSD.org COMMENT= Common Lisp development system derived from the CMU CL system LICENSE= BSD2CLAUSE PD LICENSE_COMB= dual LICENSE_FILE= ${WRKSRC}/COPYING ONLY_FOR_ARCHS= amd64 i386 LIB_DEPENDS= libgmp.so:math/gmp \ libmpfr.so:math/mpfr RUN_DEPENDS= cl-asdf>=0:devel/cl-asdf USES= gmake makeinfo tar:bzip2 SUB_FILES= pkg-message sbclrc WRKSRC= ${WRKDIR}/${PORTNAME}-${PORTVERSION} PORTDOCS= * # All options explained into file: ${WRKSRC}/base-target-features.lisp-expr OPTIONS_DEFINE= DOCS QSHOW RENAME SAFEPOINT THREADS UNICODE XREF ZLIB OPTIONS_DEFAULT= RENAME SBCL THREADS UNICODE OPTIONS_SINGLE= BOOTSTRAP OPTIONS_SINGLE_BOOTSTRAP= ABCL CCL CMUCL SBCL OPTIONS_EXCLUDE= ABCL CMUCL ABCL_DESC= Armed Bear Common Lisp BOOTSTRAP_DESC= Supported languages of the build host CCL_DESC= Clozure Common Lisp CMUCL_DESC= Carnegie Mellon University Common Lisp QSHOW_DESC= C runtime with low-level debugging output RENAME_DESC= Rename suffix .core to _core SAFEPOINT_DESC= Using safepoints instead of signals SBCL_DESC= Steel Bank Common Lisp XREF_DESC= XREF data for SBCL internals ABCL_BUILD_DEPENDS= abcl:lang/abcl ABCL_VARS= XC_HOST="abcl" CCL_BUILD_DEPENDS= ccl:lang/ccl CCL_VARS= XC_HOST="ccl --no-init --batch --quiet" CMUCL_BUILD_DEPENDS= lisp:lang/cmucl CMUCL_VARS= XC_HOST="lisp -nositeinit -noinit -batch -quiet" DOCS_VARS= INFO="asdf sbcl" QSHOW_VARS= MAKE_SH_ARGS+="--with-sb-qshow" QSHOW_VARS_OFF= MAKE_SH_ARGS+="--without-sb-qshow" RENAME_PLIST_SUB= CORE_SUFFIX="_core" RENAME_PLIST_SUB_OFF= CORE_SUFFIX=".core" SAFEPOINT_IMPLIES= THREADS SAFEPOINT_VARS= MAKE_SH_ARGS+="--with-sb-safepoint --with-sb-thruption --with-sb-wtimer" SAFEPOINT_VARS_OFF= MAKE_SH_ARGS+="--without-sb-safepoint --without-sb-thruption --without-sb-wtimer" SBCL_DISTFILES= ${PORTNAME}-${SBCL_BOOT_LIST:M${ARCHOS_PATTERN}}-binary${EXTRACT_SUFX}:binaries SBCL_VARS= XC_HOST="${BOOT_WRKSRC}/src/runtime/sbcl --core ${BOOT_WRKSRC}/output/${CORE} --noinform --disable-debugger --no-sysinit --no-userinit" THREADS_VARS= MAKE_SH_ARGS+="--with-sb-thread" THREADS_VARS_OFF= MAKE_SH_ARGS+="--without-sb-thread" UNICODE_VARS= MAKE_SH_ARGS+="--with-sb-unicode" UNICODE_VARS_OFF= MAKE_SH_ARGS+="--without-sb-unicode" XREF_VARS= MAKE_SH_ARGS+="--with-sb-xref-for-internals" XREF_VARS_OFF= MAKE_SH_ARGS+="--without-sb-xref-for-internals" ZLIB_VARS= MAKE_SH_ARGS+="--with-sb-core-compression" ZLIB_VARS_OFF= MAKE_SH_ARGS+="--without-sb-core-compression" BOOTVERSION= 1.2.7 CONMODULES= asdf sb-aclrepl sb-bsd-sockets sb-cltl2 sb-concurrency sb-cover \ sb-executable sb-gmp sb-grovel sb-introspect sb-md5 sb-mpfr \ sb-posix sb-queue sb-rotate-byte sb-rt sb-simple-streams \ sb-sprof MAKE_SH_ARGS?= --prefix="${PREFIX}" --xc-host="${XC_HOST}" # You can use the DYNAMIC_SPACE_SIZE knob to change the size of SBCL dynamically-allocated memory. # Default for arch: i386 = 512Mb, amd64 = 1Gb. .if defined(DYNAMIC_SPACE_SIZE) MAKE_SH_ARGS+= --dynamic-space-size=${DYNAMIC_SPACE_SIZE} .endif SBCL_BOOT_LIST= ${BOOTVERSION}-x86-64-freebsd ${BOOTVERSION}-x86-freebsd \ ${BOOTVERSION}-x86-64-dragonfly .include ARCHOS_PATTERN= *-${ARCH:S/amd64/x86-64/:S/i386/x86/}-${OPSYS:tl}* BOOT_WRKSRC= ${WRKDIR}/${PORTNAME}-${SBCL_BOOT_LIST:M${ARCHOS_PATTERN}} # for port maintenance, invoke "make makesum PLUS_BOOTSTRAPS=1" .if defined (PLUS_BOOTSTRAPS) . for B in ${SBCL_BOOT_LIST} . if ! ${DISTFILES:Msbcl-${B}-*} DISTFILES:= ${DISTFILES} \ ${PORTNAME}-${B}-binary${EXTRACT_SUFX}:binaries . endif . endfor .endif # Old FreeBSD bootstraps feature the older core name for SBCL bootstrap .if ${OPSYS} == FreeBSD CORE= sbcl.core .else CORE= sbcl_core .endif post-patch: @${REINPLACE_CMD} -e 's|/etc|${PREFIX}/etc|' \ ${WRKSRC}/src/code/toplevel.lisp \ ${WRKSRC}/doc/${PORTNAME}.1 \ ${WRKSRC}/doc/manual/start-stop.texinfo post-patch-RENAME-on: ${GREP} -Frl '.core' ${WRKSRC} | ${XARGS} ${REINPLACE_CMD} -e 's|\.core|_core|g' do-build: (cd ${WRKSRC} && ${SH} make.sh ${MAKE_SH_ARGS}) post-build-DOCS-on: ${DO_MAKE_BUILD} -C ${WRKSRC}/doc/manual info html do-install: (cd ${WRKSRC} && ${SETENV} \ INSTALL_ROOT="${STAGEDIR}${PREFIX}" \ MAN_DIR="${STAGEDIR}${MANPREFIX}/man" \ INFO_DIR="${STAGEDIR}${PREFIX}/${INFO_PATH}" \ DOC_DIR="${STAGEDIR}${DOCSDIR}" \ ${SH} install.sh) .for M in ${CONMODULES} ${MKDIR} ${STAGEDIR}${PREFIX}/lib/${PORTNAME}/${M} ${INSTALL_DATA} ${WRKSRC}/contrib/${M}/*.[la]* \ ${STAGEDIR}${PREFIX}/lib/${PORTNAME}/${M}/ .endfor ${INSTALL_DATA} ${WRKDIR}/sbclrc ${STAGEDIR}${PREFIX}/etc/sbclrc.sample post-install: ${STRIP_CMD} ${STAGEDIR}${PREFIX}/bin/${PORTNAME} post-install-DOCS-on: ${RM} ${STAGEDIR}${PREFIX}/${INFO_PATH}/dir # don't requered with INFO= ${RM} -r ${STAGEDIR}${DOCSDIR}/html # empty directory created by install.sh check regression-test test: build (cd ${WRKSRC}/tests && ${SH} run-tests.sh) .include 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"))))