cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

[Git][cmucl/cmucl][issue-240-subsetp-with-hash-table] 6 commits: Address #240: Speed up intersection by using a hashtable
by Raymond Toy (＠rtoy) 18 Aug '23

18 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: 55c01f44 by Raymond Toy at 2023-08-17T13:33:59+00:00 Address #240: Speed up intersection by using a hashtable - - - - - 14d847f0 by Raymond Toy at 2023-08-17T13:34:15+00:00 Merge branch 'issue-240-intersection-with-hash-table' into 'master' Address #240: Speed up intersection by using a hashtable Closes #240 See merge request cmucl/cmucl!160 - - - - - c9ce7574 by Raymond Toy at 2023-08-17T13:36:18+00:00 Address #240: Speed up union by using a hashtable - - - - - 5c7536f0 by Raymond Toy at 2023-08-17T13:36:44+00:00 Merge branch 'issue-240-union-with-hash-table' into 'master' Address #240: Speed up union by using a hashtable Closes #240 See merge request cmucl/cmucl!159 - - - - - 181508a9 by Raymond Toy at 2023-08-17T06:47:03-07:00 Remove old version of union Oops. Forgot to remove this in !159, so we do it now. - - - - - 611a0377 by Raymond Toy at 2023-08-17T15:27:54-07:00 Merge branch 'master' into issue-240-subsetp-with-hash-table - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -788,11 +788,18 @@ (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the union of list1 and list2." (declare (inline member)) - (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (let ((res list2)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) + (when (and testp notp) + (error (intl:gettext "Test and test-not both supplied."))) + (let ((res list2) + (hashtable (list-to-hashtable list2 key test test-not))) + (cond (hashtable + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (push item res)))) + ((null hashtable) + (dolist (item list1) + (unless (with-set-keys (member (apply-key key item) list2)) + (push item res))))) res)) ;;; Destination and source are setf-able and many-evaluable. Sets the source @@ -825,11 +832,20 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil)) - (dolist (elt list1) - (if (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) - res)) + (let ((hashtable + (list-to-hashtable list2 key test test-not))) + (cond (hashtable + (let ((res nil)) + (dolist (item list1) + (when (nth-value 1 (gethash (apply-key key item) hashtable)) + (push item res))) + res)) + ((null hashtable) + (let ((res nil)) + (dolist (elt list1) + (if (with-set-keys (member (apply-key key elt) list2)) + (push elt res))) + res))))) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) ===================================== tests/sets.lisp ===================================== @@ -89,3 +89,86 @@ :test-not 'eql))) + +(define-test union.hash-eql + (:tag :issues) + ;; For union to use hashtables by making the threshold + ;; small. + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '(2 2 1 3 4) + (union '(1 2 2 3) '(3 4))) + (assert-equal '(2 2 1 3 4 5 6 7 8) + (union '(1 2 2 3) '(3 4 5 6 7 8))) + (assert-equal '(2 2 1 3 4) + (union '(1 2 2 3) '(3 4) + :test #'eql)) + (assert-equal '(2 2 1 3 4 5 6 7 8) + (union '(1 2 2 3) '(3 4 5 6 7 8) + :test #'eql)))) + +(define-test union.hash-eq + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '(b b a c d e) + (union '(a b b c) '(c d e) :test 'eq)) + (assert-equal '(b b a c d e f g h) + (union '(a b b c) '(c d e f g h) :test 'eq)) + (assert-equal '(b b a c d e) + (union '(a b b c) '(c d e) :test #'eq)) + (assert-equal '(b b a c d e f g h) + (union '(a b b c) '(c d e f g h) :test #'eq)))) + +(define-test union.hash-equal + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '("b" "b" "a" "c" "d" "e") + (union '("a" "b" "b" "c") + '("c" "d" "e") + :test 'equal)) + (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h") + (union '("a" "b" "b" "c") + '("c" "d" "e" "f" "g" "h") + :test 'equal)) + (assert-equal '("b" "b" "a" "c" "d" "e") + (union '("a" "b" "b" "c") + '("c" "d" "e") + :test #'equal)) + (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h") + (union '("a" "b" "b" "c") + '("c" "d" "e" "f" "g" "h") + :test #'equal)))) + +(define-test union.hash-equalp + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '("b" "b" "a" "C" "d" "e") + (union '("a" "b" "b" "c") + '("C" "d" "e") + :test 'equalp)) + (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h") + (union '("a" "b" "b" "C") + '("c" "D" "e" "f" "g" "h") + :test 'equalp)) + (assert-equal '("b" "b" "a" "C" "d" "e") + (union '("a" "b" "b" "c") + '("C" "d" "e") + :test #'equalp)) + (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h") + (union '("a" "b" "b" "C") + '("c" "D" "e" "f" "g" "h") + :test #'equalp)))) + +;; Simple test that we handle a key correctly +(define-test union.hash-eql-with-key + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '((3 "b") (2 "b") (1 "a") (4 "c") (5 "d")) + (union '((1 "a") (2 "b") (3 "b")) + '((1 "a") (4 "c") (5 "d")) + :key #'first)))) + +(define-test union.test-and-test-not + (assert-error 'simple-error + (union '(1 2) + '(3 4) + :test 'eql + :test-not 'eql))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a4c90a8bfb0469e1ab17da… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a4c90a8bfb0469e1ab17da… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Remove old version of union
by Raymond Toy (＠rtoy) 17 Aug '23

17 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 181508a9 by Raymond Toy at 2023-08-17T06:47:03-07:00 Remove old version of union Oops. Forgot to remove this in !159, so we do it now. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -785,17 +785,6 @@ ;;; will apply the test to the elements from list1 and list2 in the correct ;;; order. ;;; -#+nil -(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) - "Returns the union of list1 and list2." - (declare (inline member)) - (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (let ((res list2)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) - res)) - (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the union of list1 and list2." (declare (inline member)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/181508a9edeaf570fd3f7a8… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/181508a9edeaf570fd3f7a8… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Speed up union by using a hashtable
by Raymond Toy (＠rtoy) 17 Aug '23

17 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: c9ce7574 by Raymond Toy at 2023-08-17T13:36:18+00:00 Address #240: Speed up union by using a hashtable - - - - - 5c7536f0 by Raymond Toy at 2023-08-17T13:36:44+00:00 Merge branch 'issue-240-union-with-hash-table' into 'master' Address #240: Speed up union by using a hashtable Closes #240 See merge request cmucl/cmucl!159 - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -785,6 +785,7 @@ ;;; will apply the test to the elements from list1 and list2 in the correct ;;; order. ;;; +#+nil (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the union of list1 and list2." (declare (inline member)) @@ -795,6 +796,23 @@ (push elt res))) res)) +(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + "Returns the union of list1 and list2." + (declare (inline member)) + (when (and testp notp) + (error (intl:gettext "Test and test-not both supplied."))) + (let ((res list2) + (hashtable (list-to-hashtable list2 key test test-not))) + (cond (hashtable + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (push item res)))) + ((null hashtable) + (dolist (item list1) + (unless (with-set-keys (member (apply-key key item) list2)) + (push item res))))) + res)) + ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; ===================================== tests/sets.lisp ===================================== @@ -89,3 +89,86 @@ :test-not 'eql))) + +(define-test union.hash-eql + (:tag :issues) + ;; For union to use hashtables by making the threshold + ;; small. + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '(2 2 1 3 4) + (union '(1 2 2 3) '(3 4))) + (assert-equal '(2 2 1 3 4 5 6 7 8) + (union '(1 2 2 3) '(3 4 5 6 7 8))) + (assert-equal '(2 2 1 3 4) + (union '(1 2 2 3) '(3 4) + :test #'eql)) + (assert-equal '(2 2 1 3 4 5 6 7 8) + (union '(1 2 2 3) '(3 4 5 6 7 8) + :test #'eql)))) + +(define-test union.hash-eq + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '(b b a c d e) + (union '(a b b c) '(c d e) :test 'eq)) + (assert-equal '(b b a c d e f g h) + (union '(a b b c) '(c d e f g h) :test 'eq)) + (assert-equal '(b b a c d e) + (union '(a b b c) '(c d e) :test #'eq)) + (assert-equal '(b b a c d e f g h) + (union '(a b b c) '(c d e f g h) :test #'eq)))) + +(define-test union.hash-equal + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '("b" "b" "a" "c" "d" "e") + (union '("a" "b" "b" "c") + '("c" "d" "e") + :test 'equal)) + (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h") + (union '("a" "b" "b" "c") + '("c" "d" "e" "f" "g" "h") + :test 'equal)) + (assert-equal '("b" "b" "a" "c" "d" "e") + (union '("a" "b" "b" "c") + '("c" "d" "e") + :test #'equal)) + (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h") + (union '("a" "b" "b" "c") + '("c" "d" "e" "f" "g" "h") + :test #'equal)))) + +(define-test union.hash-equalp + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '("b" "b" "a" "C" "d" "e") + (union '("a" "b" "b" "c") + '("C" "d" "e") + :test 'equalp)) + (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h") + (union '("a" "b" "b" "C") + '("c" "D" "e" "f" "g" "h") + :test 'equalp)) + (assert-equal '("b" "b" "a" "C" "d" "e") + (union '("a" "b" "b" "c") + '("C" "d" "e") + :test #'equalp)) + (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h") + (union '("a" "b" "b" "C") + '("c" "D" "e" "f" "g" "h") + :test #'equalp)))) + +;; Simple test that we handle a key correctly +(define-test union.hash-eql-with-key + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '((3 "b") (2 "b") (1 "a") (4 "c") (5 "d")) + (union '((1 "a") (2 "b") (3 "b")) + '((1 "a") (4 "c") (5 "d")) + :key #'first)))) + +(define-test union.test-and-test-not + (assert-error 'simple-error + (union '(1 2) + '(3 4) + :test 'eql + :test-not 'eql))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/14d847f0523f21a3d3db82… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/14d847f0523f21a3d3db82… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Speed up intersection by using a hashtable
by Raymond Toy (＠rtoy) 17 Aug '23

17 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 55c01f44 by Raymond Toy at 2023-08-17T13:33:59+00:00 Address #240: Speed up intersection by using a hashtable - - - - - 14d847f0 by Raymond Toy at 2023-08-17T13:34:15+00:00 Merge branch 'issue-240-intersection-with-hash-table' into 'master' Address #240: Speed up intersection by using a hashtable Closes #240 See merge request cmucl/cmucl!160 - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -825,11 +825,20 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil)) - (dolist (elt list1) - (if (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) - res)) + (let ((hashtable + (list-to-hashtable list2 key test test-not))) + (cond (hashtable + (let ((res nil)) + (dolist (item list1) + (when (nth-value 1 (gethash (apply-key key item) hashtable)) + (push item res))) + res)) + ((null hashtable) + (let ((res nil)) + (dolist (elt list1) + (if (with-set-keys (member (apply-key key elt) list2)) + (push elt res))) + res))))) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9d593e3aa3831a687e7d72… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9d593e3aa3831a687e7d72… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-subsetp-with-hash-table] 13 commits: Fix #244: Add c-call:signed-char
by Raymond Toy (＠rtoy) 16 Aug '23

16 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: f577eda6 by Raymond Toy at 2023-07-23T22:38:00+00:00 Fix #244: Add c-call:signed-char - - - - - 0411c386 by Raymond Toy at 2023-07-23T22:38:01+00:00 Merge branch 'issue-244-c-call-signed-char' into 'master' Fix #244: Add c-call:signed-char Closes #244 See merge request cmucl/cmucl!157 - - - - - 3e8b0a12 by Raymond Toy at 2023-07-26T13:43:15+00:00 Fix #245: Replace egrep with grep -E - - - - - 24152f4d by Raymond Toy at 2023-07-26T13:43:15+00:00 Merge branch 'issue-245-replace-egrep-with-grep' into 'master' Fix #245: Replace egrep with grep -E Closes #245 See merge request cmucl/cmucl!158 - - - - - 5b27393f by Carl Shapiro at 2023-07-30T21:15:48-07:00 Guard against a division by zero in test run reports - - - - - a7300f03 by Carl Shapiro at 2023-07-31T05:28:58+00:00 Merge branch 'zero-tests' into 'master' Guard against a division by zero when reporting test results See merge request cmucl/cmucl!161 - - - - - 33f11724 by Raymond Toy at 2023-08-12T07:34:55-07:00 Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis In files/math.lisp, the word "naive" is spelled using the character \Latin_Small_Letter_I_With_Diaeresis. However, when compiling locally with a UTF-8 encoding (which is the default), this is invalid. The letter needs to be encoded as 2 octets. I'm too lazy to figure out how to get emacs to insert the correct encoded character so I'm replacing it with a simple "i". This makes the file pure ASCII, so it should work fine with a UTF-8 encoding. - - - - - a8ced15b by Carl Shapiro at 2023-08-14T04:45:23+00:00 Address #196: Fix issues with mapping and nconc accumulation - - - - - 310e41eb by Carl Shapiro at 2023-08-14T04:45:41+00:00 Merge branch 'mapcan' into 'master' Address #196: Fix issues with mapping and nconc accumulation See merge request cmucl/cmucl!162 - - - - - 19a305de by Raymond Toy at 2023-08-16T14:28:11+00:00 Address #240: Speed up set-difference - - - - - 9d593e3a by Raymond Toy at 2023-08-16T14:28:55+00:00 Merge branch 'issue-240-set-diff-with-hash-table' into 'master' Address #240: Speed up set-difference Closes #240 See merge request cmucl/cmucl!153 - - - - - d22817cb by Raymond Toy at 2023-08-16T09:28:39-07:00 Merge branch 'master' into issue-240-subsetp-with-hash-table - - - - - a4c90a8b by Raymond Toy at 2023-08-16T12:52:55-07:00 Fix up bad merge and disable hashtable only for subsetp We mistakenly removed *allow-hashtable-for-set-functions* when merging with master. Put it all back. However, modify it so we only disable hashtables for subsetp because that's the only function (so far) that is used in TYPE-INIT where hashtables aren't available yet. - - - - - 9 changed files: - benchmarks/cl-bench/files/math.lisp - bin/clean-target.sh - bin/make-extra-dist.sh - src/code/c-call.lisp - src/code/list.lisp - src/compiler/seqtran.lisp - src/general-info/release-21f.md - + tests/list.lisp - tests/run-tests.lisp Changes: ===================================== benchmarks/cl-bench/files/math.lisp ===================================== @@ -1,6 +1,6 @@ ;;; math.lisp -- various numerical operations ;; -;; Time-stamp: <2004-01-05 emarsden> +;; Time-stamp: <2023-08-12 07:34:28 toy> ;; ;; some basic mathematical benchmarks @@ -56,7 +56,7 @@ ;; calculate the "level" of a point in the Mandebrot Set, which is the ;; number of iterations taken to escape to "infinity" (points that ;; don't escape are included in the Mandelbrot Set). This version is -;; intended to test performance when programming in naïve math-style. +;; intended to test performance when programming in naive math-style. (defun mset-level/complex (c) (declare (type complex c)) (loop :for z = #c(0 0) :then (+ (* z z) c) ===================================== bin/clean-target.sh ===================================== @@ -48,10 +48,10 @@ CORE='-o -name "*.core"' if [ -n "$KEEP" ]; then case $KEEP in - lib) GREP='egrep -v' + lib) GREP='grep -Ev' PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library' ;; core) CORE='' ;; - all) GREP='egrep -v' + all) GREP='grep -Ev' PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library|(asdf|defsystem)' CORE='' ;; esac ===================================== bin/make-extra-dist.sh ===================================== @@ -94,12 +94,12 @@ install ${GROUP} ${OWNER} -m 0755 $TARGET/motif/server/motifd \ # Install the contrib stuff. Create the directories and then copy the files. -for d in `(cd src; find contrib -type d -print | egrep -v "CVS|asdf|defsystem")` +for d in `(cd src; find contrib -type d -print | grep -E -v "CVS|asdf|defsystem")` do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d done -for f in `(cd src/contrib; find . -type f -print | egrep -v "CVS|asdf|defsystem|unix")` +for f in `(cd src/contrib; find . -type f -print | grep -E -v "CVS|asdf|defsystem|unix")` do FILE=`basename $f` DIR=`dirname $f` @@ -108,13 +108,13 @@ done # Install all the locale data. -for d in `(cd src/i18n/; find locale -type d -print | egrep -v CVS)` +for d in `(cd src/i18n/; find locale -type d -print | grep -E -v CVS)` do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d done # Install mo files. -for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` +for f in `(cd $TARGET/i18n; find locale -type f -print | grep -E -v 'CVS|~.*~|.*~')` do FILE=`basename $f` DIR=`dirname $f` @@ -122,7 +122,7 @@ do done # Install po files. (Do we really need to distribute the po files?) -#for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` +#for f in `(cd $TARGET/i18n; find locale -type f -print | grep -E -v 'CVS|~.*~|.*~')` #do # FILE=`basename $f` # DIR=`dirname $f` ===================================== src/code/c-call.lisp ===================================== @@ -19,7 +19,7 @@ (intl:textdomain "cmucl") -(export '(char short int long long-long unsigned-char unsigned-short unsigned-int +(export '(char short int long long-long signed-char unsigned-char unsigned-short unsigned-int unsigned-long unsigned-long-long float double c-string void)) @@ -30,6 +30,8 @@ (def-alien-type int (integer 32)) (def-alien-type long (integer #-alpha 32 #+alpha 64)) (def-alien-type long-long (integer 64)) +;; The same as c-call:char, for convenience with C signed-char. +(def-alien-type signed-char (integer 8)) (def-alien-type unsigned-char (unsigned 8)) (def-alien-type unsigned-short (unsigned 16)) ===================================== src/code/list.lisp ===================================== @@ -749,15 +749,9 @@ (defparameter *min-list-length-for-hashtable* 15) -(defparameter *allow-hashtable-for-set-functions* - nil) - ;; Convert a list to a hashtable. The hashtable does not handle ;; duplicated values in the list. Returns the hashtable. (defun list-to-hashtable (list key test test-not) - (unless *allow-hashtable-for-set-functions* - (return-from list-to-hashtable nil)) - ;; Don't currently support test-not when converting a list to a hashtable (unless test-not (let ((hash-test (let ((test-fn (if (and (symbolp test) @@ -979,17 +973,25 @@ (rplacd splicex (cdr x))) (setq splicex x))))) +(defvar *allow-hashtable-for-set-functions* t) + (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns T if every element in list1 is also in list2." (declare (inline member)) (when (and testp notp) (error "Test and test-not both supplied.")) - (let ((hashtable (list-to-hashtable list2 key test test-not))) + ;; SUBSETP is used early in TYPE-INIT where hash tables aren't + ;; available yet, so we can't use hashtables then. LISPINIT will + ;; take care to disable this for the kernel.core. SAVE will set + ;; this to true it's safe to use hash tables for SUBSETP. + (let ((hashtable (when *allow-hashtable-for-set-functions* + (list-to-hashtable list2 key test test-not)))) (cond (hashtable (dolist (item list1) (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (return-from subsetp nil)))) + (return-from subsetp nil))) + t) ((null hashtable) (dolist (item list1) (unless (with-set-keys (member (apply-key key item) list2)) @@ -1110,7 +1112,10 @@ (setf (car l) (cdar l))) (setq res (apply function (nreverse args))) (case accumulate - (:nconc (setq temp (last (nconc temp res)))) + (:nconc (when res + (let ((next-temp (last res))) + (rplacd temp res) + (setq temp next-temp)))) (:list (rplacd temp (list res)) (setq temp (cdr temp))))))) ===================================== src/compiler/seqtran.lisp ===================================== @@ -36,12 +36,18 @@ (ecase accumulate (:nconc (let ((temp (gensym)) - (map-result (gensym))) + (map-result (gensym)) + (res (gensym)) + (next-temp (gensym))) `(let ((,map-result (list nil))) (declare (dynamic-extent ,map-result)) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) + (let ((,res ,call)) + (when ,res + (let ((,next-temp (last ,res))) + (rplacd ,temp ,res) + (setq ,temp ,next-temp)))))))) (:list (let ((temp (gensym)) (map-result (gensym))) ===================================== src/general-info/release-21f.md ===================================== @@ -25,6 +25,7 @@ public domain. * ~~#154~~ piglatin translation does not work anymore * ~~#171~~ Readably print `(make-pathname :name :unspecfic)` * ~~#242~~ Fix bug in `alien-funcall` with `c-call:char` as result type + * ~~#244~~ Add `c-call:signed-char` * ~~#248~~ Print MOVS instruction with correct case * Other changes: * Improvements to the PCL implementation of CLOS: ===================================== tests/list.lisp ===================================== @@ -0,0 +1,193 @@ +(defpackage "LIST-TESTS" + (:use "COMMON-LISP" + "LISP-UNIT")) + +(in-package "LIST-TESTS") + +(define-test mapcan-empty-list-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan #'identity '()))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan #'identity '())))) + +(define-test mapcon-empty-list-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon #'identity '()))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon #'identity '())))) + +(define-test mapcan-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42))))) + +(define-test mapcon-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42))))) + +(define-test mapcan-accumulate-nil-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3))))) + +(define-test mapcon-accumulate-nil-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3))))) + +(define-test mapcan-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil))))) + (locally (declare (inline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil)))))) + +(define-test mapcon-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil))))) + (locally (declare (inline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil)))))) + +(define-test mapcan-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (inline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) + +(define-test mapcon-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) ===================================== tests/run-tests.lisp ===================================== @@ -110,9 +110,10 @@ (format t " ~5D tests failed~%" failed) (format t " ~5D tests with execution errors~%" execute-errors) (format t "~5,3f% of the tests passed~%" - (float (* 100 - (- 1 (/ (+ failed execute-errors) - (+ passed failed execute-errors)))))) + (let ((total (+ passed failed execute-errors))) + (if (zerop total) + 0.0 + (* 100.0 (- 1.0 (/ (- total passed) total)))))) ;; Print some info about any failed tests. Then exit. We want to ;; set the exit code so that any scripts runnning this can ;; determine if there were any test failures. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/27f80806c1b7101455e05c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/27f80806c1b7101455e05c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-union-with-hash-table] 6 commits: Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis
by Raymond Toy (＠rtoy) 16 Aug '23

16 Aug '23

Raymond Toy pushed to branch issue-240-union-with-hash-table at cmucl / cmucl Commits: 33f11724 by Raymond Toy at 2023-08-12T07:34:55-07:00 Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis In files/math.lisp, the word "naive" is spelled using the character \Latin_Small_Letter_I_With_Diaeresis. However, when compiling locally with a UTF-8 encoding (which is the default), this is invalid. The letter needs to be encoded as 2 octets. I'm too lazy to figure out how to get emacs to insert the correct encoded character so I'm replacing it with a simple "i". This makes the file pure ASCII, so it should work fine with a UTF-8 encoding. - - - - - a8ced15b by Carl Shapiro at 2023-08-14T04:45:23+00:00 Address #196: Fix issues with mapping and nconc accumulation - - - - - 310e41eb by Carl Shapiro at 2023-08-14T04:45:41+00:00 Merge branch 'mapcan' into 'master' Address #196: Fix issues with mapping and nconc accumulation See merge request cmucl/cmucl!162 - - - - - 19a305de by Raymond Toy at 2023-08-16T14:28:11+00:00 Address #240: Speed up set-difference - - - - - 9d593e3a by Raymond Toy at 2023-08-16T14:28:55+00:00 Merge branch 'issue-240-set-diff-with-hash-table' into 'master' Address #240: Speed up set-difference Closes #240 See merge request cmucl/cmucl!153 - - - - - 5819562a by Raymond Toy at 2023-08-16T07:43:30-07:00 Merge branch 'master' into issue-240-union-with-hash-table - - - - - 5 changed files: - benchmarks/cl-bench/files/math.lisp - src/code/list.lisp - src/compiler/seqtran.lisp - + tests/list.lisp - tests/sets.lisp Changes: ===================================== benchmarks/cl-bench/files/math.lisp ===================================== @@ -1,6 +1,6 @@ ;;; math.lisp -- various numerical operations ;; -;; Time-stamp: <2004-01-05 emarsden> +;; Time-stamp: <2023-08-12 07:34:28 toy> ;; ;; some basic mathematical benchmarks @@ -56,7 +56,7 @@ ;; calculate the "level" of a point in the Mandebrot Set, which is the ;; number of iterations taken to escape to "infinity" (points that ;; don't escape are included in the Mandelbrot Set). This version is -;; intended to test performance when programming in naïve math-style. +;; intended to test performance when programming in naive math-style. (defun mset-level/complex (c) (declare (type complex c)) (loop :for z = #c(0 0) :then (+ (* z z) c) ===================================== src/code/list.lisp ===================================== @@ -1113,7 +1113,10 @@ (setf (car l) (cdar l))) (setq res (apply function (nreverse args))) (case accumulate - (:nconc (setq temp (last (nconc temp res)))) + (:nconc (when res + (let ((next-temp (last res))) + (rplacd temp res) + (setq temp next-temp)))) (:list (rplacd temp (list res)) (setq temp (cdr temp))))))) ===================================== src/compiler/seqtran.lisp ===================================== @@ -36,12 +36,18 @@ (ecase accumulate (:nconc (let ((temp (gensym)) - (map-result (gensym))) + (map-result (gensym)) + (res (gensym)) + (next-temp (gensym))) `(let ((,map-result (list nil))) (declare (dynamic-extent ,map-result)) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) + (let ((,res ,call)) + (when ,res + (let ((,next-temp (last ,res))) + (rplacd ,temp ,res) + (setq ,temp ,next-temp)))))))) (:list (let ((temp (gensym)) (map-result (gensym))) ===================================== tests/list.lisp ===================================== @@ -0,0 +1,193 @@ +(defpackage "LIST-TESTS" + (:use "COMMON-LISP" + "LISP-UNIT")) + +(in-package "LIST-TESTS") + +(define-test mapcan-empty-list-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan #'identity '()))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan #'identity '())))) + +(define-test mapcon-empty-list-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon #'identity '()))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon #'identity '())))) + +(define-test mapcan-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42))))) + +(define-test mapcon-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42))))) + +(define-test mapcan-accumulate-nil-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3))))) + +(define-test mapcon-accumulate-nil-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3))))) + +(define-test mapcan-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil))))) + (locally (declare (inline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil)))))) + +(define-test mapcon-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil))))) + (locally (declare (inline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil)))))) + +(define-test mapcan-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (inline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) + +(define-test mapcon-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) ===================================== tests/sets.lisp ===================================== @@ -89,6 +89,7 @@ :test-not 'eql))) + (define-test union.hash-eql (:tag :issues) ;; For union to use hashtables by making the threshold @@ -171,5 +172,3 @@ '(3 4) :test 'eql :test-not 'eql))) - - View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ec9b0dcd0041e301bdefc6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ec9b0dcd0041e301bdefc6… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-intersection-with-hash-table] 6 commits: Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis
by Raymond Toy (＠rtoy) 16 Aug '23

16 Aug '23

Raymond Toy pushed to branch issue-240-intersection-with-hash-table at cmucl / cmucl Commits: 33f11724 by Raymond Toy at 2023-08-12T07:34:55-07:00 Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis In files/math.lisp, the word "naive" is spelled using the character \Latin_Small_Letter_I_With_Diaeresis. However, when compiling locally with a UTF-8 encoding (which is the default), this is invalid. The letter needs to be encoded as 2 octets. I'm too lazy to figure out how to get emacs to insert the correct encoded character so I'm replacing it with a simple "i". This makes the file pure ASCII, so it should work fine with a UTF-8 encoding. - - - - - a8ced15b by Carl Shapiro at 2023-08-14T04:45:23+00:00 Address #196: Fix issues with mapping and nconc accumulation - - - - - 310e41eb by Carl Shapiro at 2023-08-14T04:45:41+00:00 Merge branch 'mapcan' into 'master' Address #196: Fix issues with mapping and nconc accumulation See merge request cmucl/cmucl!162 - - - - - 19a305de by Raymond Toy at 2023-08-16T14:28:11+00:00 Address #240: Speed up set-difference - - - - - 9d593e3a by Raymond Toy at 2023-08-16T14:28:55+00:00 Merge branch 'issue-240-set-diff-with-hash-table' into 'master' Address #240: Speed up set-difference Closes #240 See merge request cmucl/cmucl!153 - - - - - 901b9fab by Raymond Toy at 2023-08-16T07:41:55-07:00 Merge branch 'master' into issue-240-intersection-with-hash-table - - - - - 4 changed files: - benchmarks/cl-bench/files/math.lisp - src/code/list.lisp - src/compiler/seqtran.lisp - + tests/list.lisp Changes: ===================================== benchmarks/cl-bench/files/math.lisp ===================================== @@ -1,6 +1,6 @@ ;;; math.lisp -- various numerical operations ;; -;; Time-stamp: <2004-01-05 emarsden> +;; Time-stamp: <2023-08-12 07:34:28 toy> ;; ;; some basic mathematical benchmarks @@ -56,7 +56,7 @@ ;; calculate the "level" of a point in the Mandebrot Set, which is the ;; number of iterations taken to escape to "infinity" (points that ;; don't escape are included in the Mandelbrot Set). This version is -;; intended to test performance when programming in naïve math-style. +;; intended to test performance when programming in naive math-style. (defun mset-level/complex (c) (declare (type complex c)) (loop :for z = #c(0 0) :then (+ (* z z) c) ===================================== src/code/list.lisp ===================================== @@ -1104,7 +1104,10 @@ (setf (car l) (cdar l))) (setq res (apply function (nreverse args))) (case accumulate - (:nconc (setq temp (last (nconc temp res)))) + (:nconc (when res + (let ((next-temp (last res))) + (rplacd temp res) + (setq temp next-temp)))) (:list (rplacd temp (list res)) (setq temp (cdr temp))))))) ===================================== src/compiler/seqtran.lisp ===================================== @@ -36,12 +36,18 @@ (ecase accumulate (:nconc (let ((temp (gensym)) - (map-result (gensym))) + (map-result (gensym)) + (res (gensym)) + (next-temp (gensym))) `(let ((,map-result (list nil))) (declare (dynamic-extent ,map-result)) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) + (let ((,res ,call)) + (when ,res + (let ((,next-temp (last ,res))) + (rplacd ,temp ,res) + (setq ,temp ,next-temp)))))))) (:list (let ((temp (gensym)) (map-result (gensym))) ===================================== tests/list.lisp ===================================== @@ -0,0 +1,193 @@ +(defpackage "LIST-TESTS" + (:use "COMMON-LISP" + "LISP-UNIT")) + +(in-package "LIST-TESTS") + +(define-test mapcan-empty-list-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan #'identity '()))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan #'identity '())))) + +(define-test mapcon-empty-list-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon #'identity '()))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon #'identity '())))) + +(define-test mapcan-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42))))) + +(define-test mapcon-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42))))) + +(define-test mapcan-accumulate-nil-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3))))) + +(define-test mapcon-accumulate-nil-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3))))) + +(define-test mapcan-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil))))) + (locally (declare (inline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil)))))) + +(define-test mapcon-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil))))) + (locally (declare (inline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil)))))) + +(define-test mapcan-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (inline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) + +(define-test mapcon-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/badda4b87292db2558110e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/badda4b87292db2558110e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Speed up set-difference
by Raymond Toy (＠rtoy) 16 Aug '23

16 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 19a305de by Raymond Toy at 2023-08-16T14:28:11+00:00 Address #240: Speed up set-difference - - - - - 9d593e3a by Raymond Toy at 2023-08-16T14:28:55+00:00 Merge branch 'issue-240-set-diff-with-hash-table' into 'master' Address #240: Speed up set-difference Closes #240 See merge request cmucl/cmucl!153 - - - - - 2 changed files: - src/code/list.lisp - + tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -45,7 +45,7 @@ tree-equal list-length nth %setnth nthcdr last make-list append copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff member member-if member-if-not tailp adjoin union - nunion intersection nintersection set-difference nset-difference + nunion intersection nintersection nset-difference set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) @@ -744,6 +744,39 @@ list (cons item list))) +;; The minimum length of a list before we can use a hashtable. This +;; was determined experimentally. +(defparameter *min-list-length-for-hashtable* + 15) + +;; Convert a list to a hashtable. The hashtable does not handle +;; duplicated values in the list. Returns the hashtable. +(defun list-to-hashtable (list key test test-not) + ;; Don't currently support test-not when converting a list to a hashtable + (unless test-not + (let ((hash-test (let ((test-fn (if (and (symbolp test) + (fboundp test)) + (fdefinition test) + test))) + (cond ((eql test-fn #'eq) 'eq) + ((eql test-fn #'eql) 'eql) + ((eql test-fn #'equal) 'equal) + ((eql test-fn #'equalp) 'equalp))))) + (unless hash-test + (return-from list-to-hashtable nil)) + ;; If the list is too short, the hashtable makes things + ;; slower. We also need to balance memory usage. + (let ((len 0)) + ;; Compute list length ourselves. + (dolist (item list) + (declare (ignore item)) + (incf len)) + (when (< len *min-list-length-for-hashtable*) + (return-from list-to-hashtable nil)) + (let ((hashtable (make-hash-table :test hash-test :size len))) + (dolist (item list) + (setf (gethash (apply-key key item) hashtable) item)) + hashtable))))) ;;; UNION -- Public. ;;; @@ -812,20 +845,32 @@ (setq list1 (Cdr list1)))) res)) -(defun set-difference (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) +(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (if (null list2) - list1 - (let ((res nil)) - (dolist (elt list1) - (if (not (with-set-keys (member (apply-key key elt) list2))) - (push elt res))) - res))) - + ;; Quick exit + (when (null list2) + (return-from set-difference list1)) + + (let ((hashtable + (list-to-hashtable list2 key test test-not))) + (cond (hashtable + ;; list2 was placed in hash table. + (let ((res nil)) + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (push item res))) + res)) + ((null hashtable) + ;; Default implementation because we didn't create the hash + ;; table. + (let ((res nil)) + (dolist (item list1) + (if (not (with-set-keys (member (apply-key key item) list2))) + (push item res))) + res))))) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) ===================================== tests/sets.lisp ===================================== @@ -0,0 +1,91 @@ +;; Tests for sets + +(defpackage :sets-tests + (:use :cl :lisp-unit)) + +(in-package "SETS-TESTS") + +(define-test set-diff.hash-eql + (:tag :issues) + ;; For set-difference to use hashtables by making the threshold + ;; small. + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '(2 2 1) + (set-difference '(1 2 2 3) '(3 4))) + (assert-equal '(2 2 1) + (set-difference '(1 2 2 3) '(3 4 5 6 7 8))) + (assert-equal '(2 2 1) + (set-difference '(1 2 2 3) '(3 4) + :test #'eql)) + (assert-equal '(2 2 1) + (set-difference '(1 2 2 3) '(3 4 5 6 7 8) + :test #'eql)))) + +(define-test set-diff.hash-eq + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '(b b a) + (set-difference '(a b b c) '(c d e) :test 'eq)) + (assert-equal '(b b a) + (set-difference '(a b b c) '(c d e f g h) :test 'eq)) + (assert-equal '(b b a) + (set-difference '(a b b c) '(c d e) :test #'eq)) + (assert-equal '(b b a) + (set-difference '(a b b c) '(c d e f g h) :test #'eq)))) + +(define-test set-diff.hash-equal + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "c") + '("c" "d" "e") + :test 'equal)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "c") + '("c" "d" "e" "f" "g" "h") + :test 'equal)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "c") + '("c" "d" "e") + :test #'equal)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "c") + '("c" "d" "e" "f" "g" "h") + :test #'equal)))) + +(define-test set-diff.hash-equalp + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "c") + '("C" "d" "e") + :test 'equalp)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "C") + '("c" "D" "e" "f" "g" "h") + :test 'equalp)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "c") + '("C" "d" "e") + :test #'equalp)) + (assert-equal '("b" "b" "a") + (set-difference '("a" "b" "b" "C") + '("c" "D" "e" "f" "g" "h") + :test #'equalp)))) + +;; Simple test that we handle a key correctly +(define-test set-diff.hash-eql-with-key + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '((3 "b") (2 "b")) + (set-difference '((1 "a") (2 "b") (3 "b")) + '((1 "a") (4 "c") (5 "d")) + :key #'first)))) + +(define-test set-diff.test-and-test-not + (assert-error 'simple-error + (set-difference '(1 2) + '(3 4) + :test 'eql + :test-not 'eql))) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/310e41eb1e70422bb63786… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/310e41eb1e70422bb63786… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #196: Fix issues with mapping and nconc accumulation
by Carl Shapiro (＠cshapiro) 14 Aug '23

14 Aug '23

Carl Shapiro pushed to branch master at cmucl / cmucl Commits: a8ced15b by Carl Shapiro at 2023-08-14T04:45:23+00:00 Address #196: Fix issues with mapping and nconc accumulation - - - - - 310e41eb by Carl Shapiro at 2023-08-14T04:45:41+00:00 Merge branch 'mapcan' into 'master' Address #196: Fix issues with mapping and nconc accumulation See merge request cmucl/cmucl!162 - - - - - 3 changed files: - src/code/list.lisp - src/compiler/seqtran.lisp - + tests/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -1050,7 +1050,10 @@ (setf (car l) (cdar l))) (setq res (apply function (nreverse args))) (case accumulate - (:nconc (setq temp (last (nconc temp res)))) + (:nconc (when res + (let ((next-temp (last res))) + (rplacd temp res) + (setq temp next-temp)))) (:list (rplacd temp (list res)) (setq temp (cdr temp))))))) ===================================== src/compiler/seqtran.lisp ===================================== @@ -36,12 +36,18 @@ (ecase accumulate (:nconc (let ((temp (gensym)) - (map-result (gensym))) + (map-result (gensym)) + (res (gensym)) + (next-temp (gensym))) `(let ((,map-result (list nil))) (declare (dynamic-extent ,map-result)) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) + (let ((,res ,call)) + (when ,res + (let ((,next-temp (last ,res))) + (rplacd ,temp ,res) + (setq ,temp ,next-temp)))))))) (:list (let ((temp (gensym)) (map-result (gensym))) ===================================== tests/list.lisp ===================================== @@ -0,0 +1,193 @@ +(defpackage "LIST-TESTS" + (:use "COMMON-LISP" + "LISP-UNIT")) + +(in-package "LIST-TESTS") + +(define-test mapcan-empty-list-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan #'identity '()))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan #'identity '())))) + +(define-test mapcon-empty-list-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon #'identity '()))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon #'identity '())))) + +(define-test mapcan-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42))))) + +(define-test mapcon-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42))))) + +(define-test mapcan-accumulate-nil-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3))))) + +(define-test mapcon-accumulate-nil-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3))))) + +(define-test mapcan-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil))))) + (locally (declare (inline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil)))))) + +(define-test mapcon-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil))))) + (locally (declare (inline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil)))))) + +(define-test mapcan-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (inline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) + +(define-test mapcon-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/33f117246e2a9315b33bc0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/33f117246e2a9315b33bc0… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-249-replace-lea-in-arith] Remove commented out code that used lea
by Raymond Toy (＠rtoy) 13 Aug '23

13 Aug '23

Raymond Toy pushed to branch issue-249-replace-lea-in-arith at cmucl / cmucl Commits: 4367609e by Raymond Toy at 2023-08-12T18:56:55-07:00 Remove commented out code that used lea - - - - - 1 changed file: - src/compiler/x86/arith.lisp Changes: ===================================== src/compiler/x86/arith.lisp ===================================== @@ -222,13 +222,8 @@ (:result-types tagged-num) (:note _N"inline fixnum arithmetic") (:generator 2 - (cond #+nil - ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg) - (not (location= x r))) - (inst lea r (make-ea :dword :base x :index y :scale 1))) - (t - (move r x) - (inst add r y))))) + (move r x) + (inst add r y))) (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) (:translate +) @@ -240,12 +235,8 @@ (:result-types tagged-num) (:note _N"inline fixnum arithmetic") (:generator 1 - (cond #+nil - ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))) - (inst lea r (make-ea :dword :base x :disp (fixnumize y)))) - (t - (move r x) - (inst add r (fixnumize y)))))) + (move r x) + (inst add r (fixnumize y)))) (define-vop (fast-+/signed=>signed fast-safe-arith-op) (:translate +) @@ -263,13 +254,8 @@ (:result-types signed-num) (:note _N"inline (signed-byte 32) arithmetic") (:generator 5 - (cond #+nil - ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg) - (not (location= x r))) - (inst lea r (make-ea :dword :base x :index y :scale 1))) - (t - (move r x) - (inst add r y))))) + (move r x) + (inst add r y))) (define-vop (fast-+-c/signed=>signed fast-safe-arith-op) (:translate +) @@ -281,15 +267,10 @@ (:result-types signed-num) (:note _N"inline (signed-byte 32) arithmetic") (:generator 4 - (cond #+nil - ((and (sc-is x signed-reg) (sc-is r signed-reg) - (not (location= x r))) - (inst lea r (make-ea :dword :base x :disp y))) - (t - (move r x) - (if (= y 1) - (inst inc r) - (inst add r y)))))) + (move r x) + (if (= y 1) + (inst inc r) + (inst add r y)))) (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op) (:translate +) @@ -308,13 +289,8 @@ (:result-types unsigned-num) (:note _N"inline (unsigned-byte 32) arithmetic") (:generator 5 - (cond #+nil - ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg) - (sc-is r unsigned-reg) (not (location= x r))) - (inst lea r (make-ea :dword :base x :index y :scale 1))) - (t - (move r x) - (inst add r y))))) + (move r x) + (inst add r y))) (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op) (:translate +) @@ -326,17 +302,10 @@ (:result-types unsigned-num) (:note _N"inline (unsigned-byte 32) arithmetic") (:generator 4 - (cond #+nil - ((and (sc-is x unsigned-reg) - (sc-is r unsigned-reg) - (not (location= x r)) - (valid-displacement-p y)) - (inst lea r (make-ea :dword :base x :disp y))) - (t - (move r x) - (if (= y 1) - (inst inc r) - (inst add r y)))))) + (move r x) + (if (= y 1) + (inst inc r) + (inst add r y)))) ;;;; Special logand cases: (logand signed unsigned) => unsigned @@ -647,28 +616,18 @@ (:result-types tagged-num) (:note _N"inline ASH") (:generator 2 - (cond #+nil - ((and (= amount 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - #+nil - ((and (= amount 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - #+nil - ((and (= amount 3) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 8))) + (move result number) + (cond ((plusp amount) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result amount)) (t - (move result number) - (cond ((plusp amount) - ;; We don't have to worry about overflow because of the - ;; result type restriction. - (inst shl result amount)) - (t - ;; If the amount is greater than 31, only shift by 31. We - ;; have to do this because the shift instructions only look - ;; at the low five bits of the result. - (inst sar result (min 31 (- amount))) - ;; Fixnum correction. - (inst and result #xfffffffc))))))) + ;; If the amount is greater than 31, only shift by 31. We + ;; have to do this because the shift instructions only look + ;; at the low five bits of the result. + (inst sar result (min 31 (- amount))) + ;; Fixnum correction. + (inst and result #xfffffffc))))) (define-vop (fast-ash-left/fixnum=>fixnum) (:translate ash) @@ -708,25 +667,15 @@ (:result-types unsigned-num) (:note _N"inline ASH") (:generator 3 - (cond #+nil - ((and (= amount 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - #+nil - ((and (= amount 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - #+nil - ((and (= amount 3) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 8))) + (move result number) + (cond ((plusp amount) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result amount)) + ((< amount -31) + (inst mov result 0)) (t - (move result number) - (cond ((plusp amount) - ;; We don't have to worry about overflow because of the - ;; result type restriction. - (inst shl result amount)) - ((< amount -31) - (inst mov result 0)) - (t - (inst shr result (- amount)))))))) + (inst shr result (- amount)))))) (define-vop (fast-ash-c/signed=>signed) (:translate ash) @@ -744,26 +693,16 @@ (:result-types signed-num) (:note _N"inline ASH") (:generator 3 - (cond #+nil - ((and (= amount 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - #+nil - ((and (= amount 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - #+nil - ((and (= amount 3) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 8))) + (move result number) + (cond ((plusp amount) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result amount)) (t - (move result number) - (cond ((plusp amount) - ;; We don't have to worry about overflow because of the - ;; result type restriction. - (inst shl result amount)) - (t - ;; If the amount is greater than 31, only shift by 31. We - ;; have to do this because the shift instructions only look - ;; at the low five bits of the result. - (inst sar result (min 31 (- amount))))))))) + ;; If the amount is greater than 31, only shift by 31. We + ;; have to do this because the shift instructions only look + ;; at the low five bits of the result. + (inst sar result (min 31 (- amount))))))) (define-vop (fast-ash-c/fixnum=>signed) (:translate ash) @@ -782,26 +721,16 @@ (:note "inline ASH") (:generator 1 (let ((shift (- amount vm:fixnum-tag-bits))) - (cond #+nil - ((and (= shift 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - #+nil - ((and (= shift 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - #+nil - ((and (= shift 3) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 8))) + (move result number) + (cond ((plusp shift) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result shift)) (t - (move result number) - (cond ((plusp shift) - ;; We don't have to worry about overflow because of the - ;; result type restriction. - (inst shl result shift)) - (t - ;; If the shift is greater than 31, only shift by 31. We - ;; have to do this because the shift instructions only look - ;; at the low five bits of the result. - (inst sar result (min 31 (- shift)))))))))) + ;; If the shift is greater than 31, only shift by 31. We + ;; have to do this because the shift instructions only look + ;; at the low five bits of the result. + (inst sar result (min 31 (- shift)))))))) (define-vop (fast-ash-left/unsigned=>unsigned) (:translate ash) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4367609e79b7cb5d6fa6f9a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4367609e79b7cb5d6fa6f9a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs