cmucl-cvs August 2023

cmucl-cvs@common-lisp.net

1 participants
67 discussions

[Git][cmucl/cmucl][issue-240-subsetp-with-hash-table] Split out list to hashtable function to its own
by Raymond Toy (＠rtoy) 19 Aug '23

19 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: ed173bfe by Raymond Toy at 2023-08-19T15:59:39-07:00 Split out list to hashtable function to its own Move the list to hashtable function to its own function so we can profile it. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -991,62 +991,65 @@ (defvar *allow-hashtable-for-set-functions* t) +;;(declaim (start-block shorter-list-to-hashtable subsetp)) + +(defun shorter-list-to-hashtable (list1 list2 key test test-not) + ;; Find the shorter list and return the length and the shorter list + (when test-not + (return-from shorter-list-to-hashtable nil)) + (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 shorter-list-to-hashtable nil)) + (multiple-value-bind (min-length shorter-list) + (do ((len 0 (1+ len)) + (lst1 list1 (cdr lst1)) + (lst2 list2 (cdr lst2))) + ((or (null lst1) (null lst2)) + (values len (if (null lst1) list1 list2)))) + (when (< min-length *min-list-length-for-hashtable*) + (return-from shorter-list-to-hashtable nil)) + (let ((hashtable (make-hash-table :test hash-test :size min-length))) + (dolist (item shorter-list) + (setf (gethash (apply-key key item) hashtable) item)) + (values hashtable shorter-list))))) + (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.")) - (flet ((lists-to-hashtable () - ;; Find the shorter list and return the length and the shorter list - (when test-not - (return-from lists-to-hashtable nil)) - (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 lists-to-hashtable nil)) - (multiple-value-bind (min-length shorter-list) - (do ((len 0 (1+ len)) - (lst1 list1 (cdr lst1)) - (lst2 list2 (cdr lst2))) - ((or (null lst1) (null lst2)) - (values len (if (null lst1) list1 list2)))) - (when (< min-length *min-list-length-for-hashtable*) - (return-from lists-to-hashtable nil)) - (let ((hashtable (make-hash-table :test hash-test :size min-length))) - (dolist (item shorter-list) - (setf (gethash (apply-key key item) hashtable) item)) - (values hashtable shorter-list)))))) - - ;; 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. - (multiple-value-bind (hashtable shorter-list) - (when *allow-hashtable-for-set-functions* - (lists-to-hashtable)) - (cond (hashtable - (cond ((eq shorter-list list1) - (dolist (item list2) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (return-from subsetp nil)))) - ((eq shorter-list list2) - (dolist (item list1) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (return-from subsetp nil))))) - t) - ((null hashtable) - (dolist (item list1) - (unless (with-set-keys (member (apply-key key item) list2)) - (return-from subsetp nil))) - T))))) + ;; 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. + (multiple-value-bind (hashtable shorter-list) + (when *allow-hashtable-for-set-functions* + (shorter-list-to-hashtable list1 list2 key test test-not)) + (cond (hashtable + (cond ((eq shorter-list list1) + (dolist (item list2) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (return-from subsetp nil)))) + ((eq shorter-list list2) + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (return-from subsetp nil))))) + t) + ((null hashtable) + (dolist (item list1) + (unless (with-set-keys (member (apply-key key item) list2)) + (return-from subsetp nil))) + T)))) +;;(declaim (end-block)) ;;; Functions that operate on association lists View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ed173bfe0f2fa05bbcd6730… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ed173bfe0f2fa05bbcd6730… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #249: Replace lea instruction for arithmetic
by Raymond Toy (＠rtoy) 19 Aug '23

19 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: a70248dd by Raymond Toy at 2023-08-19T13:38:11+00:00 Fix #249: Replace lea instruction for arithmetic - - - - - 5b3e11f9 by Raymond Toy at 2023-08-19T13:38:34+00:00 Merge branch 'issue-249-replace-lea-in-arith' into 'master' Fix #249: Replace lea instruction for arithmetic Closes #249 See merge request cmucl/cmucl!163 - - - - - 1 changed file: - src/compiler/x86/arith.lisp Changes: ===================================== src/compiler/x86/arith.lisp ===================================== @@ -196,143 +196,13 @@ -;(define-binop + 4 add) +(define-binop + 4 add) (define-binop - 4 sub) (define-binop logand 2 and) (define-binop logior 2 or) (define-binop logxor 2 xor) -;;; Special handling of add on the x86; can use lea to avoid a -;;; register load, otherwise it uses add. -(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op) - (:translate +) - (:args (x :scs (any-reg) :target r - :load-if (not (and (sc-is x control-stack) - (sc-is y any-reg) - (sc-is r control-stack) - (location= x r)))) - (y :scs (any-reg control-stack))) - (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg) :from (:argument 0) - :load-if (not (and (sc-is x control-stack) - (sc-is y any-reg) - (sc-is r control-stack) - (location= x r))))) - (:result-types tagged-num) - (:note _N"inline fixnum arithmetic") - (:generator 2 - (cond ((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))))) - -(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) - (:translate +) - (:args (x :target r :scs (any-reg control-stack))) - (:info y) - (:arg-types tagged-num (:constant (signed-byte 30))) - (:results (r :scs (any-reg) - :load-if (not (location= x r)))) - (:result-types tagged-num) - (:note _N"inline fixnum arithmetic") - (:generator 1 - (cond ((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)))))) - -(define-vop (fast-+/signed=>signed fast-safe-arith-op) - (:translate +) - (:args (x :scs (signed-reg) :target r - :load-if (not (and (sc-is x signed-stack) - (sc-is y signed-reg) - (sc-is r signed-stack) - (location= x r)))) - (y :scs (signed-reg signed-stack))) - (:arg-types signed-num signed-num) - (:results (r :scs (signed-reg) :from (:argument 0) - :load-if (not (and (sc-is x signed-stack) - (sc-is y signed-reg) - (location= x r))))) - (:result-types signed-num) - (:note _N"inline (signed-byte 32) arithmetic") - (:generator 5 - (cond ((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))))) - -(define-vop (fast-+-c/signed=>signed fast-safe-arith-op) - (:translate +) - (:args (x :target r :scs (signed-reg signed-stack))) - (:info y) - (:arg-types signed-num (:constant (signed-byte 32))) - (:results (r :scs (signed-reg) - :load-if (not (location= x r)))) - (:result-types signed-num) - (:note _N"inline (signed-byte 32) arithmetic") - (:generator 4 - (cond ((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)))))) - -(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op) - (:translate +) - (:args (x :scs (unsigned-reg) :target r - :load-if (not (and (sc-is x unsigned-stack) - (sc-is y unsigned-reg) - (sc-is r unsigned-stack) - (location= x r)))) - (y :scs (unsigned-reg unsigned-stack))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg) :from (:argument 0) - :load-if (not (and (sc-is x unsigned-stack) - (sc-is y unsigned-reg) - (sc-is r unsigned-stack) - (location= x r))))) - (:result-types unsigned-num) - (:note _N"inline (unsigned-byte 32) arithmetic") - (:generator 5 - (cond ((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))))) - -(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op) - (:translate +) - (:args (x :target r :scs (unsigned-reg unsigned-stack))) - (:info y) - (:arg-types unsigned-num (:constant (unsigned-byte 32))) - (:results (r :scs (unsigned-reg) - :load-if (not (location= x r)))) - (:result-types unsigned-num) - (:note _N"inline (unsigned-byte 32) arithmetic") - (:generator 4 - (cond ((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)))))) - - ;;;; Special logand cases: (logand signed unsigned) => unsigned (define-vop (fast-logand/signed-unsigned=>unsigned @@ -641,25 +511,18 @@ (:result-types tagged-num) (:note _N"inline ASH") (:generator 2 - (cond ((and (= amount 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - ((and (= amount 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - ((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) @@ -699,22 +562,15 @@ (:result-types unsigned-num) (:note _N"inline ASH") (:generator 3 - (cond ((and (= amount 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - ((and (= amount 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - ((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) @@ -732,23 +588,16 @@ (:result-types signed-num) (:note _N"inline ASH") (:generator 3 - (cond ((and (= amount 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - ((and (= amount 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - ((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) @@ -767,23 +616,16 @@ (:note "inline ASH") (:generator 1 (let ((shift (- amount vm:fixnum-tag-bits))) - (cond ((and (= shift 1) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 2))) - ((and (= shift 2) (not (location= number result))) - (inst lea result (make-ea :dword :index number :scale 4))) - ((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) @@ -1907,4 +1749,4 @@ vm:other-pointer-type)) s1))) ) - \ No newline at end of file + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/181508a9edeaf570fd3f7a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/181508a9edeaf570fd3f7a… 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] 11 commits: Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis
by Raymond Toy (＠rtoy) 18 Aug '23

18 Aug '23

Raymond Toy pushed to branch issue-249-replace-lea-in-arith 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 - - - - - 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. - - - - - 12809996 by Raymond Toy at 2023-08-18T08:39:02-07:00 Merge branch 'master' into issue-249-replace-lea-in-arith - - - - - 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 ===================================== @@ -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. ;;; @@ -755,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 @@ -792,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)) @@ -812,20 +861,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)) @@ -1050,7 +1111,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 ===================================== @@ -0,0 +1,174 @@ +;; 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))) + + + +(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/7cf87451de270f9618c61c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/7cf87451de270f9618c61c… 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] Use define-binop for add as well
by Raymond Toy (＠rtoy) 18 Aug '23

18 Aug '23

Raymond Toy pushed to branch issue-249-replace-lea-in-arith at cmucl / cmucl Commits: 7cf87451 by Raymond Toy at 2023-08-18T08:06:20-07:00 Use define-binop for add as well We can use define-binop for add because we don't have the special handling to allow lea anymore. This also means we can remove all of the hand-written vops to handle +. - - - - - 1 changed file: - src/compiler/x86/arith.lisp Changes: ===================================== src/compiler/x86/arith.lisp ===================================== @@ -196,118 +196,13 @@ -;(define-binop + 4 add) +(define-binop + 4 add) (define-binop - 4 sub) (define-binop logand 2 and) (define-binop logior 2 or) (define-binop logxor 2 xor) -;;; Special handling of add on the x86; can use lea to avoid a -;;; register load, otherwise it uses add. -(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op) - (:translate +) - (:args (x :scs (any-reg) :target r - :load-if (not (and (sc-is x control-stack) - (sc-is y any-reg) - (sc-is r control-stack) - (location= x r)))) - (y :scs (any-reg control-stack))) - (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg) :from (:argument 0) - :load-if (not (and (sc-is x control-stack) - (sc-is y any-reg) - (sc-is r control-stack) - (location= x r))))) - (:result-types tagged-num) - (:note _N"inline fixnum arithmetic") - (:generator 2 - (move r x) - (inst add r y))) - -(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) - (:translate +) - (:args (x :target r :scs (any-reg control-stack))) - (:info y) - (:arg-types tagged-num (:constant (signed-byte 30))) - (:results (r :scs (any-reg) - :load-if (not (location= x r)))) - (:result-types tagged-num) - (:note _N"inline fixnum arithmetic") - (:generator 1 - (move r x) - (inst add r (fixnumize y)))) - -(define-vop (fast-+/signed=>signed fast-safe-arith-op) - (:translate +) - (:args (x :scs (signed-reg) :target r - :load-if (not (and (sc-is x signed-stack) - (sc-is y signed-reg) - (sc-is r signed-stack) - (location= x r)))) - (y :scs (signed-reg signed-stack))) - (:arg-types signed-num signed-num) - (:results (r :scs (signed-reg) :from (:argument 0) - :load-if (not (and (sc-is x signed-stack) - (sc-is y signed-reg) - (location= x r))))) - (:result-types signed-num) - (:note _N"inline (signed-byte 32) arithmetic") - (:generator 5 - (move r x) - (inst add r y))) - -(define-vop (fast-+-c/signed=>signed fast-safe-arith-op) - (:translate +) - (:args (x :target r :scs (signed-reg signed-stack))) - (:info y) - (:arg-types signed-num (:constant (signed-byte 32))) - (:results (r :scs (signed-reg) - :load-if (not (location= x r)))) - (:result-types signed-num) - (:note _N"inline (signed-byte 32) arithmetic") - (:generator 4 - (move r x) - (if (= y 1) - (inst inc r) - (inst add r y)))) - -(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op) - (:translate +) - (:args (x :scs (unsigned-reg) :target r - :load-if (not (and (sc-is x unsigned-stack) - (sc-is y unsigned-reg) - (sc-is r unsigned-stack) - (location= x r)))) - (y :scs (unsigned-reg unsigned-stack))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg) :from (:argument 0) - :load-if (not (and (sc-is x unsigned-stack) - (sc-is y unsigned-reg) - (sc-is r unsigned-stack) - (location= x r))))) - (:result-types unsigned-num) - (:note _N"inline (unsigned-byte 32) arithmetic") - (:generator 5 - (move r x) - (inst add r y))) - -(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op) - (:translate +) - (:args (x :target r :scs (unsigned-reg unsigned-stack))) - (:info y) - (:arg-types unsigned-num (:constant (unsigned-byte 32))) - (:results (r :scs (unsigned-reg) - :load-if (not (location= x r)))) - (:result-types unsigned-num) - (:note _N"inline (unsigned-byte 32) arithmetic") - (:generator 4 - (move r x) - (if (= y 1) - (inst inc r) - (inst add r y)))) - - ;;;; Special logand cases: (logand signed unsigned) => unsigned (define-vop (fast-logand/signed-unsigned=>unsigned View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7cf87451de270f9618c61c6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7cf87451de270f9618c61c6… 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] for subsetp, hash the shorter of the two lists.
by Raymond Toy (＠rtoy) 17 Aug '23

17 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: e0d52154 by Raymond Toy at 2023-08-17T16:55:56-07:00 for subsetp, hash the shorter of the two lists. Since subsetp is kind of symmetrical and duplicates don't matter, we can hash either list. So let's hash the shorter of the two lists to minimize the host of creating the hashtable. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -997,22 +997,55 @@ (when (and testp notp) (error "Test and test-not both supplied.")) - ;; 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))) - t) - ((null hashtable) - (dolist (item list1) - (unless (with-set-keys (member (apply-key key item) list2)) - (return-from subsetp nil))) - T)))) + (flet ((lists-to-hashtable () + ;; Find the shorter list and return the length and the shorter list + (when test-not + (return-from lists-to-hashtable nil)) + (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 lists-to-hashtable nil)) + (multiple-value-bind (min-length shorter-list) + (do ((len 0 (1+ len)) + (lst1 list1 (cdr lst1)) + (lst2 list2 (cdr lst2))) + ((or (null lst1) (null lst2)) + (values len (if (null lst1) list1 list2)))) + (when (< min-length *min-list-length-for-hashtable*) + (return-from lists-to-hashtable nil)) + (let ((hashtable (make-hash-table :test hash-test :size min-length))) + (dolist (item shorter-list) + (setf (gethash (apply-key key item) hashtable) item)) + (values hashtable shorter-list)))))) + + ;; 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. + (multiple-value-bind (hashtable shorter-list) + (when *allow-hashtable-for-set-functions* + (lists-to-hashtable)) + (cond (hashtable + (cond ((eq shorter-list list1) + (dolist (item list2) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (return-from subsetp nil)))) + ((eq shorter-list list2) + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (return-from subsetp nil))))) + t) + ((null hashtable) + (dolist (item list1) + (unless (with-set-keys (member (apply-key key item) list2)) + (return-from subsetp nil))) + T))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e0d5215400dab3169ab663f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e0d5215400dab3169ab663f… 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] 6 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 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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs August 2023