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

[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