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

[cmucl/cmucl][master] Add brief documentat on the test names.
by Raymond Toy 22 Jun '15

22 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 94409c5e by Raymond Toy at 2015-06-22T23:09:02Z Add brief documentat on the test names. I always forget how to run one set of tests. Add some hints. - - - - - 1 changed file: - tests/run-tests.lisp Changes: ===================================== tests/run-tests.lisp ===================================== --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -10,6 +10,10 @@ ;;;; ;;;; lisp -noinit -load tests/run-tests.lisp -eval '(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test <list>))' ;;;; +;;;; where <list> is a list of the test names such as "ISSUES-TESTS", +;;;; "IRRAT-TESTS", etc. The test names are basically the file name +;;;; with a suffix of "-TESTS". +;;;; ;;;; Note that you cannot run these tests from a binary created during ;;;; a build process. You must run ;;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/94409c5eb240820fd9274725b…

1 0

[cmucl/cmucl][master] Lookup names correctly in COMPILER-MACRO-FUNCTION.
by Raymond Toy 22 Jun '15

22 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: e6999217 by Raymond Toy at 2015-06-22T23:08:08Z Lookup names correctly in COMPILER-MACRO-FUNCTION. Fix #3. The lookup for the names was not handling things like (FLET SQUARE TEST/PRESENT) correctly. Use VALID-FUNCTION-NAME to get the function name instead of a plain EQUAL test. - - - - - 2 changed files: - src/code/eval.lisp - tests/issues.lisp Changes: ===================================== src/code/eval.lisp ===================================== --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -448,7 +448,8 @@ set with SETF." (let ((found (and env (cdr (assoc name (c::lexenv-functions env) - :test #'equal))))) + :key #'(lambda (e) + (nth-value 1 (valid-function-name-p e)))))))) (unless (eq (cond ((c::defined-function-p found) (c::defined-function-inlinep found)) (found :notinline) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -38,3 +38,39 @@ t) (t () nil)))) + +;; Functions for testing issue-3 +(defun sqr (x) + (expt x 2)) + +(define-compiler-macro sqr (x) + `(expt ,x 2)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defmacro with-square-check (&body body &environment env) + (let ((text (if (compiler-macro-function 'sqr env) + "Yes" + "No"))) + `(progn + (format t "SQUARE compiler macro present: ~A.~%" ,text) + ,@body)))) + + +(defun test/absent () + (with-square-check + (sqr 2))) + +(defun test/present () + (flet ((sqr (x) + (print (expt x 3)))) + (with-square-check + (sqr 2)))) + +(define-test issue.3 + (:tag :issues) + (assert-prints "SQUARE compiler macro present: Yes." + (test/absent)) + (assert-prints "SQUARE compiler macro present: No. + +8" + (test/present))) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/e69992175ccdcd7f895cff997…

1 0

[cmucl/cmucl][master] Fix #4: ELT signals error on invalid index on lists
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1ca0a557 by Raymond Toy at 2015-06-14T08:31:14Z Fix #4: ELT signals error on invalid index on lists code/seq.lisp: o Define internal LIST-ELT* function that executes ELT on lists, signaling an error if the index is invalid. compiler/seqtran.lisp: o Change the deftransform for ELT to use LIST-ELT* instead of NTH. tests/issues.lisp: o Add test for this issue. - - - - - 3 changed files: - src/code/seq.lisp - src/compiler/seqtran.lisp - tests/issues.lisp Changes: ===================================== src/code/seq.lisp ===================================== --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -138,6 +138,16 @@ (t (make-sequence-of-type (result-type-or-lose type) length)))) +(defun list-elt* (sequence index) + (declare (type list sequence)) + (do ((count index (1- count)) + (list sequence (cdr list))) + ((= count 0) + (if (endp list) + (signal-index-too-large-error sequence index) + (car list))) + (declare (type (integer 0) count)))) + (defun elt (sequence index) "Returns the element of SEQUENCE specified by INDEX." (etypecase sequence ===================================== src/compiler/seqtran.lisp ===================================== --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -107,8 +107,8 @@ (deftransform elt ((s i) ((simple-array * (*)) *) * :when :both) '(aref s i)) -(deftransform elt ((s i) (list *) * :when :both :policy (< safety 3)) - '(nth i s)) +(deftransform elt ((s i) (list *) * :when :both) + '(lisp::list-elt* s i)) (deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both) '(%aset s i v)) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -23,3 +23,18 @@ (assert-equal '(square x) (funcall (compiler-macro-function 'square) '(funcall #'square x) nil))) + +(define-test issue.5 + (:tag :issues) + (assert-true + (handler-case + (let ((f (compile nil '(lambda (list) + (declare (type list list) + (optimize (speed 1) (safety 1) (compilation-speed 1) (space 1) (debug 1))) + (elt list 3))))) + (funcall f (list 0 1 2))) + ;; ELT should signal an error in this case. + (lisp::index-too-large-error () + t) + (t () + nil)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1ca0a5571183b014a50fad56b…

1 0

[cmucl/cmucl][master] Regenerated.
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b096e8dd by Raymond Toy at 2015-06-13T23:23:25Z Regenerated. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -14693,7 +14693,11 @@ msgid "No default clause allowed in ~S: ~S" msgstr "" #: src/code/macros.lisp -msgid "T and OTHERWISE may not be used as key designators for ~A" +msgid "" +"~<~A is a key designator only in the final otherwise-clause. ~\n" +" Use (~A) to use it as a " +"normal-clause or move the clause to the ~\n" +" correct position.~:@>" msgstr "" #: src/code/macros.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/b096e8dd9d0bd437945dd520b…

1 0

[cmucl/cmucl][master] Increase *ERROR-PRINT-LINES* to a 10.
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 39c24612 by Raymond Toy at 2015-06-13T23:22:58Z Increase *ERROR-PRINT-LINES* to a 10. Five is a bit small, especially when printing out the message from issue #5. - - - - - 1 changed file: - src/compiler/ir1util.lisp Changes: ===================================== src/compiler/ir1util.lisp ===================================== --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1665,7 +1665,7 @@ "The value for *Print-Level* when printing compiler error messages.") (defvar *error-print-length* 5 "The value for *Print-Length* when printing compiler error messages.") -(defvar *error-print-lines* 5 +(defvar *error-print-lines* 10 "The value for *Print-Lines* when printing compiler error messages.") (defvar *enclosing-source-cutoff* 1 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/39c246129881b43be8214737f…

1 0

[cmucl/cmucl][master] Fix #5: Give better error message
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: e791b596 by Raymond Toy at 2015-06-13T23:21:13Z Fix #5: Give better error message Give a better error message when using T clause in case error.lisp: o Add new invalid-case condition to handle errors from case expressions. macros.lisp: o Use new invalid-case condition to signal the invalid usage of T in CASE expressions. o Replace old message with better, more informative, message. Include xref to ANSI CL spec. exports.lisp: o Export INVALID-CASE from KERNEL package. - - - - - 3 changed files: - src/code/error.lisp - src/code/exports.lisp - src/code/macros.lisp Changes: ===================================== src/code/error.lisp ===================================== --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -25,6 +25,7 @@ simple-file-error simple-program-error simple-parse-error simple-style-warning simple-undefined-function constant-modified + invalid-case #+stack-checking stack-overflow #+heap-overflow-check heap-overflow)) @@ -1115,7 +1116,20 @@ (constant-modified-function-name c)) (print-references (reference-condition-references c) s))) (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) - + +;; For errors in CASE and friends. +(define-condition invalid-case (reference-condition error) + ((name :initarg :name + :reader invalid-case-name) + (format :initarg :format-control + :reader invalid-case-format) + (args :initarg :format-arguments + :reader invalid-case-format-args)) + (:report (lambda (condition stream) + (format stream "~A: " (invalid-case-name condition)) + (apply #'format stream (invalid-case-format condition) (invalid-case-format-args condition)) + (print-references (reference-condition-references condition) stream)))) + (define-condition arithmetic-error (error) ((operation :reader arithmetic-error-operation :initarg :operation :initform nil) ===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2538,7 +2538,8 @@ "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-P" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR" - "DD-PI")) + "DD-PI" + "INVALID-CASE")) (dolist (name ===================================== src/code/macros.lisp ===================================== --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -1366,7 +1366,16 @@ (error (intl:gettext "No default clause allowed in ~S: ~S") name case) (push `(t nil ,@(rest case)) clauses))) ((and (eq name 'case)) - (error (intl:gettext "T and OTHERWISE may not be used as key designators for ~A") name)) + (let ((key (first case))) + (error 'kernel:invalid-case + :name name + :format-control (intl:gettext + "~<~A is a key designator only in the final otherwise-clause. ~ + Use (~A) to use it as a normal-clause or move the clause to the ~ + correct position.~:@>") + :format-arguments (list (list key key)) + :references (list '(:ansi-cl :section (5 3)) + (list :ansi-cl :macro name))))) ((eq (first case) t) ;; The key T is normal clause, because it's not ;; the last clause. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/e791b596f0471f9027a95e8d5…

1 0

[cmucl/cmucl][master] Regenerated.
by Raymond Toy 14 Jun '15

14 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 83ce6c9e by Raymond Toy at 2015-06-13T18:30:41Z Regenerated. - - - - - 1 changed file: - src/i18n/locale/cmucl-unix.pot Changes: ===================================== src/i18n/locale/cmucl-unix.pot ===================================== --- a/src/i18n/locale/cmucl-unix.pot +++ b/src/i18n/locale/cmucl-unix.pot @@ -1236,3 +1236,50 @@ msgid "" " and its children." msgstr "" +#: src/code/unix.lisp +msgid "" +"Get the value of the environment variable named Name. If no such\n" +" variable exists, Nil is returned." +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Adds the environment variable named Name to the environment with\n" +" the given Value if Name does not already exist. If Name does exist,\n" +" the value is changed to Value if Overwrite is non-zero. Otherwise,\n" +" the value is not changed." +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Adds or changes the environment. Name-value must be a string of\n" +" the form \"name=value\". If the name does not exist, it is added.\n" +" If name does exist, the value is updated to the given value." +msgstr "" + +#: src/code/unix.lisp +msgid "Removes the variable Name from the environment" +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Executes the Unix execve system call. If the system call suceeds, lisp\n" +" will no longer be running in this process. If the system call fails " +"this\n" +" function returns two values: NIL and an error code. Arg-list should be " +"a\n" +" list of simple-strings which are passed as arguments to the exec'ed " +"program.\n" +" Environment should be an a-list mapping symbols to simple-strings which " +"this\n" +" function bashes together to form the environment for the exec'ed " +"program." +msgstr "" + +#: src/code/unix.lisp +msgid "" +"Executes the unix fork system call. Returns 0 in the child and the pid\n" +" of the child in the parent if it works, or NIL and an error number if it\n" +" doesn't work." +msgstr "" + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/83ce6c9e7cd6b3fed407255d8…

1 0

[cmucl/cmucl][master] Move more unix support to core for asdf and slime.
by Raymond Toy 12 Jun '15

12 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1a20bb57 by Raymond Toy at 2015-06-11T21:28:39Z Move more unix support to core for asdf and slime. o The upcoming version of asdf wants to use unix-getenv, so add that to the core, removing from the unix contrib. o Slime wants to use unix-execve and unix-fork, so import that and the necessary support routines in to the core from the unix contrib. - - - - - 4 changed files: - src/code/exports.lisp - src/code/unix.lisp - src/contrib/unix/unix-glibc2.lisp - src/contrib/unix/unix.lisp Changes: ===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -357,6 +357,15 @@ "FIONREAD" "TERMINAL-SPEEDS" ) + (:export + ;; For asdf + "UNIX-GETENV" + "UNIX-SETENV" + "UNIX-PUTENV" + "UNIX-UNSETENV" + ;; For slime + "UNIX-EXECVE" + "UNIX-FORK") #-(or linux solaris) (:export "TCHARS" "LTCHARS" ===================================== src/code/unix.lisp ===================================== --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -2517,3 +2517,150 @@ (cast (slot names 'machine) c-string)) #+freebsd 256 (addr names)))) + +;;; For asdf. Well, only getenv, but might as well make it symmetric. + +;; Environment manipulation; man getenv(3) +(def-alien-routine ("getenv" unix-getenv) c-call:c-string + (name c-call:c-string) + _N"Get the value of the environment variable named Name. If no such + variable exists, Nil is returned.") + +;; This doesn't exist in Solaris 8 but does exist in Solaris 10. +(def-alien-routine ("setenv" unix-setenv) c-call:int + (name c-call:c-string) + (value c-call:c-string) + (overwrite c-call:int) + _N"Adds the environment variable named Name to the environment with + the given Value if Name does not already exist. If Name does exist, + the value is changed to Value if Overwrite is non-zero. Otherwise, + the value is not changed.") + + +(def-alien-routine ("putenv" unix-putenv) c-call:int + (name-value c-call:c-string) + _N"Adds or changes the environment. Name-value must be a string of + the form \"name=value\". If the name does not exist, it is added. + If name does exist, the value is updated to the given value.") + +(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int + (name c-call:c-string) + _N"Removes the variable Name from the environment") + + +;;; For slime, which wants to use unix-execve. + +(defmacro round-bytes-to-words (n) + `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) + +;;; +;;; STRING-LIST-TO-C-STRVEC -- Internal +;;; +;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of +;;; simple-strings and constructs a C-style string vector (strvec) -- +;;; a null-terminated array of pointers to null-terminated strings. +;;; This function returns two values: a sap and a byte count. When the +;;; memory is no longer needed it should be deallocated with +;;; vm_deallocate. +;;; +(defun string-list-to-c-strvec (string-list) + ;; + ;; Make a pass over string-list to calculate the amount of memory + ;; needed to hold the strvec. + (let ((string-bytes 0) + (vec-bytes (* 4 (1+ (length string-list))))) + (declare (fixnum string-bytes vec-bytes)) + (dolist (s string-list) + (check-type s simple-string) + (incf string-bytes (round-bytes-to-words (1+ (length s))))) + ;; + ;; Now allocate the memory and fill it in. + (let* ((total-bytes (+ string-bytes vec-bytes)) + (vec-sap (system:allocate-system-memory total-bytes)) + (string-sap (sap+ vec-sap vec-bytes)) + (i 0)) + (declare (type (and unsigned-byte fixnum) total-bytes i) + (type system:system-area-pointer vec-sap string-sap)) + (dolist (s string-list) + (declare (simple-string s)) + (let ((n (length s))) + ;; + ;; Blast the string into place + #-unicode + (kernel:copy-to-system-area (the simple-string s) + (* vm:vector-data-offset vm:word-bits) + string-sap 0 + (* (1+ n) vm:byte-bits)) + #+unicode + (progn + ;; FIXME: Do we need to apply some kind of transformation + ;; to convert Lisp unicode strings to C strings? Utf-8? + (dotimes (k n) + (setf (sap-ref-8 string-sap k) + (logand #xff (char-code (aref s k))))) + (setf (sap-ref-8 string-sap n) 0)) + ;; + ;; Blast the pointer to the string into place + (setf (sap-ref-sap vec-sap i) string-sap) + (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) + (incf i 4))) + ;; Blast in last null pointer + (setf (sap-ref-sap vec-sap i) (int-sap 0)) + (values vec-sap total-bytes)))) + +(defun sub-unix-execve (program arg-list env-list) + (let ((argv nil) + (argv-bytes 0) + (envp nil) + (envp-bytes 0) + result error-code) + (unwind-protect + (progn + ;; Blast the stuff into the proper format + (multiple-value-setq + (argv argv-bytes) + (string-list-to-c-strvec arg-list)) + (multiple-value-setq + (envp envp-bytes) + (string-list-to-c-strvec env-list)) + ;; + ;; Now do the system call + (multiple-value-setq + (result error-code) + (int-syscall ("execve" + c-string system-area-pointer system-area-pointer) + program argv envp))) + ;; + ;; Deallocate memory + (when argv + (system:deallocate-system-memory argv argv-bytes)) + (when envp + (system:deallocate-system-memory envp envp-bytes))) + (values result error-code))) + +;;;; UNIX-EXECVE +(defun unix-execve (program &optional arg-list + (environment *environment-list*)) + _N"Executes the Unix execve system call. If the system call suceeds, lisp + will no longer be running in this process. If the system call fails this + function returns two values: NIL and an error code. Arg-list should be a + list of simple-strings which are passed as arguments to the exec'ed program. + Environment should be an a-list mapping symbols to simple-strings which this + function bashes together to form the environment for the exec'ed program." + (check-type program simple-string) + (let ((env-list (let ((envlist nil)) + (dolist (cons environment) + (push (if (cdr cons) + (concatenate 'simple-string + (string (car cons)) "=" + (cdr cons)) + (car cons)) + envlist)) + envlist))) + (sub-unix-execve (%name->file program) arg-list env-list))) + +(defun unix-fork () + _N"Executes the unix fork system call. Returns 0 in the child and the pid + of the child in the parent if it works, or NIL and an error number if it + doesn't work." + (int-syscall ("fork"))) ===================================== src/contrib/unix/unix-glibc2.lisp ===================================== --- a/src/contrib/unix/unix-glibc2.lisp +++ b/src/contrib/unix/unix-glibc2.lisp @@ -1129,61 +1129,6 @@ length LEN and type TYPE." ;;; unistd.h -(defun sub-unix-execve (program arg-list env-list) - (let ((argv nil) - (argv-bytes 0) - (envp nil) - (envp-bytes 0) - result error-code) - (unwind-protect - (progn - ;; Blast the stuff into the proper format - (multiple-value-setq - (argv argv-bytes) - (string-list-to-c-strvec arg-list)) - (multiple-value-setq - (envp envp-bytes) - (string-list-to-c-strvec env-list)) - ;; - ;; Now do the system call - (multiple-value-setq - (result error-code) - (int-syscall ("execve" - c-string system-area-pointer system-area-pointer) - program argv envp))) - ;; - ;; Deallocate memory - (when argv - (system:deallocate-system-memory argv argv-bytes)) - (when envp - (system:deallocate-system-memory envp envp-bytes))) - (values result error-code))) - -;;;; UNIX-EXECVE - -(defun unix-execve (program &optional arg-list - (environment *environment-list*)) - _N"Executes the Unix execve system call. If the system call suceeds, lisp - will no longer be running in this process. If the system call fails this - function returns two values: NIL and an error code. Arg-list should be a - list of simple-strings which are passed as arguments to the exec'ed program. - Environment should be an a-list mapping symbols to simple-strings which this - function bashes together to form the environment for the exec'ed program." - (check-type program simple-string) - (let ((env-list (let ((envlist nil)) - (dolist (cons environment) - (push (if (cdr cons) - (concatenate 'simple-string - (string (car cons)) "=" - (cdr cons)) - (car cons)) - envlist)) - envlist))) - (sub-unix-execve (%name->file program) arg-list env-list))) - - -(defmacro round-bytes-to-words (n) - `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) (defun unix-chown (path uid gid) _N"Given a file path, an integer user-id, and an integer group-id, @@ -1328,37 +1273,6 @@ length LEN and type TYPE." returned if the call fails." (void-syscall ("setregid" int int) rgid egid)) -(defun unix-fork () - _N"Executes the unix fork system call. Returns 0 in the child and the pid - of the child in the parent if it works, or NIL and an error number if it - doesn't work." - (int-syscall ("fork"))) - -;; Environment maninpulation; man getenv(3) -(def-alien-routine ("getenv" unix-getenv) c-call:c-string - (name c-call:c-string) - _N"Get the value of the environment variable named Name. If no such - variable exists, Nil is returned.") - -(def-alien-routine ("setenv" unix-setenv) c-call:int - (name c-call:c-string) - (value c-call:c-string) - (overwrite c-call:int) - _N"Adds the environment variable named Name to the environment with - the given Value if Name does not already exist. If Name does exist, - the value is changed to Value if Overwrite is non-zero. Otherwise, - the value is not changed.") - -(def-alien-routine ("putenv" unix-putenv) c-call:int - (name c-call:c-string) - _N"Adds or changes the environment. Name-value must be a string of - the form \"name=value\". If the name does not exist, it is added. - If name does exist, the value is updated to the given value.") - -(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int - (name c-call:c-string) - _N"Removes the variable Name from the environment") - ;;; Unix-link creates a hard link from name2 to name1. (defun unix-link (name1 name2) @@ -1888,61 +1802,6 @@ in at a time in poll.") (export '(unix-file-kind unix-maybe-prepend-current-directory unix-resolve-links unix-simplify-pathname)) -;;; -;;; STRING-LIST-TO-C-STRVEC -- Internal -;;; -;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of -;;; simple-strings and constructs a C-style string vector (strvec) -- -;;; a null-terminated array of pointers to null-terminated strings. -;;; This function returns two values: a sap and a byte count. When the -;;; memory is no longer needed it should be deallocated with -;;; vm_deallocate. -;;; -(defun string-list-to-c-strvec (string-list) - ;; - ;; Make a pass over string-list to calculate the amount of memory - ;; needed to hold the strvec. - (let ((string-bytes 0) - (vec-bytes (* 4 (1+ (length string-list))))) - (declare (fixnum string-bytes vec-bytes)) - (dolist (s string-list) - (check-type s simple-string) - (incf string-bytes (round-bytes-to-words (1+ (length s))))) - ;; - ;; Now allocate the memory and fill it in. - (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (system:allocate-system-memory total-bytes)) - (string-sap (sap+ vec-sap vec-bytes)) - (i 0)) - (declare (type (and unsigned-byte fixnum) total-bytes i) - (type system:system-area-pointer vec-sap string-sap)) - (dolist (s string-list) - (declare (simple-string s)) - (let ((n (length s))) - ;; - ;; Blast the string into place - #-unicode - (kernel:copy-to-system-area (the simple-string s) - (* vm:vector-data-offset vm:word-bits) - string-sap 0 - (* (1+ n) vm:byte-bits)) - #+unicode - (progn - ;; FIXME: Do we need to apply some kind of transformation - ;; to convert Lisp unicode strings to C strings? Utf-8? - (dotimes (k n) - (setf (sap-ref-8 string-sap k) - (logand #xff (char-code (aref s k))))) - (setf (sap-ref-8 string-sap n) 0)) - ;; - ;; Blast the pointer to the string into place - (setf (sap-ref-sap vec-sap i) string-sap) - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i 4))) - ;; Blast in last null pointer - (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap total-bytes)))) - ;;; Stuff not yet found in the header files... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ===================================== src/contrib/unix/unix.lisp ===================================== --- a/src/contrib/unix/unix.lisp +++ b/src/contrib/unix/unix.lisp @@ -634,159 +634,12 @@ group leader. NIL and an error number are returned upon failure." (void-syscall ("setpgid" int int) pid pgrp)) -(defun unix-fork () - _N"Executes the unix fork system call. Returns 0 in the child and the pid - of the child in the parent if it works, or NIL and an error number if it - doesn't work." - (int-syscall ("fork"))) - -;; Environment manipulation; man getenv(3) -(def-alien-routine ("getenv" unix-getenv) c-call:c-string - (name c-call:c-string) - _N"Get the value of the environment variable named Name. If no such - variable exists, Nil is returned.") - -;; This doesn't exist in Solaris 8 but does exist in Solaris 10. -(def-alien-routine ("setenv" unix-setenv) c-call:int - (name c-call:c-string) - (value c-call:c-string) - (overwrite c-call:int) - _N"Adds the environment variable named Name to the environment with - the given Value if Name does not already exist. If Name does exist, - the value is changed to Value if Overwrite is non-zero. Otherwise, - the value is not changed.") - - -(def-alien-routine ("putenv" unix-putenv) c-call:int - (name-value c-call:c-string) - _N"Adds or changes the environment. Name-value must be a string of - the form \"name=value\". If the name does not exist, it is added. - If name does exist, the value is updated to the given value.") - -;; This doesn't exist in Solaris 8 but does exist in Solaris 10. -(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int - (name c-call:c-string) - _N"Removes the variable Name from the environment") - ;;;; Support routines for dealing with unix pathnames. (export '(unix-file-kind unix-maybe-prepend-current-directory unix-resolve-links unix-simplify-pathname)) - -;;;; UNIX-EXECVE - -(defun unix-execve (program &optional arg-list - (environment *environment-list*)) - _N"Executes the Unix execve system call. If the system call suceeds, lisp - will no longer be running in this process. If the system call fails this - function returns two values: NIL and an error code. Arg-list should be a - list of simple-strings which are passed as arguments to the exec'ed program. - Environment should be an a-list mapping symbols to simple-strings which this - function bashes together to form the environment for the exec'ed program." - (check-type program simple-string) - (let ((env-list (let ((envlist nil)) - (dolist (cons environment) - (push (if (cdr cons) - (concatenate 'simple-string - (string (car cons)) "=" - (cdr cons)) - (car cons)) - envlist)) - envlist))) - (sub-unix-execve (%name->file program) arg-list env-list))) - - -(defmacro round-bytes-to-words (n) - `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) - -;;; -;;; STRING-LIST-TO-C-STRVEC -- Internal -;;; -;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of -;;; simple-strings and constructs a C-style string vector (strvec) -- -;;; a null-terminated array of pointers to null-terminated strings. -;;; This function returns two values: a sap and a byte count. When the -;;; memory is no longer needed it should be deallocated with -;;; vm_deallocate. -;;; -(defun string-list-to-c-strvec (string-list) - ;; - ;; Make a pass over string-list to calculate the amount of memory - ;; needed to hold the strvec. - (let ((string-bytes 0) - (vec-bytes (* 4 (1+ (length string-list))))) - (declare (fixnum string-bytes vec-bytes)) - (dolist (s string-list) - (check-type s simple-string) - (incf string-bytes (round-bytes-to-words (1+ (length s))))) - ;; - ;; Now allocate the memory and fill it in. - (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (system:allocate-system-memory total-bytes)) - (string-sap (sap+ vec-sap vec-bytes)) - (i 0)) - (declare (type (and unsigned-byte fixnum) total-bytes i) - (type system:system-area-pointer vec-sap string-sap)) - (dolist (s string-list) - (declare (simple-string s)) - (let ((n (length s))) - ;; - ;; Blast the string into place - #-unicode - (kernel:copy-to-system-area (the simple-string s) - (* vm:vector-data-offset vm:word-bits) - string-sap 0 - (* (1+ n) vm:byte-bits)) - #+unicode - (progn - ;; FIXME: Do we need to apply some kind of transformation - ;; to convert Lisp unicode strings to C strings? Utf-8? - (dotimes (k n) - (setf (sap-ref-8 string-sap k) - (logand #xff (char-code (aref s k))))) - (setf (sap-ref-8 string-sap n) 0)) - - ;; - ;; Blast the pointer to the string into place - (setf (sap-ref-sap vec-sap i) string-sap) - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i 4))) - ;; Blast in last null pointer - (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap total-bytes)))) - -(defun sub-unix-execve (program arg-list env-list) - (let ((argv nil) - (argv-bytes 0) - (envp nil) - (envp-bytes 0) - result error-code) - (unwind-protect - (progn - ;; Blast the stuff into the proper format - (multiple-value-setq - (argv argv-bytes) - (string-list-to-c-strvec arg-list)) - (multiple-value-setq - (envp envp-bytes) - (string-list-to-c-strvec env-list)) - ;; - ;; Now do the system call - (multiple-value-setq - (result error-code) - (int-syscall ("execve" - c-string system-area-pointer system-area-pointer) - program argv envp))) - ;; - ;; Deallocate memory - (when argv - (system:deallocate-system-memory argv argv-bytes)) - (when envp - (system:deallocate-system-memory envp envp-bytes))) - (values result error-code))) - ;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1a20bb5731c5774c29f25ef3d…

1 0

[cmucl/cmucl][master] Install the unix contribs in the main tarball instead of the extra.
by Raymond Toy 12 Jun '15

12 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b0b22340 by Raymond Toy at 2015-06-11T21:20:32Z Install the unix contribs in the main tarball instead of the extra. - - - - - 2 changed files: - bin/make-extra-dist.sh - bin/make-main-dist.sh Changes: ===================================== bin/make-extra-dist.sh ===================================== --- a/bin/make-extra-dist.sh +++ b/bin/make-extra-dist.sh @@ -99,7 +99,7 @@ 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")` +for f in `(cd src/contrib; find . -type f -print | egrep -v "CVS|asdf|defsystem|unix")` do FILE=`basename $f` DIR=`dirname $f` ===================================== bin/make-main-dist.sh ===================================== --- a/bin/make-main-dist.sh +++ b/bin/make-main-dist.sh @@ -140,6 +140,8 @@ esac install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/contrib/unix install ${GROUP} ${OWNER} -m 0644 $TARGET/contrib/unix/$UCONTRIB.$FASL $DESTDIR/lib/cmucl/lib/contrib/unix +install ${GROUP} ${OWNER} -m 0644 src/contrib/load-unix.lisp $DESTDIR/lib/cmucl/lib/contrib +install ${GROUP} ${OWNER} -m 0644 src/contrib/unix/${UCONTRIB}.lisp $DESTDIR/lib/cmucl/lib/contrib/unix # Copy the source files for asdf and defsystem for f in `(cd src; find contrib/asdf contrib/defsystem -type f -print | grep -v CVS)` View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/b0b223400febdf9c44e2a473f…

1 0

[cmucl/cmucl][master] 7 commits: Move the double-double functions and transforms to their own file.
by Raymond Toy 07 Jun '15

07 Jun '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 7aa4fe57 by Raymond Toy at 2015-06-06T17:26:01Z Move the double-double functions and transforms to their own file. compiler/float-tran-dd.lisp: * Most of the double-double implementation moved here. compiler/float-tran.lisp: * Removed most of the double-double implementation. compiler/loadcom.lisp: * Load float-tran-dd. tools/comcom.lisp: * Compile float-tran-dd. i18n/local/cmucl.pot: * Regenerated. - - - - - a2f0af94 by Raymond Toy at 2015-06-06T17:42:15Z Move more double-double items from float-tran to float-tran-dd. - - - - - b6a9e4dd by Raymond Toy at 2015-06-06T17:54:55Z Actually remove the double-double stuff that was moved. Previously only commented out, so really remove them now. - - - - - 268309ac by Raymond Toy at 2015-06-06T17:55:27Z Remove #+double-double conditionals. This file should only be compiled when double-double support is available. - - - - - e6da7db1 by Raymond Toy at 2015-06-06T18:24:23Z Wrap the entire file in double-double conditional. This is so that we can always compile and load this file, even if double-double isn't supported. (But all currently supported architectures support double-doubles.) - - - - - fba8332d by Raymond Toy at 2015-06-06T18:24:38Z Regenerated. - - - - - b7af30bd by Raymond Toy at 2015-06-07T03:40:47Z Merge branch 'rtoy-split-out-dd-math' into 'master' Split out double-double math routines Move the double-double transforms and a few other double-double methods from float-tran.lisp to float-tran-dd.lisp See merge request !1 - - - - - 5 changed files: - + src/compiler/float-tran-dd.lisp - src/compiler/float-tran.lisp - src/compiler/loadcom.lisp - src/i18n/locale/cmucl.pot - src/tools/comcom.lisp Changes: ===================================== src/compiler/float-tran-dd.lisp ===================================== --- /dev/null +++ b/src/compiler/float-tran-dd.lisp @@ -0,0 +1,690 @@ +;;; -*- Mode: Lisp; Package: C; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/compiler/float-tran-dd.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains floating-point specific transforms for +;;; double-doubles. +;;; +;;; The algorithms contained herein are based on the code written by +;;; Yozo Hida. See http://www.cs.berkeley.edu/~yozo/ for more +;;; information. + +(in-package "C") +(intl:textdomain "cmucl") + +#+double-double +(progn +(defknown %double-double-float (real) + double-double-float + (movable foldable flushable)) + +(deftransform float ((n prototype) (* double-double-float) * :when :both) + '(%double-double-float n)) + +(deftransform %double-float ((n) (double-double-float) * :when :both) + '(double-double-hi n)) + +(deftransform %single-float ((n) (double-double-float) * :when :both) + '(float (double-double-hi n) 1f0)) + +(deftransform %double-double-float ((n) (double-double-float) * :when :both) + 'n) + +#+nil +(defun %double-double-float (n) + (make-double-double-float (float n 1d0) 0d0)) + +;; Moved to code/float.lisp, because we need this relatively early in +;; the build process to handle float and real types. +#+nil +(defun %double-double-float (n) + (typecase n + (fixnum + (%make-double-double-float (float n 1d0) 0d0)) + (single-float + (%make-double-double-float (float n 1d0) 0d0)) + (double-float + (%make-double-double-float (float n 1d0) 0d0)) + (double-double-float + n) + (bignum + (bignum:bignum-to-float n 'double-double-float)) + (ratio + (kernel::float-ratio n 'double-double-float)))) + +(defknown double-double-float-p (t) + boolean + (movable foldable flushable)) + +(defknown %make-double-double-float (double-float double-float) + double-double-float + (movable foldable flushable)) + + +(defknown double-double-hi (double-double-float) + double-float + (movable foldable flushable)) + +(defknown double-double-lo (double-double-float) + double-float + (movable foldable flushable)) + +(deftransform float-sign ((float &optional float2) + (double-double-float &optional double-double-float) *) + (if float2 + (let ((temp (gensym))) + `(let ((,temp (abs float2))) + (if (minusp (float-sign (double-double-hi float))) + (- ,temp) + ,temp))) + '(if (minusp (float-sign (double-double-hi float))) -1w0 1w0))) + +(deftransform cis ((x) (double-double-float) *) + `(multiple-value-bind (s c) + (kernel::dd-%sincos x) + (complex c s))) + + + +(declaim (inline quick-two-sum)) +(defun quick-two-sum (a b) + "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" + (declare (double-float a b)) + (let* ((s (+ a b)) + (e (- b (- s a)))) + (values s e))) + +(declaim (inline two-sum)) +(defun two-sum (a b) + "Computes fl(a+b) and err(a+b)" + (declare (double-float a b)) + (let* ((s (+ a b)) + (v (- s a)) + (e (+ (- a (- s v)) + (- b v)))) + (locally + (declare (optimize (inhibit-warnings 3))) + (values s e)))) + +(declaim (maybe-inline add-dd)) +(defun add-dd (a0 a1 b0 b1) + "Add the double-double A0,A1 to the double-double B0,B1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3) + (inhibit-warnings 3))) + (multiple-value-bind (s1 s2) + (two-sum a0 b0) + (declare (double-float s1 s2)) + (when (float-infinity-p s1) + (return-from add-dd (values s1 0d0))) + (multiple-value-bind (t1 t2) + (two-sum a1 b1) + (declare (double-float t1 t2)) + (incf s2 t1) + (multiple-value-bind (s1 s2) + (quick-two-sum s1 s2) + (declare (double-float s1 s2)) + (incf s2 t2) + (multiple-value-bind (r1 r2) + (quick-two-sum s1 s2) + (if (and (zerop a0) (zerop b0)) + ;; Handle sum of signed zeroes here. + (values (float-sign (+ a0 b0) 0d0) + 0d0) + (values r1 r2))))))) + +(deftransform + ((a b) (vm::double-double-float vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (add-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(declaim (inline quick-two-diff)) +(defun quick-two-diff (a b) + "Compute fl(a-b) and err(a-b), assuming |a| >= |b|" + (declare (double-float a b)) + (let ((s (- a b))) + (values s (- (- a s) b)))) + +(declaim (inline two-diff)) +(defun two-diff (a b) + "Compute fl(a-b) and err(a-b)" + (declare (double-float a b)) + (let* ((s (- a b)) + (v (- s a)) + (e (- (- a (- s v)) + (+ b v)))) + (locally + (declare (optimize (inhibit-warnings 3))) + (values s e)))) + +(declaim (maybe-inline sub-dd)) +(defun sub-dd (a0 a1 b0 b1) + "Subtract the double-double B0,B1 from A0,A1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3) + (inhibit-warnings 3))) + (multiple-value-bind (s1 s2) + (two-diff a0 b0) + (declare (double-float s2)) + (when (float-infinity-p s1) + (return-from sub-dd (values s1 0d0))) + (multiple-value-bind (t1 t2) + (two-diff a1 b1) + (incf s2 t1) + (multiple-value-bind (s1 s2) + (quick-two-sum s1 s2) + (declare (double-float s2)) + (incf s2 t2) + (multiple-value-bind (r1 r2) + (quick-two-sum s1 s2) + (if (and (zerop a0) (zerop b0)) + (values (float-sign (- a0 b0) 0d0) + 0d0) + (values r1 r2))))))) + +(declaim (maybe-inline sub-d-dd)) +(defun sub-d-dd (a b0 b1) + "Compute double-double = double - double-double" + (declare (double-float a b0 b1) + (optimize (speed 3) (safety 0) + (inhibit-warnings 3))) + (multiple-value-bind (s1 s2) + (two-diff a b0) + (declare (double-float s2)) + (when (float-infinity-p s1) + (return-from sub-d-dd (values s1 0d0))) + (decf s2 b1) + (multiple-value-bind (r1 r2) + (quick-two-sum s1 s2) + (if (and (zerop a) (zerop b0)) + (values (float-sign (- a b0) 0d0) 0d0) + (values r1 r2))))) + +(declaim (maybe-inline sub-dd-d)) +(defun sub-dd-d (a0 a1 b) + "Subtract the double B from the double-double A0,A1" + (declare (double-float a0 a1 b) + (optimize (speed 3) (safety 0) + (inhibit-warnings 3))) + (multiple-value-bind (s1 s2) + (two-diff a0 b) + (declare (double-float s2)) + (when (float-infinity-p s1) + (return-from sub-dd-d (values s1 0d0))) + (incf s2 a1) + (multiple-value-bind (r1 r2) + (quick-two-sum s1 s2) + (if (and (zerop a0) (zerop b)) + (values (float-sign (- a0 b) 0d0) 0d0) + (values r1 r2))))) + +(deftransform - ((a b) (vm::double-double-float vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (sub-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(deftransform - ((a b) (double-float vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (sub-d-dd a + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(deftransform - ((a b) (vm::double-double-float double-float) + * :node node) + `(multiple-value-bind (hi lo) + (sub-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + b) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(declaim (maybe-inline split)) +;; See Listing 2.6: Mul12 in "CR-LIBM: A library of correctly rounded +;; elementary functions in double-precision". Also known as Dekker's +;; algorithm. +(defun split (a) + "Split the double-float number a into a-hi and a-lo such that a = + a-hi + a-lo and a-hi contains the upper 26 significant bits of a and + a-lo contains the lower 26 bits." + (declare (double-float a)) + (let* ((tmp (* a (+ 1 (expt 2 27)))) + (a-hi (- tmp (- tmp a))) + (a-lo (- a a-hi))) + (values a-hi a-lo))) + +;; Values used for scaling in two-prod. These are used to determine +;; if SPLIT might overflow so the value (and result) can be scaled to +;; prevent overflow. +(defconstant +two970+ + (scale-float 1d0 970)) + +(defconstant +two53+ + (scale-float 1d0 53)) + +(defconstant +two-53+ + (scale-float 1d0 -53)) + +(declaim (inline two-prod)) + +;; This is essentially the algorithm given by Listing 2.7 Mul12Cond +;; given in "CR-LIBM: A library of correctly rounded elementary +;; functions in double-precision". +#-ppc +(defun two-prod (a b) + _N"Compute fl(a*b) and err(a*b)" + (declare (double-float a b) + (optimize (speed 3))) + ;; If the numbers are too big, scale them done so SPLIT doesn't overflow. + (multiple-value-bind (aa bb) + (values (if (> a +two970+) + (* a +two-53+) + a) + (if (> b +two970+) + (* b +two-53+) + b)) + (let ((p (* aa bb))) + (declare (double-float p) + (inline split)) + (multiple-value-bind (aa-hi aa-lo) + (split aa) + ;;(format t "aa-hi, aa-lo = ~S ~S~%" aa-hi aa-lo) + (multiple-value-bind (bb-hi bb-lo) + (split bb) + ;;(format t "bb-hi, bb-lo = ~S ~S~%" bb-hi bb-lo) + (let ((e (+ (+ (- (* aa-hi bb-hi) p) + (* aa-hi bb-lo) + (* aa-lo bb-hi)) + (* aa-lo bb-lo)))) + (declare (double-float e)) + (locally + (declare (optimize (inhibit-warnings 3))) + ;; If the numbers was scaled down, we need to scale the + ;; result back up. + (when (> a +two970+) + (setf p (* p +two53+) + e (* e +two53+))) + (when (> b +two970+) + (setf p (* p +two53+) + e (* e +two53+))) + (values p e)))))))) + +#+ppc +(defun two-prod (a b) + _N"Compute fl(a*b) and err(a*b)" + (declare (double-float a b)) + ;; PPC has a fused multiply-subtract instruction that can be used + ;; here, so use it. + (let* ((p (* a b)) + (err (vm::fused-multiply-subtract a b p))) + (values p err))) + +(declaim (inline two-sqr)) +#-ppc +(defun two-sqr (a) + _N"Compute fl(a*a) and err(a*b). This is a more efficient + implementation of two-prod" + (declare (double-float a)) + (let ((q (* a a))) + (multiple-value-bind (a-hi a-lo) + (split a) + (locally + (declare (optimize (inhibit-warnings 3))) + (values q (+ (+ (- (* a-hi a-hi) q) + (* 2 a-hi a-lo)) + (* a-lo a-lo))))))) +(defun two-sqr (a) + _N"Compute fl(a*a) and err(a*b). This is a more efficient + implementation of two-prod" + (declare (double-float a)) + (let ((aa (if (> a +two970+) + (* a +two-53+) + a))) + (let ((q (* aa aa))) + (declare (double-float q) + (inline split)) + (multiple-value-bind (a-hi a-lo) + (split aa) + (locally + (declare (optimize (inhibit-warnings 3))) + (let ((e (+ (+ (- (* a-hi a-hi) q) + (* 2 a-hi a-lo)) + (* a-lo a-lo)))) + (if (> a +two970+) + (values (* q +two53+) + (* e +two53+)) + (values q e)))))))) + +#+ppc +(defun two-sqr (a) + _N"Compute fl(a*a) and err(a*b). This is a more efficient + implementation of two-prod" + (declare (double-float a)) + (let ((q (* a a))) + (values q (vm::fused-multiply-subtract a a q)))) + +(declaim (maybe-inline mul-dd-d)) +(defun mul-dd-d (a0 a1 b) + (declare (double-float a0 a1 b) + (optimize (speed 3) + (inhibit-warnings 3))) + (multiple-value-bind (p1 p2) + (two-prod a0 b) + (declare (double-float p2)) + (when (float-infinity-p p1) + (return-from mul-dd-d (values p1 0d0))) + ;;(format t "mul-dd-d p1,p2 = ~A ~A~%" p1 p2) + (incf p2 (* a1 b)) + ;;(format t "mul-dd-d p2 = ~A~%" p2) + (multiple-value-bind (r1 r2) + (quick-two-sum p1 p2) + (when (zerop r1) + (setf r1 (float-sign p1 0d0)) + (setf r2 p1)) + (values r1 r2)))) + +(declaim (maybe-inline mul-dd)) +(defun mul-dd (a0 a1 b0 b1) + "Multiply the double-double A0,A1 with B0,B1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3) + (inhibit-warnings 3))) + (multiple-value-bind (p1 p2) + (two-prod a0 b0) + (declare (double-float p1 p2)) + (when (float-infinity-p p1) + (return-from mul-dd (values p1 0d0))) + (incf p2 (* a0 b1)) + (incf p2 (* a1 b0)) + (multiple-value-bind (r1 r2) + (quick-two-sum p1 p2) + (if (zerop r1) + (values (float-sign p1 0d0) 0d0) + (values r1 r2))))) + +(declaim (maybe-inline add-dd-d)) +(defun add-dd-d (a0 a1 b) + "Add the double-double A0,A1 to the double B" + (declare (double-float a0 a1 b) + (optimize (speed 3) + (inhibit-warnings 3))) + (multiple-value-bind (s1 s2) + (two-sum a0 b) + (declare (double-float s1 s2)) + (when (float-infinity-p s1) + (return-from add-dd-d (values s1 0d0))) + (incf s2 a1) + (multiple-value-bind (r1 r2) + (quick-two-sum s1 s2) + (if (and (zerop a0) (zerop b)) + (values (float-sign (+ a0 b) 0d0) 0d0) + (values r1 r2))))) + +(declaim (maybe-inline sqr-dd)) +(defun sqr-dd (a0 a1) + (declare (double-float a0 a1) + (optimize (speed 3) + (inhibit-warnings 3))) + (multiple-value-bind (p1 p2) + (two-sqr a0) + (declare (double-float p1 p2)) + (incf p2 (* 2 a0 a1)) + ;; Hida's version of sqr (qd-2.1.210) has the following line for + ;; the sqr function. But if you compare this with mul-dd, this + ;; doesn't exist there, and if you leave it in, it produces + ;; results that are different from using mul-dd to square a value. + #+nil + (incf p2 (* a1 a1)) + (quick-two-sum p1 p2))) + +(deftransform + ((a b) (vm::double-double-float (or integer single-float double-float)) + * :node node) + `(multiple-value-bind (hi lo) + (add-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + (float b 1d0)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(deftransform + ((a b) ((or integer single-float double-float) vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (add-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b) + (float a 1d0)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(deftransform * ((a b) (vm::double-double-float vm::double-double-float) + * :node node) + ;; non-const-same-leaf-ref-p is stolen from two-arg-derive-type. + (flet ((non-const-same-leaf-ref-p (x y) + ;; Just like same-leaf-ref-p, but we don't care if the + ;; value of the leaf is constant or not. + (declare (type continuation x y)) + (let ((x-use (continuation-use x)) + (y-use (continuation-use y))) + (and (ref-p x-use) + (ref-p y-use) + (eq (ref-leaf x-use) (ref-leaf y-use)))))) + (destructuring-bind (arg1 arg2) + (combination-args node) + ;; If the two args to * are the same, we square the number + ;; instead of multiply. Squaring is simpler than a full + ;; multiply. + (if (non-const-same-leaf-ref-p arg1 arg2) + `(multiple-value-bind (hi lo) + (sqr-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo))) + `(multiple-value-bind (hi lo) + (mul-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo))))))) + +(deftransform * ((a b) (vm::double-double-float (or integer single-float double-float)) + * :node node) + `(multiple-value-bind (hi lo) + (mul-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + (float b 1d0)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(deftransform * ((a b) ((or integer single-float double-float) vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (mul-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b) + (float a 1d0)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(declaim (maybe-inline div-dd)) +(defun div-dd (a0 a1 b0 b1) + "Divide the double-double A0,A1 by B0,B1" + (declare (double-float a0 a1 b0 b1) + (optimize (speed 3) + (inhibit-warnings 3)) + (inline sub-dd)) + (let ((q1 (/ a0 b0))) + (when (float-infinity-p q1) + (return-from div-dd (values q1 0d0))) + ;; (q1b0, q1b1) = q1*(b0,b1) + ;;(format t "q1 = ~A~%" q1) + (multiple-value-bind (q1b0 q1b1) + (mul-dd-d b0 b1 q1) + ;;(format t "q1*b = ~A ~A~%" q1b0 q1b1) + (multiple-value-bind (r0 r1) + ;; r = a - q1 * b + (sub-dd a0 a1 q1b0 q1b1) + ;;(format t "r = ~A ~A~%" r0 r1) + (let ((q2 (/ r0 b0))) + (multiple-value-bind (q2b0 q2b1) + (mul-dd-d b0 b1 q2) + (multiple-value-bind (r0 r1) + ;; r = r - (q2*b) + (sub-dd r0 r1 q2b0 q2b1) + (declare (ignore r1)) + (let ((q3 (/ r0 b0))) + (multiple-value-bind (q1 q2) + (quick-two-sum q1 q2) + (add-dd-d q1 q2 q3)))))))))) + +(declaim (maybe-inline div-dd-d)) +(defun div-dd-d (a0 a1 b) + (declare (double-float a0 a1 b) + (optimize (speed 3) + (inhibit-warnings 3))) + (let ((q1 (/ a0 b))) + ;; q1 = approx quotient + ;; Now compute a - q1 * b + (multiple-value-bind (p1 p2) + (two-prod q1 b) + (multiple-value-bind (s e) + (two-diff a0 p1) + (declare (double-float e)) + (incf e a1) + (decf e p2) + ;; Next approx + (let ((q2 (/ (+ s e) b))) + (quick-two-sum q1 q2)))))) + +(deftransform / ((a b) (vm::double-double-float vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (div-dd (kernel:double-double-hi a) (kernel:double-double-lo a) + (kernel:double-double-hi b) (kernel:double-double-lo b)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(deftransform / ((a b) (vm::double-double-float (or integer single-float double-float)) + * :node node) + `(multiple-value-bind (hi lo) + (div-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) + (float b 1d0)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(declaim (inline sqr-d)) +(defun sqr-d (a) + "Square" + (declare (double-float a) + (optimize (speed 3) + (inhibit-warnings 3))) + (two-sqr a)) + +(declaim (inline mul-d-d)) +(defun mul-d-d (a b) + (two-prod a b)) + +(declaim (maybe-inline sqrt-dd)) +(defun sqrt-dd (a0 a1) + (declare (type (double-float 0d0) a0) + (double-float a1) + (optimize (speed 3) + (inhibit-warnings 3))) + ;; Strategy: Use Karp's trick: if x is an approximation to sqrt(a), + ;; then + ;; + ;; y = a*x + (a-(a*x)^2)*x/2 + ;; + ;; is an approximation that is accurate to twice the accuracy of x. + ;; Also, the multiplication (a*x) and [-]*x can be done with only + ;; half the precision. + (if (and (zerop a0) (zerop a1)) + (values a0 a1) + (let* ((x (/ (sqrt a0))) + (ax (* a0 x))) + (multiple-value-bind (s0 s1) + (sqr-d ax) + (multiple-value-bind (s2) + (sub-dd a0 a1 s0 s1) + (multiple-value-bind (p0 p1) + (mul-d-d s2 (* x 0.5d0)) + (add-dd-d p0 p1 ax))))))) + +(deftransform sqrt ((a) ((vm::double-double-float 0w0)) + * :node node) + `(multiple-value-bind (hi lo) + (sqrt-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(declaim (inline neg-dd)) +(defun neg-dd (a0 a1) + (declare (double-float a0 a1) + (optimize (speed 3) + (inhibit-warnings 3))) + (values (- a0) (- a1))) + +(declaim (inline abs-dd)) +(defun abs-dd (a0 a1) + (declare (double-float a0 a1) + (optimize (speed 3) + (inhibit-warnings 3))) + (if (minusp a0) + (neg-dd a0 a1) + (values a0 a1))) + +(deftransform abs ((a) (vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (abs-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(deftransform %negate ((a) (vm::double-double-float) + * :node node) + `(multiple-value-bind (hi lo) + (neg-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) + (truly-the ,(type-specifier (node-derived-type node)) + (kernel:%make-double-double-float hi lo)))) + +(declaim (inline dd=)) +(defun dd= (a0 a1 b0 b1) + (and (= a0 b0) + (= a1 b1))) + +(declaim (inline dd<)) +(defun dd< (a0 a1 b0 b1) + (or (< a0 b0) + (and (= a0 b0) + (< a1 b1)))) + +(declaim (inline dd>)) +(defun dd> (a0 a1 b0 b1) + (or (> a0 b0) + (and (= a0 b0) + (> a1 b1)))) + +(deftransform = ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd= (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) + + +(deftransform < ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd< (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) + + +(deftransform > ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd> (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) +) ; end progn ===================================== src/compiler/float-tran.lisp ===================================== --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -38,47 +38,6 @@ (deftransform %double-float ((n) (double-float) * :when :both) 'n) -#+double-double -(progn -(defknown %double-double-float (real) - double-double-float - (movable foldable flushable)) - -(deftransform float ((n prototype) (* double-double-float) * :when :both) - '(%double-double-float n)) - -(deftransform %double-float ((n) (double-double-float) * :when :both) - '(double-double-hi n)) - -(deftransform %single-float ((n) (double-double-float) * :when :both) - '(float (double-double-hi n) 1f0)) - -(deftransform %double-double-float ((n) (double-double-float) * :when :both) - 'n) - -#+nil -(defun %double-double-float (n) - (make-double-double-float (float n 1d0) 0d0)) - -;; Moved to code/float.lisp, because we need this relatively early in -;; the build process to handle float and real types. -#+nil -(defun %double-double-float (n) - (typecase n - (fixnum - (%make-double-double-float (float n 1d0) 0d0)) - (single-float - (%make-double-double-float (float n 1d0) 0d0)) - (double-float - (%make-double-double-float (float n 1d0) 0d0)) - (double-double-float - n) - (bignum - (bignum:bignum-to-float n 'double-double-float)) - (ratio - (kernel::float-ratio n 'double-double-float)))) -); progn - (defknown %complex-single-float (number) (complex single-float) (movable foldable flushable)) (defknown %complex-double-float (number) (complex double-float) @@ -364,27 +323,6 @@ (values (signed-byte 32) (unsigned-byte 32)) (movable foldable flushable)) -#+double-double -(progn -(defknown double-double-float-p (t) - boolean - (movable foldable flushable)) - -(defknown %make-double-double-float (double-float double-float) - double-double-float - (movable foldable flushable)) - - -(defknown double-double-hi (double-double-float) - double-float - (movable foldable flushable)) - -(defknown double-double-lo (double-double-float) - double-float - (movable foldable flushable)) - -) ; progn - (deftransform float-sign ((float &optional float2) (single-float &optional single-float) *) (if float2 @@ -401,18 +339,6 @@ (if (minusp (double-float-high-bits float)) (- ,temp) ,temp))) '(if (minusp (double-float-high-bits float)) -1d0 1d0))) -#+double-double -(deftransform float-sign ((float &optional float2) - (double-double-float &optional double-double-float) *) - (if float2 - (let ((temp (gensym))) - `(let ((,temp (abs float2))) - (if (minusp (float-sign (double-double-hi float))) - (- ,temp) - ,temp))) - '(if (minusp (float-sign (double-double-hi float))) -1w0 1w0))) - - ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, SCALE-FLOAT: ;;; @@ -778,13 +704,6 @@ (%sincos x) (complex c s))) -#+double-double -(deftransform cis ((x) (double-double-float) *) - `(multiple-value-bind (s c) - (kernel::dd-%sincos x) - (complex c s))) - - ;;; The argument range is limited on the x86 FP trig. functions. A ;;; post-test can detect a failure (and load a suitable result), but ;;; this test is avoided if possible. @@ -2170,609 +2089,3 @@ (make-values-type :required (list f e s)))) - -;;; Support for double-double floats -;;; -;;; The algorithms contained herein are based on the code written by -;;; Yozo Hida. See http://www.cs.berkeley.edu/~yozo/ for more -;;; information. - -#+double-double -(progn - -(declaim (inline quick-two-sum)) -(defun quick-two-sum (a b) - "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" - (declare (double-float a b)) - (let* ((s (+ a b)) - (e (- b (- s a)))) - (values s e))) - -(declaim (inline two-sum)) -(defun two-sum (a b) - "Computes fl(a+b) and err(a+b)" - (declare (double-float a b)) - (let* ((s (+ a b)) - (v (- s a)) - (e (+ (- a (- s v)) - (- b v)))) - (locally - (declare (optimize (inhibit-warnings 3))) - (values s e)))) - -(declaim (maybe-inline add-dd)) -(defun add-dd (a0 a1 b0 b1) - "Add the double-double A0,A1 to the double-double B0,B1" - (declare (double-float a0 a1 b0 b1) - (optimize (speed 3) - (inhibit-warnings 3))) - (multiple-value-bind (s1 s2) - (two-sum a0 b0) - (declare (double-float s1 s2)) - (when (float-infinity-p s1) - (return-from add-dd (values s1 0d0))) - (multiple-value-bind (t1 t2) - (two-sum a1 b1) - (declare (double-float t1 t2)) - (incf s2 t1) - (multiple-value-bind (s1 s2) - (quick-two-sum s1 s2) - (declare (double-float s1 s2)) - (incf s2 t2) - (multiple-value-bind (r1 r2) - (quick-two-sum s1 s2) - (if (and (zerop a0) (zerop b0)) - ;; Handle sum of signed zeroes here. - (values (float-sign (+ a0 b0) 0d0) - 0d0) - (values r1 r2))))))) - -(deftransform + ((a b) (vm::double-double-float vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (add-dd (kernel:double-double-hi a) (kernel:double-double-lo a) - (kernel:double-double-hi b) (kernel:double-double-lo b)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(declaim (inline quick-two-diff)) -(defun quick-two-diff (a b) - "Compute fl(a-b) and err(a-b), assuming |a| >= |b|" - (declare (double-float a b)) - (let ((s (- a b))) - (values s (- (- a s) b)))) - -(declaim (inline two-diff)) -(defun two-diff (a b) - "Compute fl(a-b) and err(a-b)" - (declare (double-float a b)) - (let* ((s (- a b)) - (v (- s a)) - (e (- (- a (- s v)) - (+ b v)))) - (locally - (declare (optimize (inhibit-warnings 3))) - (values s e)))) - -(declaim (maybe-inline sub-dd)) -(defun sub-dd (a0 a1 b0 b1) - "Subtract the double-double B0,B1 from A0,A1" - (declare (double-float a0 a1 b0 b1) - (optimize (speed 3) - (inhibit-warnings 3))) - (multiple-value-bind (s1 s2) - (two-diff a0 b0) - (declare (double-float s2)) - (when (float-infinity-p s1) - (return-from sub-dd (values s1 0d0))) - (multiple-value-bind (t1 t2) - (two-diff a1 b1) - (incf s2 t1) - (multiple-value-bind (s1 s2) - (quick-two-sum s1 s2) - (declare (double-float s2)) - (incf s2 t2) - (multiple-value-bind (r1 r2) - (quick-two-sum s1 s2) - (if (and (zerop a0) (zerop b0)) - (values (float-sign (- a0 b0) 0d0) - 0d0) - (values r1 r2))))))) - -(declaim (maybe-inline sub-d-dd)) -(defun sub-d-dd (a b0 b1) - "Compute double-double = double - double-double" - (declare (double-float a b0 b1) - (optimize (speed 3) (safety 0) - (inhibit-warnings 3))) - (multiple-value-bind (s1 s2) - (two-diff a b0) - (declare (double-float s2)) - (when (float-infinity-p s1) - (return-from sub-d-dd (values s1 0d0))) - (decf s2 b1) - (multiple-value-bind (r1 r2) - (quick-two-sum s1 s2) - (if (and (zerop a) (zerop b0)) - (values (float-sign (- a b0) 0d0) 0d0) - (values r1 r2))))) - -(declaim (maybe-inline sub-dd-d)) -(defun sub-dd-d (a0 a1 b) - "Subtract the double B from the double-double A0,A1" - (declare (double-float a0 a1 b) - (optimize (speed 3) (safety 0) - (inhibit-warnings 3))) - (multiple-value-bind (s1 s2) - (two-diff a0 b) - (declare (double-float s2)) - (when (float-infinity-p s1) - (return-from sub-dd-d (values s1 0d0))) - (incf s2 a1) - (multiple-value-bind (r1 r2) - (quick-two-sum s1 s2) - (if (and (zerop a0) (zerop b)) - (values (float-sign (- a0 b) 0d0) 0d0) - (values r1 r2))))) - -(deftransform - ((a b) (vm::double-double-float vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (sub-dd (kernel:double-double-hi a) (kernel:double-double-lo a) - (kernel:double-double-hi b) (kernel:double-double-lo b)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(deftransform - ((a b) (double-float vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (sub-d-dd a - (kernel:double-double-hi b) (kernel:double-double-lo b)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(deftransform - ((a b) (vm::double-double-float double-float) - * :node node) - `(multiple-value-bind (hi lo) - (sub-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) - b) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(declaim (maybe-inline split)) -;; See Listing 2.6: Mul12 in "CR-LIBM: A library of correctly rounded -;; elementary functions in double-precision". Also known as Dekker's -;; algorithm. -(defun split (a) - "Split the double-float number a into a-hi and a-lo such that a = - a-hi + a-lo and a-hi contains the upper 26 significant bits of a and - a-lo contains the lower 26 bits." - (declare (double-float a)) - (let* ((tmp (* a (+ 1 (expt 2 27)))) - (a-hi (- tmp (- tmp a))) - (a-lo (- a a-hi))) - (values a-hi a-lo))) - -;; Values used for scaling in two-prod. These are used to determine -;; if SPLIT might overflow so the value (and result) can be scaled to -;; prevent overflow. -(defconstant +two970+ - (scale-float 1d0 970)) - -(defconstant +two53+ - (scale-float 1d0 53)) - -(defconstant +two-53+ - (scale-float 1d0 -53)) - -(declaim (inline two-prod)) - -;; This is essentially the algorithm given by Listing 2.7 Mul12Cond -;; given in "CR-LIBM: A library of correctly rounded elementary -;; functions in double-precision". -#-ppc -(defun two-prod (a b) - _N"Compute fl(a*b) and err(a*b)" - (declare (double-float a b) - (optimize (speed 3))) - ;; If the numbers are too big, scale them done so SPLIT doesn't overflow. - (multiple-value-bind (aa bb) - (values (if (> a +two970+) - (* a +two-53+) - a) - (if (> b +two970+) - (* b +two-53+) - b)) - (let ((p (* aa bb))) - (declare (double-float p) - (inline split)) - (multiple-value-bind (aa-hi aa-lo) - (split aa) - ;;(format t "aa-hi, aa-lo = ~S ~S~%" aa-hi aa-lo) - (multiple-value-bind (bb-hi bb-lo) - (split bb) - ;;(format t "bb-hi, bb-lo = ~S ~S~%" bb-hi bb-lo) - (let ((e (+ (+ (- (* aa-hi bb-hi) p) - (* aa-hi bb-lo) - (* aa-lo bb-hi)) - (* aa-lo bb-lo)))) - (declare (double-float e)) - (locally - (declare (optimize (inhibit-warnings 3))) - ;; If the numbers was scaled down, we need to scale the - ;; result back up. - (when (> a +two970+) - (setf p (* p +two53+) - e (* e +two53+))) - (when (> b +two970+) - (setf p (* p +two53+) - e (* e +two53+))) - (values p e)))))))) - -#+ppc -(defun two-prod (a b) - _N"Compute fl(a*b) and err(a*b)" - (declare (double-float a b)) - ;; PPC has a fused multiply-subtract instruction that can be used - ;; here, so use it. - (let* ((p (* a b)) - (err (vm::fused-multiply-subtract a b p))) - (values p err))) - -(declaim (inline two-sqr)) -#-ppc -(defun two-sqr (a) - _N"Compute fl(a*a) and err(a*b). This is a more efficient - implementation of two-prod" - (declare (double-float a)) - (let ((q (* a a))) - (multiple-value-bind (a-hi a-lo) - (split a) - (locally - (declare (optimize (inhibit-warnings 3))) - (values q (+ (+ (- (* a-hi a-hi) q) - (* 2 a-hi a-lo)) - (* a-lo a-lo))))))) -(defun two-sqr (a) - _N"Compute fl(a*a) and err(a*b). This is a more efficient - implementation of two-prod" - (declare (double-float a)) - (let ((aa (if (> a +two970+) - (* a +two-53+) - a))) - (let ((q (* aa aa))) - (declare (double-float q) - (inline split)) - (multiple-value-bind (a-hi a-lo) - (split aa) - (locally - (declare (optimize (inhibit-warnings 3))) - (let ((e (+ (+ (- (* a-hi a-hi) q) - (* 2 a-hi a-lo)) - (* a-lo a-lo)))) - (if (> a +two970+) - (values (* q +two53+) - (* e +two53+)) - (values q e)))))))) - -#+ppc -(defun two-sqr (a) - _N"Compute fl(a*a) and err(a*b). This is a more efficient - implementation of two-prod" - (declare (double-float a)) - (let ((q (* a a))) - (values q (vm::fused-multiply-subtract a a q)))) - -(declaim (maybe-inline mul-dd-d)) -(defun mul-dd-d (a0 a1 b) - (declare (double-float a0 a1 b) - (optimize (speed 3) - (inhibit-warnings 3))) - (multiple-value-bind (p1 p2) - (two-prod a0 b) - (declare (double-float p2)) - (when (float-infinity-p p1) - (return-from mul-dd-d (values p1 0d0))) - ;;(format t "mul-dd-d p1,p2 = ~A ~A~%" p1 p2) - (incf p2 (* a1 b)) - ;;(format t "mul-dd-d p2 = ~A~%" p2) - (multiple-value-bind (r1 r2) - (quick-two-sum p1 p2) - (when (zerop r1) - (setf r1 (float-sign p1 0d0)) - (setf r2 p1)) - (values r1 r2)))) - -(declaim (maybe-inline mul-dd)) -(defun mul-dd (a0 a1 b0 b1) - "Multiply the double-double A0,A1 with B0,B1" - (declare (double-float a0 a1 b0 b1) - (optimize (speed 3) - (inhibit-warnings 3))) - (multiple-value-bind (p1 p2) - (two-prod a0 b0) - (declare (double-float p1 p2)) - (when (float-infinity-p p1) - (return-from mul-dd (values p1 0d0))) - (incf p2 (* a0 b1)) - (incf p2 (* a1 b0)) - (multiple-value-bind (r1 r2) - (quick-two-sum p1 p2) - (if (zerop r1) - (values (float-sign p1 0d0) 0d0) - (values r1 r2))))) - -(declaim (maybe-inline add-dd-d)) -(defun add-dd-d (a0 a1 b) - "Add the double-double A0,A1 to the double B" - (declare (double-float a0 a1 b) - (optimize (speed 3) - (inhibit-warnings 3))) - (multiple-value-bind (s1 s2) - (two-sum a0 b) - (declare (double-float s1 s2)) - (when (float-infinity-p s1) - (return-from add-dd-d (values s1 0d0))) - (incf s2 a1) - (multiple-value-bind (r1 r2) - (quick-two-sum s1 s2) - (if (and (zerop a0) (zerop b)) - (values (float-sign (+ a0 b) 0d0) 0d0) - (values r1 r2))))) - -(declaim (maybe-inline sqr-dd)) -(defun sqr-dd (a0 a1) - (declare (double-float a0 a1) - (optimize (speed 3) - (inhibit-warnings 3))) - (multiple-value-bind (p1 p2) - (two-sqr a0) - (declare (double-float p1 p2)) - (incf p2 (* 2 a0 a1)) - ;; Hida's version of sqr (qd-2.1.210) has the following line for - ;; the sqr function. But if you compare this with mul-dd, this - ;; doesn't exist there, and if you leave it in, it produces - ;; results that are different from using mul-dd to square a value. - #+nil - (incf p2 (* a1 a1)) - (quick-two-sum p1 p2))) - -(deftransform + ((a b) (vm::double-double-float (or integer single-float double-float)) - * :node node) - `(multiple-value-bind (hi lo) - (add-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) - (float b 1d0)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(deftransform + ((a b) ((or integer single-float double-float) vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (add-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b) - (float a 1d0)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(deftransform * ((a b) (vm::double-double-float vm::double-double-float) - * :node node) - ;; non-const-same-leaf-ref-p is stolen from two-arg-derive-type. - (flet ((non-const-same-leaf-ref-p (x y) - ;; Just like same-leaf-ref-p, but we don't care if the - ;; value of the leaf is constant or not. - (declare (type continuation x y)) - (let ((x-use (continuation-use x)) - (y-use (continuation-use y))) - (and (ref-p x-use) - (ref-p y-use) - (eq (ref-leaf x-use) (ref-leaf y-use)))))) - (destructuring-bind (arg1 arg2) - (combination-args node) - ;; If the two args to * are the same, we square the number - ;; instead of multiply. Squaring is simpler than a full - ;; multiply. - (if (non-const-same-leaf-ref-p arg1 arg2) - `(multiple-value-bind (hi lo) - (sqr-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo))) - `(multiple-value-bind (hi lo) - (mul-dd (kernel:double-double-hi a) (kernel:double-double-lo a) - (kernel:double-double-hi b) (kernel:double-double-lo b)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo))))))) - -(deftransform * ((a b) (vm::double-double-float (or integer single-float double-float)) - * :node node) - `(multiple-value-bind (hi lo) - (mul-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) - (float b 1d0)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(deftransform * ((a b) ((or integer single-float double-float) vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (mul-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b) - (float a 1d0)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(declaim (maybe-inline div-dd)) -(defun div-dd (a0 a1 b0 b1) - "Divide the double-double A0,A1 by B0,B1" - (declare (double-float a0 a1 b0 b1) - (optimize (speed 3) - (inhibit-warnings 3)) - (inline sub-dd)) - (let ((q1 (/ a0 b0))) - (when (float-infinity-p q1) - (return-from div-dd (values q1 0d0))) - ;; (q1b0, q1b1) = q1*(b0,b1) - ;;(format t "q1 = ~A~%" q1) - (multiple-value-bind (q1b0 q1b1) - (mul-dd-d b0 b1 q1) - ;;(format t "q1*b = ~A ~A~%" q1b0 q1b1) - (multiple-value-bind (r0 r1) - ;; r = a - q1 * b - (sub-dd a0 a1 q1b0 q1b1) - ;;(format t "r = ~A ~A~%" r0 r1) - (let ((q2 (/ r0 b0))) - (multiple-value-bind (q2b0 q2b1) - (mul-dd-d b0 b1 q2) - (multiple-value-bind (r0 r1) - ;; r = r - (q2*b) - (sub-dd r0 r1 q2b0 q2b1) - (declare (ignore r1)) - (let ((q3 (/ r0 b0))) - (multiple-value-bind (q1 q2) - (quick-two-sum q1 q2) - (add-dd-d q1 q2 q3)))))))))) - -(declaim (maybe-inline div-dd-d)) -(defun div-dd-d (a0 a1 b) - (declare (double-float a0 a1 b) - (optimize (speed 3) - (inhibit-warnings 3))) - (let ((q1 (/ a0 b))) - ;; q1 = approx quotient - ;; Now compute a - q1 * b - (multiple-value-bind (p1 p2) - (two-prod q1 b) - (multiple-value-bind (s e) - (two-diff a0 p1) - (declare (double-float e)) - (incf e a1) - (decf e p2) - ;; Next approx - (let ((q2 (/ (+ s e) b))) - (quick-two-sum q1 q2)))))) - -(deftransform / ((a b) (vm::double-double-float vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (div-dd (kernel:double-double-hi a) (kernel:double-double-lo a) - (kernel:double-double-hi b) (kernel:double-double-lo b)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(deftransform / ((a b) (vm::double-double-float (or integer single-float double-float)) - * :node node) - `(multiple-value-bind (hi lo) - (div-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a) - (float b 1d0)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(declaim (inline sqr-d)) -(defun sqr-d (a) - "Square" - (declare (double-float a) - (optimize (speed 3) - (inhibit-warnings 3))) - (two-sqr a)) - -(declaim (inline mul-d-d)) -(defun mul-d-d (a b) - (two-prod a b)) - -(declaim (maybe-inline sqrt-dd)) -(defun sqrt-dd (a0 a1) - (declare (type (double-float 0d0) a0) - (double-float a1) - (optimize (speed 3) - (inhibit-warnings 3))) - ;; Strategy: Use Karp's trick: if x is an approximation to sqrt(a), - ;; then - ;; - ;; y = a*x + (a-(a*x)^2)*x/2 - ;; - ;; is an approximation that is accurate to twice the accuracy of x. - ;; Also, the multiplication (a*x) and [-]*x can be done with only - ;; half the precision. - (if (and (zerop a0) (zerop a1)) - (values a0 a1) - (let* ((x (/ (sqrt a0))) - (ax (* a0 x))) - (multiple-value-bind (s0 s1) - (sqr-d ax) - (multiple-value-bind (s2) - (sub-dd a0 a1 s0 s1) - (multiple-value-bind (p0 p1) - (mul-d-d s2 (* x 0.5d0)) - (add-dd-d p0 p1 ax))))))) - -(deftransform sqrt ((a) ((vm::double-double-float 0w0)) - * :node node) - `(multiple-value-bind (hi lo) - (sqrt-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(declaim (inline neg-dd)) -(defun neg-dd (a0 a1) - (declare (double-float a0 a1) - (optimize (speed 3) - (inhibit-warnings 3))) - (values (- a0) (- a1))) - -(declaim (inline abs-dd)) -(defun abs-dd (a0 a1) - (declare (double-float a0 a1) - (optimize (speed 3) - (inhibit-warnings 3))) - (if (minusp a0) - (neg-dd a0 a1) - (values a0 a1))) - -(deftransform abs ((a) (vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (abs-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(deftransform %negate ((a) (vm::double-double-float) - * :node node) - `(multiple-value-bind (hi lo) - (neg-dd (kernel:double-double-hi a) (kernel:double-double-lo a)) - (truly-the ,(type-specifier (node-derived-type node)) - (kernel:%make-double-double-float hi lo)))) - -(declaim (inline dd=)) -(defun dd= (a0 a1 b0 b1) - (and (= a0 b0) - (= a1 b1))) - -(declaim (inline dd<)) -(defun dd< (a0 a1 b0 b1) - (or (< a0 b0) - (and (= a0 b0) - (< a1 b1)))) - -(declaim (inline dd>)) -(defun dd> (a0 a1 b0 b1) - (or (> a0 b0) - (and (= a0 b0) - (> a1 b1)))) - -(deftransform = ((a b) (vm::double-double-float vm::double-double-float) *) - `(dd= (kernel:double-double-hi a) - (kernel:double-double-lo a) - (kernel:double-double-hi b) - (kernel:double-double-lo b))) - - -(deftransform < ((a b) (vm::double-double-float vm::double-double-float) *) - `(dd< (kernel:double-double-hi a) - (kernel:double-double-lo a) - (kernel:double-double-hi b) - (kernel:double-double-lo b))) - - -(deftransform > ((a b) (vm::double-double-float vm::double-double-float) *) - `(dd> (kernel:double-double-hi a) - (kernel:double-double-lo a) - (kernel:double-double-hi b) - (kernel:double-double-lo b))) - -) ; progn double-double ===================================== src/compiler/loadcom.lisp ===================================== --- a/src/compiler/loadcom.lisp +++ b/src/compiler/loadcom.lisp @@ -32,6 +32,7 @@ (load "vm:vm-typetran") (load "vm:vm-tran") (load "c:float-tran") +(load "c:float-tran-dd") (load "c:saptran") (load "c:srctran") (load "c:locall") ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -18776,68 +18776,68 @@ msgstr "" msgid "Float zero bound ~s not correctly canonicalised?" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Compute fl(a*b) and err(a*b)" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "" "Compute fl(a*a) and err(a*b). This is a more efficient\n" " implementation of two-prod" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Computes fl(a+b) and err(a+b)" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Add the double-double A0,A1 to the double-double B0,B1" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Compute fl(a-b) and err(a-b), assuming |a| >= |b|" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Compute fl(a-b) and err(a-b)" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Subtract the double-double B0,B1 from A0,A1" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Compute double-double = double - double-double" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Subtract the double B from the double-double A0,A1" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "" "Split the double-float number a into a-hi and a-lo such that a =\n" " a-hi + a-lo and a-hi contains the upper 26 significant bits of a and\n" " a-lo contains the lower 26 bits." msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Multiply the double-double A0,A1 with B0,B1" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Add the double-double A0,A1 to the double B" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Divide the double-double A0,A1 by B0,B1" msgstr "" -#: src/compiler/float-tran.lisp +#: src/compiler/float-tran-dd.lisp msgid "Square" msgstr "" ===================================== src/tools/comcom.lisp ===================================== --- a/src/tools/comcom.lisp +++ b/src/tools/comcom.lisp @@ -121,6 +121,7 @@ (comf "target:compiler/typetran" :byte-compile *byte-compile*) (comf "target:compiler/generic/vm-typetran" :byte-compile *byte-compile*) (comf "target:compiler/float-tran" :byte-compile *byte-compile*) +(comf "target:compiler/float-tran-dd" :byte-compile *byte-compile*) (comf "target:compiler/saptran" :byte-compile *byte-compile*) (comf "target:compiler/srctran") ;; try (comf "target:compiler/locall") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/65a61bdbf178b151a633825e…

1 0