cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

[Git][cmucl/cmucl][issue-240-subsetp-with-hash-table] Fix type-init problem and set min length to 150 for subsetp
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: d1e97d99 by Raymond Toy at 2023-08-21T08:10:45-07:00 Fix type-init problem and set min length to 150 for subsetp I was wrong about `type-init` having hashtables available. The issue was `*min-list-length-for-hashtable*` not being defined during `type-init`. Also, some timing tests indicate that we need a list length of about 150 for the hashtable implementation to be faster than the list implementation. So, add a new variable `*min-list-length-for-subsetp-hashtable*` with a default value of 150. A `cold-init-form` is added so it's available during `type-init`. The variable `*allow-hashtable-for-set-functions*` is removed because we don't need it anymore. Also, as a test, I set `*min-list-length-for-subsetp-hashtable*` to 10, and we were still able to build lisp without problems. - - - - - 4 changed files: - src/code/lispinit.lisp - src/code/list.lisp - src/code/save.lisp - src/code/type.lisp Changes: ===================================== src/code/lispinit.lisp ===================================== @@ -347,9 +347,6 @@ #+gengc (setf conditions::*handler-clusters* nil) (setq intl::*default-domain* "cmucl") (setq intl::*locale* "C") - ;; During init, we can't use hashtables to speed up the set - ;; functions. In particular, subsetp is used in type-init. - (setq lisp::*allow-hashtable-for-set-functions* nil) ;; Many top-level forms call INFO, (SETF INFO). (print-and-call c::globaldb-init) ===================================== src/code/list.lisp ===================================== @@ -989,8 +989,6 @@ (rplacd splicex (cdr x))) (setq splicex x))))) -(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) @@ -1013,7 +1011,7 @@ (lst2 list2 (cdr lst2))) ((or (null lst1) (null lst2)) (values len (if (null lst1) list1 list2)))) - (when (< min-length *min-list-length-for-hashtable*) + (when (< min-length kernel::*min-list-length-for-subsetp-hashtable*) (return-from shorter-list-to-hashtable nil)) (let ((hashtable (make-hash-table :test hash-test :size min-length))) (dolist (item shorter-list) @@ -1031,7 +1029,7 @@ ;; take care to disable this for the kernel.core. SAVE will set ;; this to true when it's safe to use hash tables for SUBSETP. (multiple-value-bind (hashtable shorter-list) - (when *allow-hashtable-for-set-functions* + (when t (shorter-list-to-hashtable list1 list2 key test test-not)) (cond (hashtable (cond ((eq shorter-list list1) ===================================== src/code/save.lisp ===================================== @@ -320,8 +320,6 @@ (intl::setlocale) (ext::process-command-strings process-command-line) (setf *editor-lisp-p* nil) - ;; Allow using hashtables to speed up the set functions - (setf lisp::*allow-hashtable-for-set-functions* t) (macrolet ((find-switch (name) `(find ,name *command-line-switches* :key #'cmd-switch-name ===================================== src/code/type.lisp ===================================== @@ -377,6 +377,14 @@ (cold-load-init (setq *use-implementation-types* t)) (declaim (type boolean *use-implementation-types*)) +(defvar *min-list-length-for-subsetp-hashtable* 150 + "The minimum length of either list argument for subsetp where a + hashtable is used to speed up processing instead of using a basic + list implementation. This value was determined by experimentation.") + +(cold-load-init (setq *min-list-length-for-subsetp-hashtable* 150)) +(declaim (type fixnum *min-list-length-for-subsetp-hashtable*)) + ;;; DELEGATE-COMPLEX-{SUBTYPEP-ARG2,INTERSECTION} -- Interface ;;; ;;; These functions are used as method for types which need a complex View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d1e97d9930f50e378166876… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d1e97d9930f50e378166876… 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] Allow hashing the shorter of the two lists
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: b1638cf0 by Raymond Toy at 2023-08-20T20:12:26-07:00 Allow hashing the shorter of the two lists Carl suggested we can hash the first list and then run over the second list and remove the element from the hashtable. When we're done, if the hashtable is empty, then the first list is a subset of the second. This shows some nice speedup when the second list is much longer than the first. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -991,6 +991,35 @@ (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)) @@ -1001,20 +1030,31 @@ ;; 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 when 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)))) + (multiple-value-bind (hashtable shorter-list) + (when *allow-hashtable-for-set-functions* + (shorter-list-to-hashtable list1 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) + (cond ((eq shorter-list list1) + ;; Remove any item from list2 from the hashtable containing list1. + (dolist (item list2) + (remhash (apply-key key item) hashtable)) + ;; If the hash table is now empty, then every + ;; element in list1 appeared in list2, so list1 is a + ;; subset of list2. + (zerop (hash-table-count hashtable))) + ((eq shorter-list list2) + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (return-from subsetp nil))) + t))) (t (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/b1638cf0f8a49b5e032591a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b1638cf0f8a49b5e032591a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-252-script-to-run-ansi-tests
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed new branch issue-252-script-to-run-ansi-tests at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-252-script-to-run-a… 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] Always hash list2 and add tests
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: 46f5352a by Raymond Toy at 2023-08-20T15:17:51-07:00 Always hash list2 and add tests Made a logic error; we can't hash the shorter of the two lists, at least not without a big change to the implementation. We always hash the second list now. Remove shorter-list-to-hashtable. Add tests for subsetp. - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -991,35 +991,6 @@ (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)) @@ -1029,28 +1000,21 @@ ;; 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)) + ;; this to true when 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 - (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))))) + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (return-from subsetp nil))) t) - ((null hashtable) + (t (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 ===================================== tests/sets.lisp ===================================== @@ -172,3 +172,54 @@ '(3 4) :test 'eql :test-not 'eql))) + + +(define-test subsetp.hash-eq + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-true + (subsetp '(a b c a) '(a a d d c b) :test 'eq)) + (assert-true + (subsetp '(a b c a b c a b c) '(a a d d c b) :test 'eq)) + (assert-false + (subsetp '(a b c a z) '(a a d d c b) :test 'eq)) + (assert-false + (subsetp '(a b c a b cz) '(a a d d c b) :test 'eq)))) + +(define-test subsetp.hash-eql + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-true + (subsetp '(a b c a) '(a a d d c b) :test 'eql)) + (assert-false + (subsetp '(a b c a z) '(a a d d c b) :test 'eql)))) + +(define-test subsetp.hash-equal + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-true + (subsetp '("a" "b" "c" "a") '("a" "a" "d" "d" "c" "b") :test 'equal)) + (assert-false + (subsetp '("a" "b" "c" "a" "z") '("a" "a" "d" "d" "c" "b") :test 'equal)))) + +(define-test subsetp.hash-equalp + (:tag :issues) + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-true + (subsetp '("a" "b" "C" "A") '("a" "a" "d" "d" "c" "b") :test 'equalp)) + (assert-false + (subsetp '("a" "b" "C" "A" "z") '("a" "a" "d" "d" "c" "b") :test 'equalp)))) + +(define-test subsetp.hash-eql-with-key + (:tag :issues) + (assert-true (subsetp '((1 "a") (2 "b") (3 "c")) + '((3 "c") (3 "c") (2 "b") (1 "a")) + :test 'eql + :key #'first))) + +(define-test subsetp.test-and-test-not + (assert-error 'simple-error + (subsetp '(1 2) + '(3 4) + :test 'eql + :test-not 'equal))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/46f5352ac1d9edc8f8c0998… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/46f5352ac1d9edc8f8c0998… 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] Block compile shorter-list-to-hashtable with subsetp
by Raymond Toy (＠rtoy) 20 Aug '23

20 Aug '23

Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl Commits: 0563f5ab by Raymond Toy at 2023-08-20T13:32:29-07:00 Block compile shorter-list-to-hashtable with subsetp Add block compilation declarations so `shorter-list-to-hashtable` can be a local call for `subsetp`. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -991,7 +991,7 @@ (defvar *allow-hashtable-for-set-functions* t) -;;(declaim (start-block shorter-list-to-hashtable subsetp)) +(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 @@ -1049,7 +1049,7 @@ (return-from subsetp nil))) T)))) -;;(declaim (end-block)) +(declaim (end-block)) ;;; Functions that operate on association lists View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0563f5ab8ad64eac0fad68e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0563f5ab8ad64eac0fad68e… 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] Split out list to hashtable function to its own
by Raymond Toy (＠rtoy) 20 Aug '23

20 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) 18 Aug '23

18 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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs