August 2023 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl] Pushed new tag snapshot-2023-08
by Raymond Toy (＠rtoy) 31 Aug '23

31 Aug '23

Raymond Toy pushed new tag snapshot-2023-08 at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/snapshot-2023-08 You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-259-use-right-software-version] Fix typo in bootstrap variable
by Raymond Toy (＠rtoy) 30 Aug '23

30 Aug '23

Raymond Toy pushed to branch issue-259-use-right-software-version at cmucl / cmucl Commits: dd384b82 by Raymond Toy at 2023-08-30T16:08:42-07:00 Fix typo in bootstrap variable The bootstrap variable is the bootstrap option to build.sh, so it needs the -B option name too, not just the name of the file. - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1,7 +1,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/release/21e" version: "21e-x86" - bootstrap: "boot-2023-08" + bootstrap: "-B boot-2023-08" stages: - install View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dd384b8200627dd67aedfcc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dd384b8200627dd67aedfcc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-259-use-right-software-version] Use bootstrap file
by Raymond Toy (＠rtoy) 30 Aug '23

30 Aug '23

Raymond Toy pushed to branch issue-259-use-right-software-version at cmucl / cmucl Commits: 5988abc7 by Raymond Toy at 2023-08-30T15:50:58-07:00 Use bootstrap file Forgot to tell CI to use the bootstrap file to build the change. - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1,7 +1,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/release/21e" version: "21e-x86" - bootstrap: "" + bootstrap: "boot-2023-08" stages: - install View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5988abc756ae007124a4afa… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5988abc756ae007124a4afa… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update release notes with fixed issues
by Raymond Toy (＠rtoy) 30 Aug '23

30 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 961c96ad by Raymond Toy at 2023-08-30T11:12:42-07:00 Update release notes with fixed issues - - - - - 1 changed file: - src/general-info/release-21f.md Changes: ===================================== src/general-info/release-21f.md ===================================== @@ -1,3 +1,5 @@ +# CMUCL 21f + # Work in progress The CMUCL project is pleased to announce the release of CMUCL 21f. @@ -24,9 +26,16 @@ public domain. * Gitlab tickets: * ~~#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 + * ~~#196~~ Fix issues with mapping and nconc accumulation (mapcan) + * ~~#216~~ `enough-namestring` with relative pathname fails + * ~~#234~~ Make :ASCII external format builtin + * ~~#240~~ Speed up set operations + * ~~#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 + * ~~#249~~ Replace LEA instruction with simpler shorter instructions in arithmetic vops for x86 + * ~~#253~~ Block-compile list-to-hashtable and callers + * ~~#258~~ Remove `get-page-size` from linux-os.lisp * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/961c96adaded1bf545d8b04… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/961c96adaded1bf545d8b04… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Add hashtable for set-exclusive-or
by Raymond Toy (＠rtoy) 30 Aug '23

30 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: db531fef by Raymond Toy at 2023-08-30T17:59:50+00:00 Address #240: Add hashtable for set-exclusive-or - - - - - 766c6aa5 by Raymond Toy at 2023-08-30T18:00:08+00:00 Merge branch 'issue-240-add-hashtable-set-exclusive-or' into 'master' Address #240: Add hashtable for set-exclusive-or See merge request cmucl/cmucl!169 - - - - - 3 changed files: - src/code/list.lisp - src/i18n/locale/cmucl.pot - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -928,7 +928,7 @@ (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) - "Return new list of elements appearing exactly once in LIST1 and LIST2." + "Return new list of elements appearing exactly one of LIST1 and LIST2." (declare (inline member)) (let ((result nil) (key (when key (coerce key 'function))) @@ -936,19 +936,38 @@ (test-not (if test-not (coerce test-not 'function) #'eql))) (declare (type (or function null) key) (type function test test-not)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (setq result (cons elt result)))) - (let ((test (if testp - (lambda (x y) (funcall test y x)) - test)) - (test-not (if notp - (lambda (x y) (funcall test-not y x)) - test-not))) - (dolist (elt list2) - (unless (with-set-keys (member (apply-key key elt) list1)) - (setq result (cons elt result))))) - result)) + ;; Find the elements in list1 that do not appear in list2 and add + ;; them to the result. + (macrolet + ((compute-membership (item-list test-form) + `(dolist (elt ,item-list) + (unless ,test-form + (setq result (cons elt result)))))) + (let ((hashtable (list-to-hashtable list2 key test test-not))) + (cond + (hashtable + (compute-membership list1 + (nth-value 1 (gethash (apply-key key elt) hashtable)))) + (t + (compute-membership list1 + (with-set-keys (member (apply-key key elt) list2)))))) + ;; Now find the elements in list2 that do not appear in list1 and + ;; them to the result. + (let ((hashtable (list-to-hashtable list1 key test test-not))) + (cond + (hashtable + (compute-membership list2 + (nth-value 1 (gethash (apply-key key elt) hashtable)))) + (t + (let ((test (if testp + (lambda (x y) (funcall test y x)) + test)) + (test-not (if notp + (lambda (x y) (funcall test-not y x)) + test-not))) + (compute-membership list2 + (with-set-keys (member (apply-key key elt) list1))))))) + result))) ;;; The outer loop examines list1 while the inner loop examines list2. If an ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3236,7 +3236,7 @@ msgid "Destructively returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Return new list of elements appearing exactly once in LIST1 and LIST2." +msgid "Return new list of elements appearing exactly one of LIST1 and LIST2." msgstr "" #: src/code/list.lisp ===================================== tests/sets.lisp ===================================== @@ -279,3 +279,26 @@ '(3 4) :test 'eql :test-not 'equal))) + +(define-test set-exclusive-or.1 + (:tag :issues) + (flet + ((test (min-length) + ;; From CLHS + (let ((lisp::*min-list-length-for-hashtable* min-length)) + (assert-equal '("b" "A" "b" "a") + (set-exclusive-or '(1 "a" "b") + '(1 "A" "b"))) + (assert-equal '("A" "a") + (set-exclusive-or '(1 "a" "b") + '(1 "A" "b") + :test #'equal)) + (assert-equal nil + (set-exclusive-or '(1 "a" "b") + '(1 "A" "b") + :test #'equalp))))) + ;; Test the list impl by making the min length large. Then test + ;; the hashtable impl with a very short min length + (test 100) + (test 2))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/77dee6275790bafea5b008… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/77dee6275790bafea5b008… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-259-use-right-software-version
by Raymond Toy (＠rtoy) 30 Aug '23

30 Aug '23

Raymond Toy pushed new branch issue-259-use-right-software-version at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-259-use-right-softw… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #258: Remove get-page-size from linux-os.lisp
by Raymond Toy (＠rtoy) 30 Aug '23

30 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 917c4240 by Raymond Toy at 2023-08-30T17:38:23+00:00 Fix #258: Remove get-page-size from linux-os.lisp - - - - - 77dee627 by Raymond Toy at 2023-08-30T17:38:40+00:00 Merge branch 'issue-258-remove-get-page-size-from-linux-os' into 'master' Fix #258: Remove get-page-size from linux-os.lisp Closes #258 See merge request cmucl/cmucl!172 - - - - - 2 changed files: - src/code/linux-os.lisp - src/i18n/locale/cmucl-linux-os.pot Changes: ===================================== src/code/linux-os.lisp ===================================== @@ -32,16 +32,3 @@ ;;; (defun os-init () (setf *software-version* nil)) - - -;;; GET-PAGE-SIZE -- Interface -;;; -;;; Return the system page size. -;;; -(defun get-page-size () - (multiple-value-bind (val err) - (unix:unix-getpagesize) - (unless val - (error (intl:gettext "Getpagesize failed: ~A") (unix:get-unix-error-msg err))) - val)) - ===================================== src/i18n/locale/cmucl-linux-os.pot ===================================== @@ -15,10 +15,6 @@ msgstr "" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" -#: src/code/linux-os.lisp -msgid "Getpagesize failed: ~A" -msgstr "" - #: src/code/signal.lisp msgid "Stack fault on coprocessor" msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d08a26c44064027d44023d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d08a26c44064027d44023d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-258-remove-get-page-size-from-linux-os
by Raymond Toy (＠rtoy) 29 Aug '23

29 Aug '23

Raymond Toy pushed new branch issue-258-remove-get-page-size-from-linux-os at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-258-remove-get-page… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Remove extra closing paren after %print-pathname
by Raymond Toy (＠rtoy) 29 Aug '23

29 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d08a26c4 by Raymond Toy at 2023-08-29T14:53:04-07:00 Remove extra closing paren after %print-pathname Gets rid of a simple compiler warning. - - - - - 1 changed file: - src/code/pathname.lisp Changes: ===================================== src/code/pathname.lisp ===================================== @@ -195,7 +195,7 @@ (%pathname-directory pathname) (%pathname-name pathname) (%pathname-type pathname) - (%pathname-version pathname))))))))) + (%pathname-version pathname)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d08a26c44064027d44023d0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d08a26c44064027d44023d0… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] Macroize membership loop in set-exclusiv-or
by Raymond Toy (＠rtoy) 29 Aug '23

29 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: dac5115d by Raymond Toy at 2023-08-29T06:53:26-07:00 Macroize membership loop in set-exclusiv-or Add a short macro to handle looping over a list determining the membership of the list element in the result. Fix a typo in the docstring. Update cmucl.pot due to the changed docstring. - - - - - 2 changed files: - src/code/list.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/list.lisp ===================================== @@ -916,35 +916,36 @@ (type function test test-not)) ;; Find the elements in list1 that do not appear in list2 and add ;; them to the result. - (let ((hashtable (list-to-hashtable list2 key test test-not))) - (cond - (hashtable - (dolist (elt list1) - (unless (nth-value 1 (gethash (apply-key key elt) hashtable)) - (setq result (cons elt result))))) - (t - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (setq result (cons elt result))))))) - ;; Now find the elements in list2 that do not appear in list1 and - ;; them to the result. - (let ((hashtable (list-to-hashtable list1 key test test-not))) - (cond - (hashtable - (dolist (elt list2) - (unless (nth-value 1 (gethash (apply-key key elt) hashtable)) - (setq result (cons elt result))))) - (t - (let ((test (if testp - (lambda (x y) (funcall test y x)) - test)) - (test-not (if notp - (lambda (x y) (funcall test-not y x)) - test-not))) - (dolist (elt list2) - (unless (with-set-keys (member (apply-key key elt) list1)) - (setq result (cons elt result)))))))) - result)) + (macrolet + ((compute-membership (item-list test-form) + `(dolist (elt ,item-list) + (unless ,test-form + (setq result (cons elt result)))))) + (let ((hashtable (list-to-hashtable list2 key test test-not))) + (cond + (hashtable + (compute-membership list1 + (nth-value 1 (gethash (apply-key key elt) hashtable)))) + (t + (compute-membership list1 + (with-set-keys (member (apply-key key elt) list2)))))) + ;; Now find the elements in list2 that do not appear in list1 and + ;; them to the result. + (let ((hashtable (list-to-hashtable list1 key test test-not))) + (cond + (hashtable + (compute-membership list2 + (nth-value 1 (gethash (apply-key key elt) hashtable)))) + (t + (let ((test (if testp + (lambda (x y) (funcall test y x)) + test)) + (test-not (if notp + (lambda (x y) (funcall test-not y x)) + test-not))) + (compute-membership list2 + (with-set-keys (member (apply-key key elt) list1))))))) + result))) ;;; The outer loop examines list1 while the inner loop examines list2. If an ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3236,7 +3236,7 @@ msgid "Destructively returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Return new list of elements appearing exactly once in LIST1 and LIST2." +msgid "Return new list of elements appearing exactly one of LIST1 and LIST2." msgstr "" #: src/code/list.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dac5115d3df457ac2daadcd… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dac5115d3df457ac2daadcd… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Rename processing macros for set operations
by Raymond Toy (＠rtoy) 29 Aug '23

29 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: ffe3625a by Raymond Toy at 2023-08-29T13:01:16+00:00 Address #240: Rename processing macros for set operations - - - - - 747a82ba by Raymond Toy at 2023-08-29T13:04:36+00:00 Merge branch 'issue-240-clean-up-hashtable-for-sets-impl' into 'master' Address #240: Rename processing macros for set operations See merge request cmucl/cmucl!171 - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -753,26 +753,31 @@ union intersection set-difference nunion nintersection nset-difference)) -;; Main code to process a set function. INIT-RES initializes the -;; value of RES, which holds the result of the set function. -;; TEST-FORM is a form that tests whether to add the item from LIST1 -;; to RES. -(defmacro process-set-body (init-res invert-p test-form) - `(let ((res ,init-res)) - (dolist (item list1) - (when ,(if invert-p - `(not ,test-form) - test-form) - (push item res))) - res)) - -(defmacro process-set (init-res invert-p) - `(let ((hashtable (list-to-hashtable list2 key test test-not))) - (if hashtable - (process-set-body ,init-res ,invert-p - (nth-value 1 (gethash (apply-key key item) hashtable))) - (process-set-body ,init-res ,invert-p - (with-set-keys (member (apply-key key item) list2)))))) +;; Handle a non-destructive set operation. LIST1 and LIST2 are the +;; two arguments to the set function. INITIAL-RESULT is the value +;; used to initialize the result list. IS specifies whether the test +;; (or test-not) function implies an element of LIST1 should be +;; included in the result. +(defmacro do-set-operation (list1 list2 &key initial-result is) + (let ((membership-test (ecase is + (:element-of-set + 'when) + (:not-element-of-set + 'unless)))) + `(let ((hashtable (list-to-hashtable ,list2 key test test-not))) + (macrolet + ((process-set-op (list1 init-res member-form test-form) + `(let ((res ,init-res)) + (dolist (item ,list1) + (,member-form ,test-form + (push item res))) + res))) + + (if hashtable + (process-set-op ,list1 ,initial-result ,membership-test + (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set-op ,list1 ,initial-result ,membership-test + (with-set-keys (member (apply-key key item) list2)))))))) ;; Convert a list to a hashtable. The hashtable does not handle ;; duplicated values in the list. Returns the hashtable. @@ -815,7 +820,7 @@ (declare (inline member)) (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (process-set list2 t)) + (do-set-operation list1 list2 :initial-result list2 :is :not-element-of-set)) (defun intersection (list1 list2 &key key @@ -824,7 +829,7 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (process-set nil nil)) + (do-set-operation list1 list2 :initial-result nil :is :element-of-set)) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -835,7 +840,7 @@ (when (null list2) (return-from set-difference list1)) - (process-set nil t)) + (do-set-operation list1 list2 :initial-result nil :is :not-element-of-set)) ;;; Destination and source are setf-able and many-evaluable. Sets the source @@ -851,14 +856,14 @@ ;;; the result list. INVERT-P is T if the result of the TEST-FORM ;;; should be inverted. TEST-FORM is the form used for determining ;;; how to update the result. -(defmacro nprocess-set-body (init-res invert-p test-form) +(defmacro nprocess-set-body (list1 init-res is-member-p test-form) `(let ((res ,init-res) - (list1 list1)) + (list1 ,list1)) (do () ((endp list1)) - (if ,(if invert-p - `(not ,test-form) - test-form) + (if ,(if is-member-p + test-form + `(not ,test-form)) (steve-splice list1 res) (setq list1 (cdr list1)))) res)) @@ -867,13 +872,30 @@ ;; initializes the value of the result list. INVERT-P indicates ;; whether to invert the test-form used to determine how the result ;; should be updated. -(defmacro nprocess-set (init-res invert-p) - `(let ((hashtable (list-to-hashtable list2 key test test-not))) - (if hashtable - (nprocess-set-body ,init-res ,invert-p - (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) - (nprocess-set-body ,init-res ,invert-p - (with-set-keys (member (apply-key key (car list1)) list2)))))) +(defmacro do-destructive-set-operation (list1 list2 &key initial-result is) + (let ((is-member-p (ecase is + (:element-of-set + t) + (:not-element-of-set + nil)))) + `(let ((hashtable (list-to-hashtable ,list2 key test test-not))) + (macrolet + ((process-set-op (list1 init-res is-member-p test-form) + `(let ((res ,init-res) + (list1 ,list1)) + (do () + ((endp list1)) + (if ,(if is-member-p + test-form + `(not ,test-form)) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res))) + (if hashtable + (process-set-op ,list1 ,initial-result ,is-member-p + (nth-value 1 (gethash (apply-key key (car ,list1)) hashtable))) + (process-set-op ,list1 ,initial-result ,is-member-p + (with-set-keys (member (apply-key key (car ,list1)) list2)))))))) (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -882,7 +904,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set list2 t)) + (do-destructive-set-operation list1 list2 :initial-result list2 :is :not-element-of-set)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -891,7 +913,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set nil nil)) + (do-destructive-set-operation list1 list2 :initial-result nil :is :element-of-set)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -900,7 +922,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set nil t)) + (do-destructive-set-operation list1 list2 :initial-result nil :is :not-element-of-set)) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4542d55efe2291e2de7378… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4542d55efe2291e2de7378… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-for-sets-impl] 3 commits: Rename/refactor nprocess-set
by Raymond Toy (＠rtoy) 27 Aug '23

27 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-for-sets-impl at cmucl / cmucl Commits: 702fe16a by Raymond Toy at 2023-08-27T12:03:05-07:00 Rename/refactor nprocess-set Do the same for nprocess-set as we did for process-set, renaming it to do-destructive-set-operation. - - - - - 2a02ec67 by Raymond Toy at 2023-08-27T14:27:53-07:00 Move the process-set-body macro into do-set-operation Get rid the extra macro by moving inside the do-set-operation macro. This makes it a little neater. - - - - - 15ed5464 by Raymond Toy at 2023-08-27T14:55:27-07:00 Move the nprocess-set-body macro into do-destructive-set-operation Get rid the extra macro by moving it inside the do-destructive-set-operation macro. This makes it a little neater. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -753,17 +753,11 @@ union intersection set-difference nunion nintersection nset-difference)) -;; Main code to process a set function. INIT-RES initializes the -;; value of RES, which holds the result of the set function. -;; TEST-FORM is a form that tests whether to add the item from LIST1 -;; to RES. -(defmacro process-set-body (list1 init-res membership-test test-form) - `(let ((res ,init-res)) - (dolist (item ,list1) - (,membership-test ,test-form - (push item res))) - res)) - +;; Handle a non-destructive set operation. LIST1 and LIST2 are the +;; two arguments to the set function. INITIAL-RESULT is the value +;; used to initialize the result list. IS specifies whether the test +;; (or test-not) function implies an element of LIST1 should be +;; included in the result. (defmacro do-set-operation (list1 list2 &key initial-result is) (let ((membership-test (ecase is (:element-of-set @@ -771,11 +765,19 @@ (:not-element-of-set 'unless)))) `(let ((hashtable (list-to-hashtable ,list2 key test test-not))) - (if hashtable - (process-set-body ,list1 ,initial-result ,membership-test + (macrolet + ((process-set-op (list1 init-res member-form test-form) + `(let ((res ,init-res)) + (dolist (item ,list1) + (,member-form ,test-form + (push item res))) + res))) + + (if hashtable + (process-set-op ,list1 ,initial-result ,membership-test (nth-value 1 (gethash (apply-key key item) hashtable))) - (process-set-body ,list1 ,initial-result ,membership-test - (with-set-keys (member (apply-key key item) ,list2))))))) + (process-set-op ,list1 ,initial-result ,membership-test + (with-set-keys (member (apply-key key item) list2)))))))) ;; Convert a list to a hashtable. The hashtable does not handle ;; duplicated values in the list. Returns the hashtable. @@ -854,14 +856,14 @@ ;;; the result list. INVERT-P is T if the result of the TEST-FORM ;;; should be inverted. TEST-FORM is the form used for determining ;;; how to update the result. -(defmacro nprocess-set-body (init-res invert-p test-form) +(defmacro nprocess-set-body (list1 init-res is-member-p test-form) `(let ((res ,init-res) - (list1 list1)) + (list1 ,list1)) (do () ((endp list1)) - (if ,(if invert-p - `(not ,test-form) - test-form) + (if ,(if is-member-p + test-form + `(not ,test-form)) (steve-splice list1 res) (setq list1 (cdr list1)))) res)) @@ -870,13 +872,30 @@ ;; initializes the value of the result list. INVERT-P indicates ;; whether to invert the test-form used to determine how the result ;; should be updated. -(defmacro nprocess-set (init-res invert-p) - `(let ((hashtable (list-to-hashtable list2 key test test-not))) - (if hashtable - (nprocess-set-body ,init-res ,invert-p - (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) - (nprocess-set-body ,init-res ,invert-p - (with-set-keys (member (apply-key key (car list1)) list2)))))) +(defmacro do-destructive-set-operation (list1 list2 &key initial-result is) + (let ((is-member-p (ecase is + (:element-of-set + t) + (:not-element-of-set + nil)))) + `(let ((hashtable (list-to-hashtable ,list2 key test test-not))) + (macrolet + ((process-set-op (list1 init-res is-member-p test-form) + `(let ((res ,init-res) + (list1 ,list1)) + (do () + ((endp list1)) + (if ,(if is-member-p + test-form + `(not ,test-form)) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res))) + (if hashtable + (process-set-op ,list1 ,initial-result ,is-member-p + (nth-value 1 (gethash (apply-key key (car ,list1)) hashtable))) + (process-set-op ,list1 ,initial-result ,is-member-p + (with-set-keys (member (apply-key key (car ,list1)) list2)))))))) (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -885,7 +904,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set list2 t)) + (do-destructive-set-operation list1 list2 :initial-result list2 :is :not-element-of-set)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -894,7 +913,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set nil nil)) + (do-destructive-set-operation list1 list2 :initial-result nil :is :element-of-set)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -903,7 +922,7 @@ (if (and testp notp) (error "Test and test-not both supplied.")) - (nprocess-set nil t)) + (do-destructive-set-operation list1 list2 :initial-result nil :is :not-element-of-set)) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bd928112a03960e68d419f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bd928112a03960e68d419f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-240-clean-up-hashtable-for-sets-impl
by Raymond Toy (＠rtoy) 27 Aug '23

27 Aug '23

Raymond Toy pushed new branch issue-240-clean-up-hashtable-for-sets-impl at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-240-clean-up-hashta… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] Add comments and fix docstring.
by Raymond Toy (＠rtoy) 27 Aug '23

27 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: 8074203f by Raymond Toy at 2023-08-26T20:42:51-07:00 Add comments and fix docstring. The docstring says set-exclusive-or produces elements appearing exactly once in list1 and list2. But that's not right. The result has elements appearing in either list1 or list2 but not both. Use the text from the CLHS as the docstring. Add some comments to the code. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -906,7 +906,7 @@ (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) - "Return new list of elements appearing exactly once in LIST1 and LIST2." + "Return new list of elements appearing exactly one of LIST1 and LIST2." (declare (inline member)) (let ((result nil) (key (when key (coerce key 'function))) @@ -914,6 +914,8 @@ (test-not (if test-not (coerce test-not 'function) #'eql))) (declare (type (or function null) key) (type function test test-not)) + ;; Find the elements in list1 that do not appear in list2 and add + ;; them to the result. (let ((hashtable (list-to-hashtable list2 key test test-not))) (cond (hashtable @@ -924,6 +926,8 @@ (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) (setq result (cons elt result))))))) + ;; Now find the elements in list2 that do not appear in list1 and + ;; them to the result. (let ((hashtable (list-to-hashtable list1 key test test-not))) (cond (hashtable View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8074203fd56e40c38130f31… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8074203fd56e40c38130f31… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] Fix another typo
by Raymond Toy (＠rtoy) 27 Aug '23

27 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: 56ecb8cf by Raymond Toy at 2023-08-26T20:33:49-07:00 Fix another typo Malformed flet is fixed now. Test runs correctly. - - - - - 1 changed file: - tests/sets.lisp Changes: ===================================== tests/sets.lisp ===================================== @@ -283,20 +283,20 @@ (define-test set-exclusive-or.1 (:tag :issues) (flet - ((test min-length) - ;; From CLHS - (let ((lisp::*min-list-length-for-hashtable* min-length)) - (assert-equal '("b" "A" "b" "a") - (set-exclusive-or '(1 "a" "b") - '(1 "A" "b"))) - (assert-equal '("A" "a") - (set-exclusive-or '(1 "a" "b") - '(1 "A" "b") - :test #'equal)) - (assert-equal nil - (set-exclusive-or '(1 "a" "b") - '(1 "A" "b") - :test #'equalp)))) + ((test (min-length) + ;; From CLHS + (let ((lisp::*min-list-length-for-hashtable* min-length)) + (assert-equal '("b" "A" "b" "a") + (set-exclusive-or '(1 "a" "b") + '(1 "A" "b"))) + (assert-equal '("A" "a") + (set-exclusive-or '(1 "a" "b") + '(1 "A" "b") + :test #'equal)) + (assert-equal nil + (set-exclusive-or '(1 "a" "b") + '(1 "A" "b") + :test #'equalp))))) ;; Test the list impl by making the min length large. Then test ;; the hashtable impl with a very short min length (test 100) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/56ecb8cfbfd96a722cc710e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/56ecb8cfbfd96a722cc710e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] Clean up error in set-exclusive-or test
by Raymond Toy (＠rtoy) 26 Aug '23

26 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: 6a53d42c by Raymond Toy at 2023-08-26T16:25:01-07:00 Clean up error in set-exclusive-or test Somehow the test set-exclusive-or.1 had incorporated lots of other tests inside it. Remove the random junk. - - - - - 1 changed file: - tests/sets.lisp Changes: ===================================== tests/sets.lisp ===================================== @@ -230,238 +230,6 @@ (test 1))) -(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))) - -(define-test set-exclusive-or.1 - (:tag :issues) - ;; From CLHS - (assert-equal '("b" "A" "b" "a") - (set-exclusive-or '(1 "a" "b") - '(1 "A" "b"))) - ;; 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))) - - (define-test subsetp.hash-eq (:tag :issues) (let ((lisp::*min-list-length-for-hashtable* 2)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6a53d42ce2f1a6a8ea3b871… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6a53d42ce2f1a6a8ea3b871… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] Fix typo.
by Raymond Toy (＠rtoy) 26 Aug '23

26 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: c8f2c87d by Raymond Toy at 2023-08-25T20:12:46-07:00 Fix typo. Somehow a stray "g" got added to steve-splice. Remove it. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -842,7 +842,7 @@ ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; (defmacro steve-splice (source destination) - `(let ((temp ,source))g + `(let ((temp ,source)) (setf ,source (cdr ,source) (cdr temp) ,destination ,destination temp))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c8f2c87db5e3ab95e5371e5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c8f2c87db5e3ab95e5371e5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-255-add-sacla-tests] 2 commits: Only ignore build-* in the top-level dir
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch issue-255-add-sacla-tests at cmucl / cmucl Commits: 083a78da by Raymond Toy at 2023-08-25T15:14:06-07:00 Only ignore build-* in the top-level dir - - - - - f1ff2d63 by Raymond Toy at 2023-08-25T15:14:45-07:00 Add script to convert sacla test to lisp-unit test. - - - - - 2 changed files: - .gitignore - + sacla/build-sacla-tests.lisp Changes: ===================================== .gitignore ===================================== @@ -12,7 +12,7 @@ *.x86f *~ /test-tmp -build-* +/build-* darwin-8bit-[234] darwin-[234] linux-8bit-[234] ===================================== sacla/build-sacla-tests.lisp ===================================== @@ -0,0 +1,41 @@ +(defun get-sacla-test-files () + (let ((test-files + ;; We only want files named "must-*.lisp", using a cmucl + ;; pathname extension. + (directory "lisp/tests/must-*.lisp"))) + test-files)) + +(defun process-one-file (file) + (let* ((base-name (pathname-name file)) + (output-file (make-pathname :name (pathname-name file) + :type (pathname-type file))) + (test-base-name (symbolicate "SACLA-" (string-upcase base-name))) + (*print-case* :downcase)) + (with-open-file (output output-file + :direction :output + :if-exists :supersede) + (format *trace-output* "load-truename ~S~%" *load-truename*) + (format *trace-output* "Reading ~S~%" file) + (format *trace-output* "Writing ~S~%" output-file) + (format output "(in-package #:sacla-lisp-unit)~%") + (with-open-file (input file) + (loop for count from 1 + for sexp = (read input nil) + while sexp + do (progn + (write `(define-test ,(symbolicate test-base-name (format nil ".~d" count)) + (:tag ,(intern (string test-base-name) :keyword)) + (assert-true ,sexp)) + :stream output + :circle t + :level nil + :length nil) + (terpri output)))) + (terpri output)))) + +(defun create-lisp-unit-sacla-tests () + (let ((test-files (get-sacla-test-files))) + ;; For each test file, convert the file to a lisp-unit test file + ;; by wrapping each sexp in a define-test form. + (dolist (file test-files) + (process-one-file file)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4c44b23fcd11b67a25314b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4c44b23fcd11b67a25314b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-255-add-sacla-tests] Remove these files that were accidentally checked in
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch issue-255-add-sacla-tests at cmucl / cmucl Commits: 4c44b23f by Raymond Toy at 2023-08-25T15:10:11-07:00 Remove these files that were accidentally checked in - - - - - 1 changed file: - − sacla/must-array.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4c44b23fcd11b67a25314b9… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4c44b23fcd11b67a25314b9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-255-add-sacla-tests
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed new branch issue-255-add-sacla-tests at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-255-add-sacla-tests You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-set-exclusive-or] 3 commits: Address #240: Use hashtable for nset-diff, nunion, nintersection
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl Commits: 87e54e03 by Raymond Toy at 2023-08-25T14:15:52+00:00 Address #240: Use hashtable for nset-diff, nunion, nintersection - - - - - 4542d55e by Raymond Toy at 2023-08-25T14:16:04+00:00 Merge branch 'issue-240-add-hashtable-for-destructive-set-ops' into 'master' Address #240: Use hashtable for nset-diff, nunion, nintersection See merge request cmucl/cmucl!167 - - - - - d1bf9185 by Raymond Toy at 2023-08-25T08:34:43-07:00 Merge branch 'master' into issue-240-add-hashtable-set-exclusive-or - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -749,7 +749,9 @@ (defparameter *min-list-length-for-hashtable* 15) -(declaim (start-block list-to-hashtable union intersection set-difference)) +(declaim (start-block list-to-hashtable + union intersection set-difference + nunion nintersection nset-difference)) ;; Main code to process a set function. INIT-RES initializes the ;; value of RES, which holds the result of the set function. @@ -836,8 +838,6 @@ (process-set nil t)) -(declaim (end-block)) - ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; @@ -847,19 +847,42 @@ (cdr temp) ,destination ,destination temp))) +;;; Main body for destructive set operations. INIT-RES initializes +;;; the result list. INVERT-P is T if the result of the TEST-FORM +;;; should be inverted. TEST-FORM is the form used for determining +;;; how to update the result. +(defmacro nprocess-set-body (init-res invert-p test-form) + `(let ((res ,init-res) + (list1 list1)) + (do () + ((endp list1)) + (if ,(if invert-p + `(not ,test-form) + test-form) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + +;; Implementation of the destructive set operations. INIT-RES +;; initializes the value of the result list. INVERT-P indicates +;; whether to invert the test-form used to determine how the result +;; should be updated. +(defmacro nprocess-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (nprocess-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) + (nprocess-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key (car list1)) list2)))))) + + (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2) - (list1 list1)) - (do () - ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setf list1 (cdr list1)))) - res)) + + (nprocess-set list2 t)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -867,13 +890,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) + + (nprocess-set nil nil)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -881,14 +899,10 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) - res)) + (nprocess-set nil t)) + +(declaim (end-block)) (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) ===================================== tests/sets.lisp ===================================== @@ -88,8 +88,37 @@ :test 'eql :test-not 'eql))) - +(define-test nset-diff.1 + (:tag :issues) + ;; From CLHS + (flet + ((test1 (min-length-limit) + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list "A" "b" "C" "d")) + (lst2 (list "a" "B" "C" "d"))) + (assert-equal '("b" "A") + (nset-difference lst1 lst2 :test 'equal)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '("A") lst1)))) + (test1 100) + (test1 1))) + +(define-test nset-diff.key + (:tag :issues) + (flet + ((test (min-length-limit) + ;; From CLHS + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list '("a" . "b") '("c" . "d") '("e" . "f"))) + (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a")))) + (assert-equal '(("e" . "f") ("c" . "d")) + (nset-difference lst1 lst2 :test 'equal :key #'cdr)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '(("a" . "b") ("c" . "d")) lst1)))) + (test 100) + (test 1))) + (define-test union.hash-eql (:tag :issues) ;; For union to use hashtables by making the threshold @@ -173,6 +202,33 @@ :test 'eql :test-not 'eql))) +(define-test nunion.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 2 '(1 2) "a" "b")) + (lst2 (list 2 3 '(2 3) "B" "C"))) + (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C") + (nunion lst1 lst2)) + (assert-equal '(1 2 3 (2 3) "B" "C") + lst1)))) + (test 100) + (test 1))) + +(define-test nintersection.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")) + (lst2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))) + (assert-equal '(c b 4 1 1) + (nintersection lst1 lst2)) + (assert-equal '(1) lst1)))) + (test 100) + (test 1))) + (define-test subsetp.hash-eq (:tag :issues) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/fc0d7a8d541e5ccd95a4cc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/fc0d7a8d541e5ccd95a4cc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-240-add-hashtable-set-exclusive-or
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed new branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-240-add-hashtable-s… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Use hashtable for nset-diff, nunion, nintersection
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 87e54e03 by Raymond Toy at 2023-08-25T14:15:52+00:00 Address #240: Use hashtable for nset-diff, nunion, nintersection - - - - - 4542d55e by Raymond Toy at 2023-08-25T14:16:04+00:00 Merge branch 'issue-240-add-hashtable-for-destructive-set-ops' into 'master' Address #240: Use hashtable for nset-diff, nunion, nintersection See merge request cmucl/cmucl!167 - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -749,7 +749,9 @@ (defparameter *min-list-length-for-hashtable* 15) -(declaim (start-block list-to-hashtable union intersection set-difference)) +(declaim (start-block list-to-hashtable + union intersection set-difference + nunion nintersection nset-difference)) ;; Main code to process a set function. INIT-RES initializes the ;; value of RES, which holds the result of the set function. @@ -836,8 +838,6 @@ (process-set nil t)) -(declaim (end-block)) - ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; @@ -847,19 +847,42 @@ (cdr temp) ,destination ,destination temp))) +;;; Main body for destructive set operations. INIT-RES initializes +;;; the result list. INVERT-P is T if the result of the TEST-FORM +;;; should be inverted. TEST-FORM is the form used for determining +;;; how to update the result. +(defmacro nprocess-set-body (init-res invert-p test-form) + `(let ((res ,init-res) + (list1 list1)) + (do () + ((endp list1)) + (if ,(if invert-p + `(not ,test-form) + test-form) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + +;; Implementation of the destructive set operations. INIT-RES +;; initializes the value of the result list. INVERT-P indicates +;; whether to invert the test-form used to determine how the result +;; should be updated. +(defmacro nprocess-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (nprocess-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) + (nprocess-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key (car list1)) list2)))))) + + (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2) - (list1 list1)) - (do () - ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setf list1 (cdr list1)))) - res)) + + (nprocess-set list2 t)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -867,13 +890,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) + + (nprocess-set nil nil)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -881,14 +899,10 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) - res)) + (nprocess-set nil t)) + +(declaim (end-block)) (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) ===================================== tests/sets.lisp ===================================== @@ -88,8 +88,37 @@ :test 'eql :test-not 'eql))) - +(define-test nset-diff.1 + (:tag :issues) + ;; From CLHS + (flet + ((test1 (min-length-limit) + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list "A" "b" "C" "d")) + (lst2 (list "a" "B" "C" "d"))) + (assert-equal '("b" "A") + (nset-difference lst1 lst2 :test 'equal)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '("A") lst1)))) + (test1 100) + (test1 1))) + +(define-test nset-diff.key + (:tag :issues) + (flet + ((test (min-length-limit) + ;; From CLHS + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list '("a" . "b") '("c" . "d") '("e" . "f"))) + (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a")))) + (assert-equal '(("e" . "f") ("c" . "d")) + (nset-difference lst1 lst2 :test 'equal :key #'cdr)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '(("a" . "b") ("c" . "d")) lst1)))) + (test 100) + (test 1))) + (define-test union.hash-eql (:tag :issues) ;; For union to use hashtables by making the threshold @@ -173,6 +202,33 @@ :test 'eql :test-not 'eql))) +(define-test nunion.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 2 '(1 2) "a" "b")) + (lst2 (list 2 3 '(2 3) "B" "C"))) + (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C") + (nunion lst1 lst2)) + (assert-equal '(1 2 3 (2 3) "B" "C") + lst1)))) + (test 100) + (test 1))) + +(define-test nintersection.1 + (:tag :issues) + (flet + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")) + (lst2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))) + (assert-equal '(c b 4 1 1) + (nintersection lst1 lst2)) + (assert-equal '(1) lst1)))) + (test 100) + (test 1))) + (define-test subsetp.hash-eq (:tag :issues) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/39817da21c213415dd494c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/39817da21c213415dd494c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] 4 commits: Fix warning that SIGNED-CHAR is also exported from C-CALL
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 427aaa31 by Raymond Toy at 2023-08-22T19:50:31-07:00 Fix warning that SIGNED-CHAR is also exported from C-CALL When we added `c-call:signed-char`, we forgot to also add it to the package exports list for the `c-call` package. Add it to get rid of the compiler warning. - - - - - 9581820a by Raymond Toy at 2023-08-25T13:32:42+00:00 Address #240: Clean up hashtable implementation of set functions - - - - - 39817da2 by Raymond Toy at 2023-08-25T13:32:51+00:00 Merge branch 'issue-240-clean-up-hashtable-impl' into 'master' Address #240: Clean up hashtable implementation of set functions See merge request cmucl/cmucl!168 - - - - - 51df6ed9 by Raymond Toy at 2023-08-25T06:55:36-07:00 Merge branch 'master' into issue-240-add-hashtable-for-destructive-set-ops - - - - - 2 changed files: - src/code/exports.lisp - src/code/list.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -169,6 +169,7 @@ (defpackage "C-CALL" (:import-from "COMMON-LISP" "CHAR" "FLOAT") (:export "C-STRING" "CHAR" "DOUBLE" "FLOAT" "INT" "LONG" "SHORT" + "SIGNED-CHAR" "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-SHORT" "LONG-LONG" "UNSIGNED-LONG-LONG" "VOID")) ===================================== src/code/list.lisp ===================================== @@ -752,6 +752,28 @@ (declaim (start-block list-to-hashtable union intersection set-difference nunion nintersection nset-difference)) + +;; Main code to process a set function. INIT-RES initializes the +;; value of RES, which holds the result of the set function. +;; TEST-FORM is a form that tests whether to add the item from LIST1 +;; to RES. +(defmacro process-set-body (init-res invert-p test-form) + `(let ((res ,init-res)) + (dolist (item list1) + (when ,(if invert-p + `(not ,test-form) + test-form) + (push item res))) + res)) + +(defmacro process-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key item) list2)))))) + ;; 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) @@ -793,17 +815,7 @@ (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)) + (process-set list2 t)) (defun intersection (list1 list2 &key key @@ -812,20 +824,7 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (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))))) + (process-set nil nil)) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -836,23 +835,8 @@ (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))))) + (process-set nil t)) + ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f305c0ee3440ffc83756e5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f305c0ee3440ffc83756e5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #240: Clean up hashtable implementation of set functions
by Raymond Toy (＠rtoy) 25 Aug '23

25 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9581820a by Raymond Toy at 2023-08-25T13:32:42+00:00 Address #240: Clean up hashtable implementation of set functions - - - - - 39817da2 by Raymond Toy at 2023-08-25T13:32:51+00:00 Merge branch 'issue-240-clean-up-hashtable-impl' into 'master' Address #240: Clean up hashtable implementation of set functions See merge request cmucl/cmucl!168 - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -750,6 +750,28 @@ 15) (declaim (start-block list-to-hashtable union intersection set-difference)) + +;; Main code to process a set function. INIT-RES initializes the +;; value of RES, which holds the result of the set function. +;; TEST-FORM is a form that tests whether to add the item from LIST1 +;; to RES. +(defmacro process-set-body (init-res invert-p test-form) + `(let ((res ,init-res)) + (dolist (item list1) + (when ,(if invert-p + `(not ,test-form) + test-form) + (push item res))) + res)) + +(defmacro process-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key item) list2)))))) + ;; 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) @@ -791,17 +813,7 @@ (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)) + (process-set list2 t)) (defun intersection (list1 list2 &key key @@ -810,20 +822,7 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (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))))) + (process-set nil nil)) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -834,23 +833,8 @@ (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))))) + (process-set nil t)) + (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/427aaa311105943b771698… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/427aaa311105943b771698… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Fix warning that SIGNED-CHAR is also exported from C-CALL
by Raymond Toy (＠rtoy) 23 Aug '23

23 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 427aaa31 by Raymond Toy at 2023-08-22T19:50:31-07:00 Fix warning that SIGNED-CHAR is also exported from C-CALL When we added `c-call:signed-char`, we forgot to also add it to the package exports list for the `c-call` package. Add it to get rid of the compiler warning. - - - - - 1 changed file: - src/code/exports.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -169,6 +169,7 @@ (defpackage "C-CALL" (:import-from "COMMON-LISP" "CHAR" "FLOAT") (:export "C-STRING" "CHAR" "DOUBLE" "FLOAT" "INT" "LONG" "SHORT" + "SIGNED-CHAR" "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-SHORT" "LONG-LONG" "UNSIGNED-LONG-LONG" "VOID")) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/427aaa311105943b771698b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/427aaa311105943b771698b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-impl] 2 commits: Refactor the body of set ops
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-impl at cmucl / cmucl Commits: e6f1cc3e by Raymond Toy at 2023-08-22T16:30:18-07:00 Refactor the body of set ops The set functions have basically exactly the same body with the only difference being how the result list is initialized; the test form used to determine how the result list is updated; and whether a hashtable is used or not. Place all of the common stuff in the macro PROCESS-SET and rename the old PROCESS-SET to PROCESS-SET-BODY. - - - - - b4d8cfea by Raymond Toy at 2023-08-22T16:31:34-07:00 Remove commented out code - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -755,13 +755,23 @@ ;; value of RES, which holds the result of the set function. ;; TEST-FORM is a form that tests whether to add the item from LIST1 ;; to RES. -(defmacro process-set (init-res test-form) +(defmacro process-set-body (init-res invert-p test-form) `(let ((res ,init-res)) (dolist (item list1) - (when ,test-form + (when ,(if invert-p + `(not ,test-form) + test-form) (push item res))) res)) +(defmacro process-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key item) list2)))))) + ;; 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) @@ -803,10 +813,7 @@ (declare (inline member)) (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) - (let ((hashtable (list-to-hashtable list2 key test test-not))) - (if hashtable - (process-set list2 (not (nth-value 1 (gethash (apply-key key item) hashtable)))) - (process-set list2 (not (with-set-keys (member (apply-key key item) list2))))))) + (process-set list2 t)) (defun intersection (list1 list2 &key key @@ -815,11 +822,7 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (if hashtable - (process-set nil (nth-value 1 (gethash (apply-key key item) hashtable))) - (process-set nil (with-set-keys (member (apply-key key item) list2)))))) + (process-set nil nil)) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -830,11 +833,7 @@ (when (null list2) (return-from set-difference list1)) - (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (if hashtable - (process-set nil (not (nth-value 1 (gethash (apply-key key item) hashtable)))) - (process-set nil (not (with-set-keys (member (apply-key key item) list2))))))) + (process-set nil t)) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d046100fe1e8dc2aa9e2b5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d046100fe1e8dc2aa9e2b5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] Refactor the body of destructive set ops
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: f305c0ee by Raymond Toy at 2023-08-22T15:38:51-07:00 Refactor the body of destructive set ops The destructive set functions have basically exactly the same body with the only difference being how the result list is initialized; the test form used to determine how the result list is updated; and whether a hashtable is used or not. Place all of the common stuff in the macro NPROCESS-SET and rename the old NPROCESS-SET to NPROCESS-SET-BODY. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -863,47 +863,42 @@ (cdr temp) ,destination ,destination temp))) -;;; Main processing for destructive set operations. Like PROCESS-SET with same args, -;;; but for destructive operations. -(defmacro nprocess-set (init-res test-form) +;;; Main body for destructive set operations. INIT-RES initializes +;;; the result list. INVERT-P is T if the result of the TEST-FORM +;;; should be inverted. TEST-FORM is the form used for determining +;;; how to update the result. +(defmacro nprocess-set-body (init-res invert-p test-form) `(let ((res ,init-res) (list1 list1)) (do () ((endp list1)) - (if ,test-form + (if ,(if invert-p + `(not ,test-form) + test-form) (steve-splice list1 res) (setq list1 (cdr list1)))) res)) +;; Implementation of the destructive set operations. INIT-RES +;; initializes the value of the result list. INVERT-P indicates +;; whether to invert the test-form used to determine how the result +;; should be updated. +(defmacro nprocess-set (init-res invert-p) + `(let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (nprocess-set-body ,init-res ,invert-p + (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) + (nprocess-set-body ,init-res ,invert-p + (with-set-keys (member (apply-key key (car list1)) list2)))))) + (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - - (let (#+nil - (res list2) - (hashtable (list-to-hashtable list2 key test test-not)) - #+nil - (list1 list1)) - (if hashtable - (nprocess-set list2 (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (nprocess-set list2 (not (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (macrolet - ((process (test-form) - `(do () - ((endp list1)) - (if (not ,test-form) - (steve-splice list1 res) - (setf list1 (cdr list1)))))) - (cond - (hashtable - (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (t - (process (with-set-keys (member (apply-key key (car list1)) list2))))) - res))) + + (nprocess-set list2 t)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -911,26 +906,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let (#+nil - (res nil) - (hashtable (list-to-hashtable list2 key test test-not)) - #+nil - (list1 list1)) - (if hashtable - (nprocess-set nil (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) - (nprocess-set nil (with-set-keys (member (apply-key key (car list1)) list2)))) - #+nil - (macrolet - ((process (test-form) - `(do () ((endp list1)) - (if ,test-form - (steve-splice list1 res) - (setq list1 (Cdr list1)))))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (t - (process (with-set-keys (member (apply-key key (car list1)) list2))))) - res))) + + (nprocess-set nil nil)) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -938,26 +915,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let (#+nil - (res nil) - (hashtable (list-to-hashtable list2 key test test-not)) - #+nil - (list1 list1)) - (if hashtable - (nprocess-set nil (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (nprocess-set nil (not (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (macrolet - ((process (test-form) - `(do () ((endp list1)) - (if (not ,test-form) - (steve-splice list1 res) - (setq list1 (cdr list1)))))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) - (t - (process (with-set-keys (member (apply-key key (car list1)) list2))))) - res))) + + (nprocess-set nil t)) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f305c0ee3440ffc83756e59… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f305c0ee3440ffc83756e59… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] Add macro NPROCESS-SET for destructive set ops
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 6b3621ac by Raymond Toy at 2023-08-22T15:13:03-07:00 Add macro NPROCESS-SET for destructive set ops The destructive set functions all have basically the same body. The only difference is how to initialize the result list and the test function. Capture this similarity in the macro NPROCESS-SET. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -863,15 +863,34 @@ (cdr temp) ,destination ,destination temp))) +;;; Main processing for destructive set operations. Like PROCESS-SET with same args, +;;; but for destructive operations. +(defmacro nprocess-set (init-res test-form) + `(let ((res ,init-res) + (list1 list1)) + (do () + ((endp list1)) + (if ,test-form + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + + (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2) + (let (#+nil + (res list2) (hashtable (list-to-hashtable list2 key test test-not)) + #+nil (list1 list1)) + (if hashtable + (nprocess-set list2 (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) + (nprocess-set list2 (not (with-set-keys (member (apply-key key (car list1)) list2))))) + #+nil (macrolet ((process (test-form) `(do () @@ -892,9 +911,15 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) + (let (#+nil + (res nil) (hashtable (list-to-hashtable list2 key test test-not)) - (list1 list1)) + #+nil + (list1 list1)) + (if hashtable + (nprocess-set nil (nth-value 1 (gethash (apply-key key (car list1)) hashtable))) + (nprocess-set nil (with-set-keys (member (apply-key key (car list1)) list2)))) + #+nil (macrolet ((process (test-form) `(do () ((endp list1)) @@ -913,9 +938,15 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil) + (let (#+nil + (res nil) (hashtable (list-to-hashtable list2 key test test-not)) - (list1 list1)) + #+nil + (list1 list1)) + (if hashtable + (nprocess-set nil (not (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) + (nprocess-set nil (not (with-set-keys (member (apply-key key (car list1)) list2))))) + #+nil (macrolet ((process (test-form) `(do () ((endp list1)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b3621aca7ff60f1e0d7917… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b3621aca7ff60f1e0d7917… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-impl] Add macro PROCESS-SET to handle processing of set functions
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-impl at cmucl / cmucl Commits: d046100f by Raymond Toy at 2023-08-22T14:39:12-07:00 Add macro PROCESS-SET to handle processing of set functions All of the (non-destructive) set functions have basically the same processing code. The only difference is how to initialize the result and the test used to determine if an item is to be added to the result. We encapsulate this similarity in the macro `PROCESS-SET` and use it in `union`, `intersection`, and `set-difference`. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -750,6 +750,18 @@ 15) (declaim (start-block list-to-hashtable union intersection set-difference)) + +;; Main code to process a set function. INIT-RES initializes the +;; value of RES, which holds the result of the set function. +;; TEST-FORM is a form that tests whether to add the item from LIST1 +;; to RES. +(defmacro process-set (init-res test-form) + `(let ((res ,init-res)) + (dolist (item list1) + (when ,test-form + (push item res))) + res)) + ;; 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) @@ -791,18 +803,10 @@ (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))) - (macrolet - ((process (test-form) - `(dolist (item list1) - (unless ,test-form - (push item res))))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key item) hashtable)))) - (t - (process (with-set-keys (member (apply-key key item) list2))))) - res))) + (let ((hashtable (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set list2 (not (nth-value 1 (gethash (apply-key key item) hashtable)))) + (process-set list2 (not (with-set-keys (member (apply-key key item) list2))))))) (defun intersection (list1 list2 &key key @@ -812,18 +816,10 @@ (if (and testp notp) (error "Test and test-not both supplied.")) (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (macrolet - ((process (test-form) - `(let ((res nil)) - (dolist (item list1) - (if ,test-form - (push item res))) - res))) - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key item) hashtable)))) - (t - (process (with-set-keys (member (apply-key key item) list2)))))))) + (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set nil (nth-value 1 (gethash (apply-key key item) hashtable))) + (process-set nil (with-set-keys (member (apply-key key item) list2)))))) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." @@ -835,21 +831,10 @@ (return-from set-difference list1)) (let ((hashtable - (list-to-hashtable list2 key test test-not))) - (macrolet - ((process (test-form) - `(let ((res nil)) - (dolist (item list1) - (if (not ,test-form) - (push item res))) - res))) - - (cond (hashtable - (process (nth-value 1 (gethash (apply-key key item) hashtable)))) - (t - ;; Default implementation because we didn't create the hash - ;; table. - (process (with-set-keys (member (apply-key key item) list2)))))))) + (list-to-hashtable list2 key test test-not))) + (if hashtable + (process-set nil (not (nth-value 1 (gethash (apply-key key item) hashtable)))) + (process-set nil (not (with-set-keys (member (apply-key key item) list2))))))) (declaim (end-block)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d046100fe1e8dc2aa9e2b53… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d046100fe1e8dc2aa9e2b53… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] Add destructive functions to start-block
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 8f262bac by Raymond Toy at 2023-08-22T13:01:02-07:00 Add destructive functions to start-block We forgot to add `nunion`, `nintersection`, and `nset-difference` to the `start-block` to make the available. Without this, they're not globally defined. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -749,7 +749,9 @@ (defparameter *min-list-length-for-hashtable* 15) -(declaim (start-block list-to-hashtable union intersection set-difference)) +(declaim (start-block list-to-hashtable + union intersection set-difference + nunion nintersection nset-difference)) ;; 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) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8f262bac2129c7d8532c3df… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8f262bac2129c7d8532c3df… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] Block compile destructive ops too
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 0d14e908 by Raymond Toy at 2023-08-22T07:19:14-07:00 Block compile destructive ops too And remove old commented-out code. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -852,8 +852,6 @@ (push item res))) res))))) -(declaim (end-block)) - ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; @@ -905,11 +903,6 @@ (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) (t (process (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) res))) (defun nset-difference (list1 list2 &key key @@ -931,13 +924,10 @@ (process (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))) (t (process (with-set-keys (member (apply-key key (car list1)) list2))))) - #+nil - (do () ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) res))) +(declaim (end-block)) + (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Return new list of elements appearing exactly once in LIST1 and LIST2." View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0d14e90845074a14424fec7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0d14e90845074a14424fec7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] 3 commits: Fix #253: Block-compile list-to-hashtable and callers
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: afaeb420 by Raymond Toy at 2023-08-22T14:00:25+00:00 Fix #253: Block-compile list-to-hashtable and callers - - - - - a5b2c0f8 by Raymond Toy at 2023-08-22T14:02:24+00:00 Merge branch 'issue-253-block-compile-list-to-hashtable' into 'master' Fix #253: Block-compile list-to-hashtable and callers Closes #253 See merge request cmucl/cmucl!166 - - - - - 3fb1adf8 by Raymond Toy at 2023-08-22T07:14:56-07:00 Merge branch 'master' into issue-240-add-hashtable-for-destructive-set-ops - - - - - 2 changed files: - src/code/list.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/list.lisp ===================================== @@ -749,6 +749,7 @@ (defparameter *min-list-length-for-hashtable* 15) +(declaim (start-block list-to-hashtable union intersection set-difference)) ;; 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) @@ -802,6 +803,57 @@ (push item res))))) res)) + +(defun intersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Returns the intersection of list1 and list2." + (declare (inline member)) + (if (and testp notp) + (error "Test and test-not both supplied.")) + (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 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.")) + ;; 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))))) + +(declaim (end-block)) + ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; @@ -834,28 +886,6 @@ (process (with-set-keys (member (apply-key key (car list1)) list2))))) res))) - -(defun intersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) - "Returns the intersection of list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (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)) "Destructively returns the intersection of list1 and list2." @@ -882,33 +912,6 @@ (setq list1 (Cdr list1)))) res))) -(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.")) - ;; 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)) "Destructively returns the elements of list1 which are not in list2." @@ -935,7 +938,6 @@ (setq list1 (cdr list1)))) res))) - (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Return new list of elements appearing exactly once in LIST1 and LIST2." ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3216,19 +3216,19 @@ msgid "Test and test-not both supplied." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the union list1 and list2." +msgid "Returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the intersection of list1 and list2." +msgid "Returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the intersection of list1 and list2." +msgid "Destructively returns the union list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the elements of list1 which are not in list2." +msgid "Destructively returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/260b94a55db82b20489b41… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/260b94a55db82b20489b41… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-impl] 5 commits: Address #240: Speed up subsetp with a hashtable
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-impl at cmucl / cmucl Commits: 0b497d8c by Raymond Toy at 2023-08-21T20:15:07+00:00 Address #240: Speed up subsetp with a hashtable - - - - - bfae1626 by Raymond Toy at 2023-08-21T20:15:21+00:00 Merge branch 'issue-240-subsetp-with-hash-table' into 'master' Address #240: Speed up subsetp with a hashtable Closes #240 See merge request cmucl/cmucl!164 - - - - - afaeb420 by Raymond Toy at 2023-08-22T14:00:25+00:00 Fix #253: Block-compile list-to-hashtable and callers - - - - - a5b2c0f8 by Raymond Toy at 2023-08-22T14:02:24+00:00 Merge branch 'issue-253-block-compile-list-to-hashtable' into 'master' Fix #253: Block-compile list-to-hashtable and callers Closes #253 See merge request cmucl/cmucl!166 - - - - - 97b6cca7 by Raymond Toy at 2023-08-22T07:07:49-07:00 Merge branch 'master' into issue-240-clean-up-hashtable-impl - - - - - 4 changed files: - src/code/list.lisp - src/code/type.lisp - src/i18n/locale/cmucl.pot - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -749,6 +749,7 @@ (defparameter *min-list-length-for-hashtable* 15) +(declaim (start-block list-to-hashtable union intersection set-difference)) ;; 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) @@ -803,29 +804,6 @@ (process (with-set-keys (member (apply-key key item) list2))))) 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. -;;; -(defmacro steve-splice (source destination) - `(let ((temp ,source)) - (setf ,source (cdr ,source) - (cdr temp) ,destination - ,destination temp))) - -(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) - "Destructively returns the union list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res list2) - (list1 list1)) - (do () - ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setf list1 (cdr list1)))) - res)) - (defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -847,20 +825,6 @@ (t (process (with-set-keys (member (apply-key key item) list2)))))))) -(defun nintersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) - "Destructively returns the intersection of list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) - (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)) @@ -888,6 +852,45 @@ (process (with-set-keys (member (apply-key key item) list2)))))))) +(declaim (end-block)) + +;;; Destination and source are setf-able and many-evaluable. Sets the source +;;; to the cdr, and "conses" the 1st elt of source to destination. +;;; +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (cdr ,source) + (cdr temp) ,destination + ,destination temp))) + +(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + "Destructively returns the union list1 and list2." + (declare (inline member)) + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res list2) + (list1 list1)) + (do () + ((endp list1)) + (if (not (with-set-keys (member (apply-key key (car list1)) list2))) + (steve-splice list1 res) + (setf list1 (cdr list1)))) + res)) + +(defun nintersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively returns the intersection of list1 and list2." + (declare (inline member)) + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res nil) + (list1 list1)) + (do () ((endp list1)) + (if (with-set-keys (member (apply-key key (car list1)) list2)) + (steve-splice list1 res) + (setq list1 (Cdr list1)))) + res)) + (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the elements of list1 which are not in list2." @@ -989,14 +992,69 @@ (rplacd splicex (cdr x))) (setq splicex x))))) +(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 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) + (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)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (return-from subsetp nil))) - T) - + (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 when it's safe to use hash tables for SUBSETP. + (multiple-value-bind (hashtable shorter-list) + (when t + (shorter-list-to-hashtable list1 list2 key test test-not)) + (cond (hashtable + (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 ===================================== 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 ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1155,6 +1155,13 @@ msgid "" " affects array types." msgstr "" +#: src/code/type.lisp +msgid "" +"The minimum length of either list argument for subsetp where a\n" +" hashtable is used to speed up processing instead of using a basic\n" +" list implementation. This value was determined by experimentation." +msgstr "" + #: src/code/type.lisp msgid "Subtypep is illegal on this type:~% ~S" msgstr "" @@ -3209,19 +3216,19 @@ msgid "Test and test-not both supplied." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the union list1 and list2." +msgid "Returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the intersection of list1 and list2." +msgid "Returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the intersection of list1 and list2." +msgid "Destructively returns the union list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the elements of list1 which are not in list2." +msgid "Destructively returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp ===================================== 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/-/compare/ce2eadfcb1f890cd1c96b6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ce2eadfcb1f890cd1c96b6… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #253: Block-compile list-to-hashtable and callers
by Raymond Toy (＠rtoy) 22 Aug '23

22 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: afaeb420 by Raymond Toy at 2023-08-22T14:00:25+00:00 Fix #253: Block-compile list-to-hashtable and callers - - - - - a5b2c0f8 by Raymond Toy at 2023-08-22T14:02:24+00:00 Merge branch 'issue-253-block-compile-list-to-hashtable' into 'master' Fix #253: Block-compile list-to-hashtable and callers Closes #253 See merge request cmucl/cmucl!166 - - - - - 2 changed files: - src/code/list.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/list.lisp ===================================== @@ -749,6 +749,7 @@ (defparameter *min-list-length-for-hashtable* 15) +(declaim (start-block list-to-hashtable union intersection set-difference)) ;; 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) @@ -802,29 +803,6 @@ (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. -;;; -(defmacro steve-splice (source destination) - `(let ((temp ,source)) - (setf ,source (cdr ,source) - (cdr temp) ,destination - ,destination temp))) - -(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) - "Destructively returns the union list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res list2) - (list1 list1)) - (do () - ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setf list1 (cdr list1)))) - res)) - (defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) @@ -847,20 +825,6 @@ (push elt res))) res))))) -(defun nintersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) - "Destructively returns the intersection of list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) - (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)) @@ -888,6 +852,45 @@ (push item res))) res))))) +(declaim (end-block)) + +;;; Destination and source are setf-able and many-evaluable. Sets the source +;;; to the cdr, and "conses" the 1st elt of source to destination. +;;; +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (cdr ,source) + (cdr temp) ,destination + ,destination temp))) + +(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + "Destructively returns the union list1 and list2." + (declare (inline member)) + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res list2) + (list1 list1)) + (do () + ((endp list1)) + (if (not (with-set-keys (member (apply-key key (car list1)) list2))) + (steve-splice list1 res) + (setf list1 (cdr list1)))) + res)) + +(defun nintersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively returns the intersection of list1 and list2." + (declare (inline member)) + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res nil) + (list1 list1)) + (do () ((endp list1)) + (if (with-set-keys (member (apply-key key (car list1)) list2)) + (steve-splice list1 res) + (setq list1 (Cdr list1)))) + res)) + (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the elements of list1 which are not in list2." ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3216,19 +3216,19 @@ msgid "Test and test-not both supplied." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the union list1 and list2." +msgid "Returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the intersection of list1 and list2." +msgid "Returns the elements of list1 which are not in list2." msgstr "" #: src/code/list.lisp -msgid "Destructively returns the intersection of list1 and list2." +msgid "Destructively returns the union list1 and list2." msgstr "" #: src/code/list.lisp -msgid "Returns the elements of list1 which are not in list2." +msgid "Destructively returns the intersection of list1 and list2." msgstr "" #: src/code/list.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bfae1626b04fcf606a4a2d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bfae1626b04fcf606a4a2d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] Fix up some tests so they run and pass.
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 260b94a5 by Raymond Toy at 2023-08-21T16:06:08-07:00 Fix up some tests so they run and pass. - - - - - 1 changed file: - tests/sets.lisp Changes: ===================================== tests/sets.lisp ===================================== @@ -90,35 +90,34 @@ (define-test nset-diff.1 - (:tags :issues) + (:tag :issues) ;; From CLHS (flet - ((test1) - (let ((lst1 (list "A" "b" "C" "d")) - (lst2 (list "a" "B" "C" "d"))) - (assert-equal '("b" "A") - (nset-difference lst1 lst2 :test 'equal)) - ;; This isn't specified by the CLHS, but it is what we do. - (assert-equal '("A") lst1))) - (test1) - - (let ((lisp::*min-list-length-for-hashtable* 1)) - (test1)))) + ((test1 (min-length-limit) + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list "A" "b" "C" "d")) + (lst2 (list "a" "B" "C" "d"))) + (assert-equal '("b" "A") + (nset-difference lst1 lst2 :test 'equal)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '("A") lst1)))) + (test1 100) + (test1 1))) (define-test nset-diff.key - (:tags :issues) + (:tag :issues) (flet - ((test) - ;; From CLHS - (let ((lst1 (list '("a" . "b") '("c" . "d") '("e" . "f"))) - (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a")))) - (assert-equal '(("e" . "f" ("c" . "d"))) - (nset-difference lst1 lst2 :test 'equal :key #'cdr)) - ;; This isn't specified by the CLHS, but it is what we do. - (assert-equal '(("a" . "b") ("c" . "d")) lst1))) - (test) - (let ((lisp::*min-list-length-for-hashtable* 1)) - (test)))) + ((test (min-length-limit) + ;; From CLHS + (let ((lisp::*min-list-length-for-hashtable* min-length-limit) + (lst1 (list '("a" . "b") '("c" . "d") '("e" . "f"))) + (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a")))) + (assert-equal '(("e" . "f") ("c" . "d")) + (nset-difference lst1 lst2 :test 'equal :key #'cdr)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '(("a" . "b") ("c" . "d")) lst1)))) + (test 100) + (test 1))) (define-test union.hash-eql (:tag :issues) @@ -206,29 +205,29 @@ (define-test nunion.1 (:tag :issues) (flet - ((test) - (let ((lst1 (list 1 2 '(1 2) "a" "b")) - (lst2 (list 2 3 '(2 3) "B" "C"))) - (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C") - (nunion lst1 lst2)) - (assert-equal '(1 2 3 (2 3) "B" "C") - lst1))) - (test) - (let ((lisp::*min-list-length-for-hashtable* 1)) - (test)))) + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 2 '(1 2) "a" "b")) + (lst2 (list 2 3 '(2 3) "B" "C"))) + (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C") + (nunion lst1 lst2)) + (assert-equal '(1 2 3 (2 3) "B" "C") + lst1)))) + (test 100) + (test 1))) (define-test nintersection.1 (:tag :issues) (flet - ((test) - (let ((lst1 (list 1 1 2 3 4 a b c "A" "B" "C" "d")) - (lst2 (list 1 4 5 b c d "a" "B" "c" "D"))) - (assert-equal '(c b 4 1 1) - (nintersection lst1 lst2)) - (assert-equal '(1) lst1))) - (test) - (let ((lisp::*min-list-length-for-hashtable* 1)) - (test)))) + ((test (min-list-length) + (let ((lisp::*min-list-length-for-hashtable* min-list-length) + (lst1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")) + (lst2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))) + (assert-equal '(c b 4 1 1) + (nintersection lst1 lst2)) + (assert-equal '(1) lst1)))) + (test 100) + (test 1))) (define-test subsetp.hash-eq View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/260b94a55db82b20489b41f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/260b94a55db82b20489b41f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] 3 commits: Address #240: Speed up subsetp with a hashtable
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 0b497d8c by Raymond Toy at 2023-08-21T20:15:07+00:00 Address #240: Speed up subsetp with a hashtable - - - - - bfae1626 by Raymond Toy at 2023-08-21T20:15:21+00:00 Merge branch 'issue-240-subsetp-with-hash-table' into 'master' Address #240: Speed up subsetp with a hashtable Closes #240 See merge request cmucl/cmucl!164 - - - - - 84d77f51 by Raymond Toy at 2023-08-21T15:54:30-07:00 Merge branch 'master' into issue-240-add-hashtable-for-destructive-set-ops - - - - - 4 changed files: - src/code/list.lisp - src/code/type.lisp - src/i18n/locale/cmucl.pot - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -1022,14 +1022,69 @@ (rplacd splicex (cdr x))) (setq splicex x))))) +(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 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) + (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)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (return-from subsetp nil))) - T) + (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 when it's safe to use hash tables for SUBSETP. + (multiple-value-bind (hashtable shorter-list) + (when t + (shorter-list-to-hashtable list1 list2 key test test-not)) + (cond (hashtable + (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 ===================================== 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 ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1155,6 +1155,13 @@ msgid "" " affects array types." msgstr "" +#: src/code/type.lisp +msgid "" +"The minimum length of either list argument for subsetp where a\n" +" hashtable is used to speed up processing instead of using a basic\n" +" list implementation. This value was determined by experimentation." +msgstr "" + #: src/code/type.lisp msgid "Subtypep is illegal on this type:~% ~S" msgstr "" ===================================== tests/sets.lisp ===================================== @@ -280,4 +280,3 @@ '(3 4) :test 'eql :test-not 'equal))) ->>>>>>> Stashed changes View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/792673c330f128f0944c46… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/792673c330f128f0944c46… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-add-hashtable-for-destructive-set-ops] Add tests for destructive functions.
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl Commits: 792673c3 by Raymond Toy at 2023-08-21T13:58:36-07:00 Add tests for destructive functions. - - - - - 1 changed file: - tests/sets.lisp Changes: ===================================== tests/sets.lisp ===================================== @@ -88,8 +88,38 @@ :test 'eql :test-not 'eql))) - +(define-test nset-diff.1 + (:tags :issues) + ;; From CLHS + (flet + ((test1) + (let ((lst1 (list "A" "b" "C" "d")) + (lst2 (list "a" "B" "C" "d"))) + (assert-equal '("b" "A") + (nset-difference lst1 lst2 :test 'equal)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '("A") lst1))) + (test1) + + (let ((lisp::*min-list-length-for-hashtable* 1)) + (test1)))) + +(define-test nset-diff.key + (:tags :issues) + (flet + ((test) + ;; From CLHS + (let ((lst1 (list '("a" . "b") '("c" . "d") '("e" . "f"))) + (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a")))) + (assert-equal '(("e" . "f" ("c" . "d"))) + (nset-difference lst1 lst2 :test 'equal :key #'cdr)) + ;; This isn't specified by the CLHS, but it is what we do. + (assert-equal '(("a" . "b") ("c" . "d")) lst1))) + (test) + (let ((lisp::*min-list-length-for-hashtable* 1)) + (test)))) + (define-test union.hash-eql (:tag :issues) ;; For union to use hashtables by making the threshold @@ -172,3 +202,82 @@ '(3 4) :test 'eql :test-not 'eql))) + +(define-test nunion.1 + (:tag :issues) + (flet + ((test) + (let ((lst1 (list 1 2 '(1 2) "a" "b")) + (lst2 (list 2 3 '(2 3) "B" "C"))) + (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C") + (nunion lst1 lst2)) + (assert-equal '(1 2 3 (2 3) "B" "C") + lst1))) + (test) + (let ((lisp::*min-list-length-for-hashtable* 1)) + (test)))) + +(define-test nintersection.1 + (:tag :issues) + (flet + ((test) + (let ((lst1 (list 1 1 2 3 4 a b c "A" "B" "C" "d")) + (lst2 (list 1 4 5 b c d "a" "B" "c" "D"))) + (assert-equal '(c b 4 1 1) + (nintersection lst1 lst2)) + (assert-equal '(1) lst1))) + (test) + (let ((lisp::*min-list-length-for-hashtable* 1)) + (test)))) + + +(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))) +>>>>>>> Stashed changes View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/792673c330f128f0944c462… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/792673c330f128f0944c462… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-clean-up-hashtable-impl] Undo inadvertent indentation change.
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch issue-240-clean-up-hashtable-impl at cmucl / cmucl Commits: ce2eadfc by Raymond Toy at 2023-08-21T13:30:44-07:00 Undo inadvertent indentation change. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -828,7 +828,7 @@ (defun intersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (test #'eql testp) (test-not nil notp)) "Returns the intersection of list1 and list2." (declare (inline member)) (if (and testp notp) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ce2eadfcb1f890cd1c96b6a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ce2eadfcb1f890cd1c96b6a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-240-clean-up-hashtable-impl
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed new branch issue-240-clean-up-hashtable-impl at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-240-clean-up-hashta… 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 subsetp with a hashtable
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 0b497d8c by Raymond Toy at 2023-08-21T20:15:07+00:00 Address #240: Speed up subsetp with a hashtable - - - - - bfae1626 by Raymond Toy at 2023-08-21T20:15:21+00:00 Merge branch 'issue-240-subsetp-with-hash-table' into 'master' Address #240: Speed up subsetp with a hashtable Closes #240 See merge request cmucl/cmucl!164 - - - - - 4 changed files: - src/code/list.lisp - src/code/type.lisp - src/i18n/locale/cmucl.pot - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -989,14 +989,69 @@ (rplacd splicex (cdr x))) (setq splicex x))))) +(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 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) + (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)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (return-from subsetp nil))) - T) + (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 when it's safe to use hash tables for SUBSETP. + (multiple-value-bind (hashtable shorter-list) + (when t + (shorter-list-to-hashtable list1 list2 key test test-not)) + (cond (hashtable + (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 ===================================== 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 ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1155,6 +1155,13 @@ msgid "" " affects array types." msgstr "" +#: src/code/type.lisp +msgid "" +"The minimum length of either list argument for subsetp where a\n" +" hashtable is used to speed up processing instead of using a basic\n" +" list implementation. This value was determined by experimentation." +msgstr "" + #: src/code/type.lisp msgid "Subtypep is illegal on this type:~% ~S" msgstr "" ===================================== 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/-/compare/eab9b8765cc37e24da1e97… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/eab9b8765cc37e24da1e97… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-240-add-hashtable-for-destructive-set-ops
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed new branch issue-240-add-hashtable-for-destructive-set-ops at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-240-add-hashtable-f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-253-block-compile-list-to-hashtable
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed new branch issue-253-block-compile-list-to-hashtable at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-253-block-compile-l… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #252: Add script to run ansi-tests
by Raymond Toy (＠rtoy) 21 Aug '23

21 Aug '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: f9ccc188 by Raymond Toy at 2023-08-21T18:03:25+00:00 Fix #252: Add script to run ansi-tests - - - - - eab9b876 by Raymond Toy at 2023-08-21T18:04:16+00:00 Merge branch 'issue-252-script-to-run-ansi-tests' into 'master' Fix #252: Add script to run ansi-tests Closes #252 See merge request cmucl/cmucl!165 - - - - - 3 changed files: - .gitlab-ci.yml - + bin/run-ansi-tests.sh - bin/run-tests.sh → bin/run-unit-tests.sh Changes: ===================================== .gitlab-ci.yml ===================================== @@ -62,7 +62,7 @@ linux:test: - job: linux:build artifacts: true script: - - bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log + - bin/run-unit-tests.sh -l dist/bin/lisp 2>&1 | tee test.log linux:ansi-test: stage: ansi-test @@ -75,14 +75,8 @@ linux:ansi-test: # Needs artifacts from build (dist/) - job: linux:build artifacts: true - before_script: - - git clone https://gitlab.common-lisp.net/cmucl/ansi-test.git - - (cd ansi-test; git checkout cmucl-expected-failures) script: - - cd ansi-test - - make LISP="../dist/bin/lisp -batch -noinit -nositeinit" - # There should be no unexpected successes or failures; check these separately. - - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out + - bin/run-ansi-tests.sh -l dist/bin/lisp linux:benchmark: stage: benchmark @@ -149,7 +143,7 @@ osx:test: - job: osx:build artifacts: true script: - - bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log + - bin/run-unit-tests.sh -l dist/bin/lisp 2>&1 | tee test.log osx:ansi-test: stage: ansi-test @@ -162,14 +156,8 @@ osx:ansi-test: # Needs artifacts from build (dist/) - job: osx:build artifacts: true - before_script: - - /opt/local/bin/git clone https://gitlab.common-lisp.net/cmucl/ansi-test.git - - (cd ansi-test; /opt/local/bin/git checkout cmucl-expected-failures) script: - - cd ansi-test - - make LISP="../dist/bin/lisp -batch -noinit -nositeinit" - # There should be no unexpected successes or failures; check these separately. - - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out + - bin/run-ansi-tests.sh -l dist/bin/lisp osx:benchmark: stage: benchmark ===================================== bin/run-ansi-tests.sh ===================================== @@ -0,0 +1,48 @@ +#! /bin/bash + +# Run the ansi-tests. +# +# We need to check ou ansi-tests if we haven't already. We expect +# this to be run from the root of the cmucl git tree. We will check +# it out one level up from where we are. + +usage() { + echo "run-ansi-tests.sh [?h] [-l lisp]" + echo " -l lisp Lisp to use for the tests; defaults to lisp" + echo " -h|? This help message" + echo "" + echo "Run the ansi-tests" + echo "" + echo "If ../ansi-test does not exist a clone is checked out there." + echo "Then the ansi-test is run in the clone using the given lisp." + exit 0; +} + +LISP=lisp +while getopts "h?l:" arg +do + case $arg in + l) LISP="$PWD/$OPTARG" ;; + \?) usage ;; + h) usage ;; + esac +done + +# Shift out the options +shift $[$OPTIND - 1] + +set -x +if [ -d ../ansi-test ]; then + # We already have clone; make sure it's clean by stashing any changes. + (cd ../ansi-test; git stash) +else + (cd ../; git clone https://gitlab.common-lisp.net/cmucl/ansi-test.git) +fi + +cd ../ansi-test +git checkout cmucl-expected-failures + +make LISP="$LISP batch -noinit -nositeinit" +# There should be no unexpected successes or failures; check these separately +grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out + ===================================== bin/run-tests.sh → bin/run-unit-tests.sh ===================================== View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5b3e11f9235825ec368793… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5b3e11f9235825ec368793… 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] Update POT file for new comment
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: e4f4082e by Raymond Toy at 2023-08-21T08:18:12-07:00 Update POT file for new comment - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1155,6 +1155,13 @@ msgid "" " affects array types." msgstr "" +#: src/code/type.lisp +msgid "" +"The minimum length of either list argument for subsetp where a\n" +" hashtable is used to speed up processing instead of using a basic\n" +" list implementation. This value was determined by experimentation." +msgstr "" + #: src/code/type.lisp msgid "Subtypep is illegal on this type:~% ~S" msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e4f4082e4b015b26b1cc556… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e4f4082e4b015b26b1cc556… 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] 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) 20 Aug '23

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

20 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) 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

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

16 Aug '23

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

1 0

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

16 Aug '23

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

1 0

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

16 Aug '23

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

1 0

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

14 Aug '23

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

1 0

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

13 Aug '23

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

1 0

[Git][cmucl/cmucl][master] Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis
by Raymond Toy (＠rtoy) 12 Aug '23

12 Aug '23

Raymond Toy pushed to branch master 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. - - - - - 1 changed file: - benchmarks/cl-bench/files/math.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) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/33f117246e2a9315b33bc09… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/33f117246e2a9315b33bc09… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-249-replace-lea-in-arith
by Raymond Toy (＠rtoy) 12 Aug '23

12 Aug '23

Raymond Toy pushed new branch issue-249-replace-lea-in-arith at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-249-replace-lea-in-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0