Raymond Toy pushed to branch rtoy-mmap-anon-control-and-binding-stacks at cmucl / cmucl Commits: f7e92b73 by Raymond Toy at 2015-11-10T21:39:15Z Rename arguments to RENAME-PACKAGE and update docstring Can't ever remember the order of arguments for RENAME-PACKAGE so just rename the variables to make it clearer. And update the docstring to be a little more verbose. - - - - - 5d3a63fa by Raymond Toy at 2015-11-28T16:43:54Z Support constant shifts for bignum digits. This gets rid of the load of the shift amount to ecx, saving one instruction and reducing pressure on the ecx register. - - - - - a613a908 by Raymond Toy at 2015-11-28T16:45:41Z Regenerated (due to docstring change for rename-package). - - - - - 1b8b84be by Raymond Toy at 2015-12-01T21:41:49Z Handle large (fixed) shift amounts for the digit shifters. Make the vops handle the case when the known constant shift amount is so large that the result is a known value. Plus, the instructions have a fixed immediate argument size and the amount is taken mod 32 which would produce the wrong result if the actual shift amount were used. - - - - - 5406768c by Raymond Toy at 2015-12-02T20:07:43Z Linux needs unix-setitimer Cut and paste error from unix-glibc2.lisp copied unix-getitimer instead of unix-setitimer which is needed by SAVE-LISP. - - - - - be500bc5 by Raymond Toy at 2015-12-05T16:10:46Z Regenerated. - - - - - 1d64f63b by Raymond Toy at 2015-12-05T17:01:22Z Update from logs. - - - - - 7a1457da by Raymond Toy at 2015-12-11T19:25:30Z New implementation of the digit shifters. Define new vops for the digit shifters that take a constant (unsigned-byte 5) value. The previous version, while correct, still causes the ecx register to spill because it was a temporary. This doens't cause the compiler to spill ecx unnecessarily anymore. - - - - - c91ff829 by Raymond Toy at 2015-12-12T08:51:40Z Update lisp-unit. - - - - - 275011da by Raymond Toy at 2015-12-13T21:35:03Z Merge branch 'master' into rtoy-mmap-anon-control-and-binding-stacks - - - - - 8 changed files: - src/code/package.lisp - src/code/unix.lisp - src/compiler/x86/arith.lisp - src/contrib/lisp-unit/internal-test/example-tests.lisp - src/contrib/lisp-unit/lisp-unit.lisp - src/general-info/release-21b.txt - src/i18n/locale/cmucl-unix.pot - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/package.lisp ===================================== --- a/src/code/package.lisp +++ b/src/code/package.lisp @@ -1204,23 +1204,25 @@ ;;; Change the name if we can, blast any old nicknames and then ;;; add in any new ones. ;;; -(defun rename-package (package name &optional (nicknames ())) - "Changes the name and nicknames for a package." +(defun rename-package (package new-name &optional (new-nicknames ())) + "Replaces the name and nicknames of Package. The old name and all of + the old nicknames of Package are eliminated and are replaced by + New-Name and New-Nicknames." (let* ((package (package-or-lose package)) - (name (string name)) - (found (find-package name))) + (new-name (string new-name)) + (found (find-package new-name))) (unless (or (not found) (eq found package)) (error 'simple-package-error - :package name + :package new-name :format-control (intl:gettext "A package named ~S already exists.") - :format-arguments (list name))) + :format-arguments (list new-name))) (remhash (package-%name package) *package-names*) (dolist (n (package-%nicknames package)) (remhash n *package-names*)) - (setf (package-%name package) name) - (setf (gethash name *package-names*) package) + (setf (package-%name package) new-name) + (setf (gethash new-name *package-names*) package) (setf (package-%nicknames package) ()) - (enter-new-nicknames package nicknames) + (enter-new-nicknames package new-nicknames) package)) ;;; Delete-Package -- Public ===================================== src/code/unix.lisp ===================================== --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -2661,12 +2661,18 @@ which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) #+linux -(defun unix-getitimer (which) - _N"Unix-getitimer returns the INTERVAL and VALUE slots of one of - three system timers (:real :virtual or :profile). On success, - unix-getitimer returns 5 values, - T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec." +(defun unix-setitimer (which int-secs int-usec val-secs val-usec) + _N" Unix-setitimer sets the INTERVAL and VALUE slots of one of + three system timers (:real :virtual or :profile). A SIGALRM signal + will be delivered VALUE <seconds+microseconds> from now. INTERVAL, + when non-zero, is <seconds+microseconds> to be loaded each time + the timer expires. Setting INTERVAL and VALUE to zero disables + the timer. See the Unix man page for more details. On success, + unix-setitimer returns the old contents of the INTERVAL and VALUE + slots as in unix-getitimer." (declare (type (member :real :virtual :profile) which) + (type (unsigned-byte 29) int-secs val-secs) + (type (integer 0 (1000000)) int-usec val-usec) (values t (unsigned-byte 29)(mod 1000000) (unsigned-byte 29)(mod 1000000))) @@ -2674,14 +2680,19 @@ (:real ITIMER-REAL) (:virtual ITIMER-VIRTUAL) (:profile ITIMER-PROF)))) - (with-alien ((itv (struct itimerval))) - (syscall* ("getitimer" int (* (struct itimerval))) + (with-alien ((itvn (struct itimerval)) + (itvo (struct itimerval))) + (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs + (slot (slot itvn 'it-interval) 'tv-usec) int-usec + (slot (slot itvn 'it-value ) 'tv-sec ) val-secs + (slot (slot itvn 'it-value ) 'tv-usec) val-usec) + (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval))) (values T - (slot (slot itv 'it-interval) 'tv-sec) - (slot (slot itv 'it-interval) 'tv-usec) - (slot (slot itv 'it-value) 'tv-sec) - (slot (slot itv 'it-value) 'tv-usec)) - which (alien-sap (addr itv)))))) + (slot (slot itvo 'it-interval) 'tv-sec) + (slot (slot itvo 'it-interval) 'tv-usec) + (slot (slot itvo 'it-value) 'tv-sec) + (slot (slot itvo 'it-value) 'tv-usec)) + which (alien-sap (addr itvn))(alien-sap (addr itvo))))))  ;;;; User and group database access, POSIX Standard 9.2.2 ===================================== src/compiler/x86/arith.lisp ===================================== --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1445,32 +1445,62 @@ (:translate bignum::%ashr) (:policy :fast-safe) (:args (digit :scs (unsigned-reg unsigned-stack) :target result) - (count :scs (unsigned-reg) :target ecx)) + (count :scs (unsigned-reg))) (:arg-types unsigned-num positive-fixnum) (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) (:results (result :scs (unsigned-reg) :from (:argument 0) :load-if (not (and (sc-is result unsigned-stack) (location= digit result))))) (:result-types unsigned-num) - (:generator 1 + (:generator 2 (move result digit) (move ecx count) (inst sar result :cl))) +(define-vop (digit-ashr-c) + (:translate bignum::%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target result)) + (:info count) + (:arg-types unsigned-num (:constant (unsigned-byte #.(1- (integer-length vm:word-bits))))) + (:results (result :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is result unsigned-stack) + (location= digit result))))) + (:result-types unsigned-num) + (:generator 1 + (move result digit) + ;; If the count is greater than 31, it's the same as + ;; shifting by 31, leaving just the sign bit. + (inst sar result count))) + (define-vop (digit-lshr digit-ashr) (:translate bignum::%digit-logical-shift-right) - (:generator 1 + (:generator 2 (move result digit) (move ecx count) (inst shr result :cl))) +(define-vop (digit-lshr-c digit-ashr-c) + (:translate bignum::%digit-logical-shift-right) + (:generator 1 + (move result digit) + (inst shr result count))) + (define-vop (digit-ashl digit-ashr) (:translate bignum::%ashl) - (:generator 1 + (:generator 2 (move result digit) (move ecx count) (inst shl result :cl))) +(define-vop (digit-ashl-c digit-ashr-c) + (:translate bignum::%ashl) + (:generator 1 + (move result digit) + (inst shl result count))) + + +  ;;;; Static functions. ===================================== src/contrib/lisp-unit/internal-test/example-tests.lisp ===================================== --- a/src/contrib/lisp-unit/internal-test/example-tests.lisp +++ b/src/contrib/lisp-unit/internal-test/example-tests.lisp @@ -57,6 +57,10 @@ (dotimes (i 5) (assert-equal i (my-sqrt (* i i)) i))) +(define-test cl-user::my-sqrt + (dotimes (i 5) + (assert-equal i (my-sqrt (* i i)) i))) + ;;; Macro (defmacro my-macro (arg1 arg2) ===================================== src/contrib/lisp-unit/lisp-unit.lisp ===================================== --- a/src/contrib/lisp-unit/lisp-unit.lisp +++ b/src/contrib/lisp-unit/lisp-unit.lisp @@ -126,8 +126,9 @@ functions or even macros does not require reloading any tests. "If not NIL, enter the debugger when an error is encountered in an assertion.") -(defparameter *signal-results* nil - "Signal the result if non NIL.") +(defun use-debugger (&optional (flag t)) + "Use the debugger when testing, or not." + (setq *use-debugger* flag)) (defun use-debugger-p (condition) "Debug or ignore errors." @@ -136,9 +137,8 @@ assertion.") (y-or-n-p "~A -- debug?" condition)) (*use-debugger*))) -(defun use-debugger (&optional (flag t)) - "Use the debugger when testing, or not." - (setq *use-debugger* flag)) +(defparameter *signal-results* nil + "Signal the result if non NIL.") (defun signal-results (&optional (flag t)) "Signal the results for extensibility." @@ -238,7 +238,7 @@ assertion.") ((and (stringp item) (not doc) (rest body)) (if tag (values doc tag (rest body)) - (parse-body (rest body) doc tag))) + (parse-body (rest body) item tag))) (t (values doc tag body))))) (defun test-name-error-report (test-name-error stream) @@ -260,20 +260,31 @@ assertion.") name (error 'test-name-error :datum name))) +(defun test-package (name) + "Return the package for storing the test." + (multiple-value-bind (symbol status) + (find-symbol (symbol-name name)) + (declare (ignore symbol)) + (ecase status + ((:internal :external nil) + (symbol-package name)) + (:inherited *package*)))) + (defmacro define-test (name &body body) "Store the test in the test database." (let ((qname (gensym "NAME-"))) (multiple-value-bind (doc tag code) (parse-body body) `(let* ((,qname (valid-test-name ',name)) - (doc (or ,doc (string ,qname)))) + (doc (or ,doc (symbol-name ,qname))) + (package (test-package ,qname))) (setf ;; Unit test - (gethash ,qname (package-table *package* t)) + (gethash ,qname (package-table package t)) (make-instance 'unit-test :doc doc :code ',code)) ;; Tags - (loop for tag in ',tag do - (pushnew - ,qname (gethash tag (package-tags *package* t)))) + (loop + for tag in ',tag do + (pushnew ,qname (gethash tag (package-tags package t)))) ;; Return the name of the test ,qname)))) ===================================== src/general-info/release-21b.txt ===================================== --- a/src/general-info/release-21b.txt +++ b/src/general-info/release-21b.txt @@ -42,10 +42,13 @@ New in this release: of BYTE and WORD. * Unix support on Linux has been unified with all other OSes. Thus, src/code/unix-glibc2.lisp is no longer used. + * Micro-optimize modular shifts on x86. + * Update lisp-unit to commit e6c259f. * ANSI compliance fixes: * Bugfixes: + * Linux was missing unix-setitimer which prevented saving cores. * Trac Tickets: ===================================== src/i18n/locale/cmucl-unix.pot ===================================== --- a/src/i18n/locale/cmucl-unix.pot +++ b/src/i18n/locale/cmucl-unix.pot @@ -1298,14 +1298,6 @@ msgstr "" #: src/code/unix.lisp msgid "" -"Unix-getitimer returns the INTERVAL and VALUE slots of one of\n" -" three system timers (:real :virtual or :profile). On success,\n" -" unix-getitimer returns 5 values,\n" -" T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec." -msgstr "" - -#: src/code/unix.lisp -msgid "" "Return a USER-INFO structure for the user identified by UID, or NIL if not " "found." msgstr "" ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -8120,7 +8120,10 @@ msgid "The package named ~S doesn't exist." msgstr "" #: src/code/package.lisp -msgid "Changes the name and nicknames for a package." +msgid "" +"Replaces the name and nicknames of Package. The old name and all of\n" +" the old nicknames of Package are eliminated and are replaced by\n" +" New-Name and New-Nicknames." msgstr "" #: src/code/package.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/70f15c09eb7c4cb656ab38026...