[Git][cmucl/cmucl][rtoy-mmap-anon-control-and-binding-stacks] 10 commits: Rename arguments to RENAME-PACKAGE and update docstring
Raymond Toy
rtoy at common-lisp.net
Mon Dec 14 05:35:26 UTC 2015
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/70f15c09eb7c4cb656ab38026d92d821979449a7...275011da14a17167d5c039047861253550279fe5
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20151214/41a62a74/attachment-0001.html>
More information about the cmucl-cvs
mailing list