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

[Git][cmucl/cmucl][rtoy-setexception-inexact] 3 commits: Use setexception to raise the inexact exception for asin.
by Raymond Toy 23 Dec '15

23 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: e655d017 by Raymond Toy at 2015-12-23T14:30:10Z Use setexception to raise the inexact exception for asin. o Add tests for this o Use setexception for inexact in e_asin.c. - - - - - 8b36c06e by Raymond Toy at 2015-12-23T15:48:58Z Group the inexact exception test with the exceptions tests. - - - - - b4c91767 by Raymond Toy at 2015-12-23T15:55:19Z Use setexception to raise the inexact exception for exp. o Add tests for this o Use setexception for inexact in e_exp.c. - - - - - 3 changed files: - src/lisp/e_asin.c - src/lisp/e_exp.c - tests/fdlibm.lisp Changes: ===================================== src/lisp/e_asin.c ===================================== --- a/src/lisp/e_asin.c +++ b/src/lisp/e_asin.c @@ -89,7 +89,12 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ return fdlibm_setexception(x, FDLIBM_INVALID); } else if (ix<0x3fe00000) { /* |x|<0.5 */ if(ix<0x3e400000) { /* if |x| < 2**-27 */ - if(huge+x>one) return x;/* return x with inexact if x!=0*/ + /* return x inexact except 0 */ + if (x != 0) { + fdlibm_setexception(x, FDLIBM_INEXACT); + } + + return x; } else t = x*x; p = t*(pS0+t*(pS1+t*(pS2+t*(pS3+t*(pS4+t*pS5))))); ===================================== src/lisp/e_exp.c ===================================== --- a/src/lisp/e_exp.c +++ b/src/lisp/e_exp.c @@ -161,7 +161,12 @@ P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ x = hi - lo; } else if(hx < 0x3e300000) { /* when |x|<2**-28 */ - if(huge+x>one) return one+x;/* trigger inexact */ + /* return x inexact except 0 */ + if (x != 0) { + fdlibm_setexception(x, FDLIBM_INEXACT); + } + + return one + x; } else k = 0; ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -106,7 +106,18 @@ (assert-error ext:double-float-negative-infinity (kernel:%asinh ext:double-float-negative-infinity))) (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%asinh *snan*))))) + (assert-true (ext:float-nan-p (kernel:%asinh *snan*)))) + (let ((x (scale-float 1d0 -29)) + (x0 0d0)) + (with-inexact-exception-enabled + ;; This must not throw an inexact exception because the result + ;; is exact when the arg is 0. + (assert-eql 0d0 (asinh x0))) + (with-inexact-exception-enabled + ;; This must throw an inexact exception for non-zero x even + ;; though the result is exactly x. + (assert-error 'floating-point-inexact + (asinh x))))) (define-test %atanh.exceptions (:tag :fdlibm) @@ -176,7 +187,19 @@ (ext:set-floating-point-modes :traps '(:underflow)) (assert-error 'floating-point-underflow (kernel:%exp -1000d0))) - (apply #'ext:set-floating-point-modes modes)))) + (apply #'ext:set-floating-point-modes modes))) + (let ((x (scale-float 1d0 -29)) + (x0 0d0)) + ;; exp(x) = x, |x| < 2^-28, with inexact exception unlees x = 0 + (with-inexact-exception-enabled + ;; This must not throw an inexact exception because the result + ;; is exact when the arg is 0. + (assert-eql 1d0 (kernel:%exp x0))) + (with-inexact-exception-enabled + ;; This must throw an inexact exception for non-zero x even + ;; though the result is exactly x. + (assert-error 'floating-point-inexact + (kernel:%exp x))))) (define-test %log.exception (:tag :fdlibm) @@ -298,16 +321,7 @@ (x0 0d0)) ;; asinh(x) = x for x < 2^-28 (assert-eql x (asinh x)) - (assert-eql (- x) (asinh (- x))) - (with-inexact-exception-enabled - ;; This must not throw an inexact exception because the result - ;; is exact when the arg is 0. - (assert-eql 0d0 (asinh x0))) - (with-inexact-exception-enabled - ;; This must throw an inexact exception for non-zero x even - ;; though the result is exactly x. - (assert-error 'floating-point-inexact - (asinh x)))) + (assert-eql (- x) (asinh (- x)))) (let ((x (scale-float 1d0 -28))) ;; Case 2 > |x| >= 2^-28 (assert-eql 3.725290298461914d-9 (asinh x)) @@ -556,4 +570,30 @@ (assert-eql -1d0 (tanh -100d0)) ;; tanh(1d300), no overflow (assert-eql 1d0 (tanh most-positive-double-float)) - (assert-eql -1d0 (tanh (- most-positive-double-float)))) \ No newline at end of file + (assert-eql -1d0 (tanh (- most-positive-double-float)))) + +(define-test %asin-basic-tests + (:tag :fdlibm) + (let ((x (scale-float 1d0 -28)) + (x0 0d0)) + ;; asin(x) = x for |x| < 2^-27, with inexact exception if x is not 0. + (assert-eql x (kernel:%asin x)) + (assert-eql (- x) (kernel:%asin (- x))))) + +(define-test %asin-exception + (:tag :fdlibm) + (let ((x (scale-float 1d0 -28)) + (x0 0d0)) + ;; asin(x) = x for |x| < 2^-27, with inexact exception if x is not 0. + (assert-eql x (kernel:%asin x)) + (assert-eql (- x) (kernel:%asin (- x))) + (with-inexact-exception-enabled + ;; This must not throw an inexact exception because the result + ;; is exact when the arg is 0. + (assert-eql 0d0 (kernel:%asin x0))) + (with-inexact-exception-enabled + ;; This must throw an inexact exception for non-zero x even + ;; though the result is exactly x. + (assert-error 'floating-point-inexact + (kernel:%asin x))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/0d53bc7f4a6713baf3b60149…

1 0

[Git][cmucl/cmucl][rtoy-setexception-inexact] 2 commits: Add inexact exception test for asinh.
by Raymond Toy 23 Dec '15

23 Dec '15

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl Commits: 507f6d9e by Raymond Toy at 2015-12-22T21:35:14Z Add inexact exception test for asinh. - - - - - 0d53bc7f by Raymond Toy at 2015-12-23T14:24:49Z Merge branch 'master' into rtoy-setexception-inexact - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -14,6 +14,15 @@ (kernel:make-double-float #x7ff00000 1) "A randon signaling MaN value") +(defmacro with-inexact-exception-enabled (&body body) + (let ((old-modes (gensym "OLD-MODES-"))) + `(let ((,old-modes (ext:get-floating-point-modes))) + (unwind-protect + (progn + (ext:set-floating-point-modes :traps '(:inexact)) + ,@body) + (apply 'ext:set-floating-point-modes ,old-modes))))) + (define-test %cosh.exceptions (:tag :fdlibm) (assert-error 'floating-point-overflow @@ -285,10 +294,20 @@ (:tag :fdlibm) (assert-eql -0d0 (asinh -0d0)) (assert-eql 0d0 (asinh 0d0)) - (let ((x (scale-float 1d0 -29))) + (let ((x (scale-float 1d0 -29)) + (x0 0d0)) ;; asinh(x) = x for x < 2^-28 (assert-eql x (asinh x)) - (assert-eql (- x) (asinh (- x)))) + (assert-eql (- x) (asinh (- x))) + (with-inexact-exception-enabled + ;; This must not throw an inexact exception because the result + ;; is exact when the arg is 0. + (assert-eql 0d0 (asinh x0))) + (with-inexact-exception-enabled + ;; This must throw an inexact exception for non-zero x even + ;; though the result is exactly x. + (assert-error 'floating-point-inexact + (asinh x)))) (let ((x (scale-float 1d0 -28))) ;; Case 2 > |x| >= 2^-28 (assert-eql 3.725290298461914d-9 (asinh x)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/a53d7ef42da5bf984ae51dc4…

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-setexception-inexact
by Raymond Toy 23 Dec '15

23 Dec '15

Raymond Toy pushed new branch rtoy-setexception-inexact at cmucl / cmucl

1 0

[Git][cmucl/cmucl][master] Add inexact exception test for asinh.
by Raymond Toy 23 Dec '15

23 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 507f6d9e by Raymond Toy at 2015-12-22T21:35:14Z Add inexact exception test for asinh. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -14,6 +14,15 @@ (kernel:make-double-float #x7ff00000 1) "A randon signaling MaN value") +(defmacro with-inexact-exception-enabled (&body body) + (let ((old-modes (gensym "OLD-MODES-"))) + `(let ((,old-modes (ext:get-floating-point-modes))) + (unwind-protect + (progn + (ext:set-floating-point-modes :traps '(:inexact)) + ,@body) + (apply 'ext:set-floating-point-modes ,old-modes))))) + (define-test %cosh.exceptions (:tag :fdlibm) (assert-error 'floating-point-overflow @@ -285,10 +294,20 @@ (:tag :fdlibm) (assert-eql -0d0 (asinh -0d0)) (assert-eql 0d0 (asinh 0d0)) - (let ((x (scale-float 1d0 -29))) + (let ((x (scale-float 1d0 -29)) + (x0 0d0)) ;; asinh(x) = x for x < 2^-28 (assert-eql x (asinh x)) - (assert-eql (- x) (asinh (- x)))) + (assert-eql (- x) (asinh (- x))) + (with-inexact-exception-enabled + ;; This must not throw an inexact exception because the result + ;; is exact when the arg is 0. + (assert-eql 0d0 (asinh x0))) + (with-inexact-exception-enabled + ;; This must throw an inexact exception for non-zero x even + ;; though the result is exactly x. + (assert-error 'floating-point-inexact + (asinh x)))) (let ((x (scale-float 1d0 -28))) ;; Case 2 > |x| >= 2^-28 (assert-eql 3.725290298461914d-9 (asinh x)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/507f6d9e658dd231fb22b8402…

1 0

[Git][cmucl/cmucl][master] Add tanh tests.
by Raymond Toy 20 Dec '15

20 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 4b556124 by Raymond Toy at 2015-12-20T12:38:54Z Add tanh tests. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -515,3 +515,26 @@ (assert-error 'floating-point-overflow (sinh (- x)))) (assert-error 'floating-point-overflow (sinh 1000d0)) (assert-error 'floating-point-overflow (sinh -1000d0))) + +(define-test tanh-basic-tests + (:tag :fdlibm) + ;; case |x| < 2^-55 + (let ((x (scale-float 1d0 -56))) + (assert-eql x (tanh x)) + (assert-eql (- x) (tanh (- x)))) + ;; tanh(log(2)) = 3/5, case |x| < 1 + (let ((x (log 2d0)) + (y (float 3/5 1d0))) + (assert-eql y (tanh x)) + (assert-eql (- y) (tanh (- x)))) + ;; tanh(2*log(2)) = 15/17, case |x| < 22 + (let ((x (* 2 (log 2d0))) + (y (float 15/17 1d0))) + (assert-eql y (tanh x)) + (assert-eql (- y) (tanh (- x)))) + ;; tanh(100) = 1, case |x| > 22 + (assert-eql 1d0 (tanh 100d0)) + (assert-eql -1d0 (tanh -100d0)) + ;; tanh(1d300), no overflow + (assert-eql 1d0 (tanh most-positive-double-float)) + (assert-eql -1d0 (tanh (- most-positive-double-float)))) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/4b5561248417690e415cf6152…

1 0

[Git][cmucl/cmucl][master] 2 commits: Add log tests.
by Raymond Toy 20 Dec '15

20 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 106b9498 by Raymond Toy at 2015-12-20T12:18:26Z Add log tests. - - - - - d1ef807a by Raymond Toy at 2015-12-20T12:33:05Z Add sinh tests. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -403,3 +403,115 @@ (assert-error 'floating-point-overflow (exp 1000d0)) ;; exp(-1000) underflow (assert-eql 0d0 (exp -1000d0))) + +(define-test log-basic-tests + (:tag :fdlibm) + (assert-eql 0d0 (log 1d0)) + (assert-eql 1d0 (log (exp 1d0))) + (assert-eql -1d0 (log (exp -1d0))) + (assert-eql 0.5d0 (log (sqrt (exp 1d0)))) + (assert-eql -0.5d0 (log (sqrt (exp -1d0)))) + ;; Test a denormal arg + (assert-eql -709.08956571282410d0 (log (scale-float 1d0 -1023))) + ;; Largest double value + (assert-eql 709.7827128933840d0 (log most-positive-double-float)) + ;; Tests case 0 < f < 2^-20, k = 0 + ;; log(1+2^-21) + (assert-eql 4.7683704451632344d-7 (log (+ 1 (scale-float 1d0 -21)))) + ;; Tests case 0 < f < 2^-20, k = 1 + ;; log(2 + 2^-20) + (assert-eql 0.6931476573969898d0 (log (+ 2(scale-float 1d0 -20)))) + (assert-eql 1.3862943611198906d0 (log 4d0)) + ;; Tests main path, i > 0, k = 0 + (assert-eql 0.3220828910287846d0 + (log (kernel:make-double-float (+ #x3ff00000 #x6147a) 0))) + ;; Tests main path, i > 0, k = 1 + (assert-eql 0.35065625373947773d0 + (log (kernel:make-double-float (+ #x3ff00000 #x6b851) 0))) + ;; Tests main path, i > 0, k = -1 + (assert-eql -0.3710642895311607d0 + (log (kernel:make-double-float (+ #x3fe00000 #x6147a) 0))) + ;; Tests main path, i < 0, k = 0 + (assert-eql 0.3220821999597803d0 + (log (kernel:make-double-float (+ #x3ff00000 #x61479) 0))) + ;; Tests main path, i < 0, k = 1 + (assert-eql 1.0152293805197257d0 + (log (kernel:make-double-float (+ #x40000000 #x61479) 0))) + ;; Tests main path, i < 0, k = -1 + (assert-eql -0.37106498060016496d0 + (log (kernel:make-double-float (+ #x3fe00000 #x61479) 0)))) + +(define-test log-consistency + (:tag :fdlibm) + ;; |log(x) + log(1/x)| < 1.77635684e-15, x = 1.2^k, 0 <= k < 2000 + ;; The threshold is experimentally determined + (let ((x 1d0) + (max-value -1d0)) + (declare (double-float max-value) + (type (double-float 1d0) x)) + (dotimes (k 2000) + (let ((y (abs (+ (log x) (log (/ x)))))) + (setf max-value (max max-value y)) + (setf x (* x 1.4d0)))) + (assert-true (< max-value 1.77635684d-15))) + ;; |exp(log(x)) - x|/x < 5.6766649d-14, x = 1.4^k, 0 <= k < 2000 + (let ((x 1d0) + (max-error 0d0)) + (declare (double-float max-error) + (type (double-float 1d0) x)) + (dotimes (k 2000) + (let ((y (abs (/ (- (exp (log x)) x) x)))) + (setf max-error (max max-error y)) + (setf x (* x 1.4d0)))) + (assert-true (< max-error 5.6766649d-14))) + ;; |exp(log(x)) - x|/x < 5.68410245d-14, x = 1.4^(-k), 0 <= k < 2000 + (let ((x 1d0) + (max-error 0d0)) + (declare (double-float max-error) + (type (double-float (0d0)) x)) + (dotimes (k 2000) + (let ((y (abs (/ (- (exp (log x)) x) x)))) + (setf max-error (max max-error y)) + (setf x (/ x 1.4d0)))) + (assert-true (< max-error 5.68410245d-14)))) + +(define-test sinh-basic-tests + (:tag :fdlibm) + (assert-eql +0d0 (sinh 0d0)) + (assert-eql -0d0 (sinh -0d0)) + ;; sinh(x) = x, |x| < 2^-28 + (let ((x (scale-float 1d0 -29))) + (assert-eql x (sinh x)) + (assert-eql (- x) (sinh (- x)))) + ;; case |x| < 1 + (assert-eql 0.5210953054937474d0 (sinh 0.5d0)) + (assert-eql -0.5210953054937474d0 (sinh -0.5d0)) + ;; sinh(10*log(2)) = 1048575/2048, case |x| < 22 + (let ((x (* 10 (log 2d0))) + (y (float 1048575/2048 1d0))) + (assert-eql y (sinh x)) + (assert-eql (- y) (sinh (- x)))) + ;; sinh(10), case |x| < 22 + (let ((y 11013.232874703393d0)) + (assert-eql y (sinh 10d0)) + (assert-eql (- y) (sinh -10d0))) + ;; sinh(32*log(2)), case |x| in [22, log(maxdouble)] + (let ((x (* 32 (log 2d0))) + (y 2.1474836479999983d9)) + (assert-eql y (sinh x)) + (assert-eql (- y) (sinh (- x)))) + ;; sinh(100), case |x| in [22, log(maxdouble)] + (let ((y 1.3440585709080678d43)) + (assert-eql y (sinh 100d0)) + (assert-eql (- y) (sinh -100d0))) + ;; sinh(710....), no overflow, case |x| in [log(maxdouble), overflowthreshold] + (let ((x 710.4758600739439d0) + (y 1.7976931348621744d308)) + (assert-eql y (sinh x)) + (assert-eql (- y) (sinh (- x)))) + ;; sinh(710.475860073944), overflow, case |x| > ovfthreshold] + (let ((x 710.475860073944d0)) + (assert-error 'floating-point-overflow (sinh x)) + (assert-error 'floating-point-overflow (sinh (- x)))) + (assert-error 'floating-point-overflow (sinh 1000d0)) + (assert-error 'floating-point-overflow (sinh -1000d0))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/4c29796b2ba54474fff55a48…

1 0

[Git][cmucl/cmucl][master] Add exp tests.
by Raymond Toy 19 Dec '15

19 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 4c29796b by Raymond Toy at 2015-12-19T10:29:09Z Add exp tests. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -362,3 +362,44 @@ (let ((x 710.4758600739439d0)) (assert-eql 1.7976931348621744d308 (cosh x)) (assert-eql 1.7976931348621744d308 (cosh (- x))))) + +(define-test exp-basic-tests + (:tag :fdlibm) + ;; No overflow and no underflow + (let ((x 709.7822265625d0)) + (assert-eql 1.7968190737295725d308 (exp x)) + (assert-eql 5.565390609552841d-309 (exp (- x)))) + ;; exp(7.09782712893383973096e+02), no overflow + (assert-eql 1.7976931348622732d308 (exp 7.09782712893383973096d+02)) + ;; exp(-7.45133219101941108420e+02), no underflow + (assert-eql 4.9406564584124654d-324 (exp -7.45133219101941108420d+02)) + ;; Overflow + (assert-error 'floating-point-overflow (exp 709.7827128933841d0)) + ;; Case |x| < 2^-28 + (let ((x (scale-float 1d0 -29))) + (assert-eql (+ 1 x) (exp x)) + (assert-eql (- 1 x) (exp (- x)))) + ;; exp(0.5), case log(2)/2 < |x| < 3/2*log(2) + (let ((x 0.5d0)) + (assert-eql 1.6487212707001282d0 (exp x)) + (assert-eql 0.6065306597126334d0 (exp (- x)))) + ;; exp(2), case |x| > 3/2*log(2) + (let ((x 2d0)) + (assert-eql 7.38905609893065d0 (exp x)) + (assert-eql 0.1353352832366127d0 (exp (- x)))) + ;; exp(2^-1022), case k < -1021 + (assert-eql 1d0 (exp (scale-float 1d0 -1022))) + ;; exp(2^-1021), case k >= -1021 + (assert-eql 1d0 (exp (scale-float 1d0 -1021))) + ;; exp(7.09782712893383973096e+02), no overflow + (assert-eql 1.7976931348622732d308 (exp 7.09782712893383973096d+02)) + ;; overflow + (assert-error 'floating-point-overflow (exp 709.7827128933841d0)) + ;; exp(-7.45133219101941108420e+02), no underflow + (assert-eql 4.9406564584124654d-324 (exp -745.1332191019411d0)) + ;; exp(-745.1332191019412), underflows + (assert-eql 0d0 (exp -745.1332191019412d0)) + ;; exp(1000) overflow + (assert-error 'floating-point-overflow (exp 1000d0)) + ;; exp(-1000) underflow + (assert-eql 0d0 (exp -1000d0))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/4c29796b2ba54474fff55a484…

1 0

[Git][cmucl/cmucl][master] Add cosh tests.
by Raymond Toy 19 Dec '15

19 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: aeff3c51 by Raymond Toy at 2015-12-19T09:55:25Z Add cosh tests. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -332,4 +332,33 @@ ;; There's no guarantee that atanh(3/4) = log(7)2 in floating ;; point, but it's true in this case with fdlibm (assert-eql (/ (log 7d0) 2) (atanh x)))) - \ No newline at end of file + +(define-test cosh-basic-tests + (:tag :fdlibm) + ;; cosh(2^-55) = 1, tiny x case + (let ((x (scale-float 1d0 -55))) + (assert-eql 1d0 (cosh x)) + (assert-eql 1d0 (cosh (- x)))) + ;; cosh(2^-55) = 1, tiny x case + (let ((x (scale-float 1d0 -56))) + (assert-eql 1d0 (cosh x)) + (assert-eql 1d0 (cosh (- x)))) + ;; cosh(log(2)/4) = (sqrt(2) + 1)/2^(5/4), case |x| < log(2)/2 + (let ((x (/ (log 2d0) 4))) + ;; This depends on (/ (log 2d0) 4) producing the value we really + ;; want as the arg. + (assert-eql 1.0150517651282178d0 (cosh x)) + (assert-eql 1.0150517651282178d0 (cosh (- x)))) + ;; cosh(10*log(2)) = 1048577/2048, case log(2)/2 < |x| < 22 + (let ((x (* 10 (log 2d0))) + (y (float 1048577/2048 1d0))) + (assert-eql y (cosh x)) + (assert-eql y (cosh (- x)))) + ;; cosh(32*log(2)), case 22 <= |x| < log(maxdouble) + (let ((x (* 32 (log 2d0)))) + (assert-eql 2.1474836479999983d9 (cosh x)) + (assert-eql 2.1474836479999983d9 (cosh (- x)))) + ;; cosh(710.4758600739439), case log(maxdouble) <= |x| <= overflowthreshold + (let ((x 710.4758600739439d0)) + (assert-eql 1.7976931348621744d308 (cosh x)) + (assert-eql 1.7976931348621744d308 (cosh (- x))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/aeff3c51eb1c62e21b4ca9a86…

1 0

[Git][cmucl/cmucl][master] Add atanh tests.
by Raymond Toy 19 Dec '15

19 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: fab01803 by Raymond Toy at 2015-12-19T09:46:21Z Add atanh tests. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -310,6 +310,26 @@ (assert-eql 710.4758600739439d0 (asinh x)) (assert-eql -710.4758600739439d0 (asinh (- x))))) - - - \ No newline at end of file +(define-test atanh-basic-tests + (:tag :fdlibm) + (assert-eql +0d0 (atanh +0d0)) + (assert-eql -0d0 (atanh -0d0)) + ;; atanh(x) = x, |x| < 2^-28 + (let ((x (scale-float 1d0 -29))) + (assert-eql x (atanh x)) + (assert-eql (- x) (atanh (- x)))) + ;; atanh(0.25) = log(5/3)/2, |x| < 0.5 + (let ((x 0.25d0)) + (assert-eql 0.25541281188299536d0 (atanh x)) + (assert-eql -0.25541281188299536d0 (atanh (- x))) + ;; There's no guarantee that atanh(1/4) = log(5/3)2 in floating + ;; point, but it's true in this case with fdlibm + (assert-eql (/ (log (float 5/3 1d0)) 2) (atanh x))) + ;; atanh(0.75) = log(7)/2, 0.5 < |x| < 1 + (let ((x 0.75d0)) + (assert-eql 0.9729550745276566d0 (atanh x)) + (assert-eql -0.9729550745276566d0 (atanh (- x))) + ;; There's no guarantee that atanh(3/4) = log(7)2 in floating + ;; point, but it's true in this case with fdlibm + (assert-eql (/ (log 7d0) 2) (atanh x)))) + \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/fab01803f386f8a7ce697ea58…

1 0

[Git][cmucl/cmucl][master] Add acosh tests.
by Raymond Toy 19 Dec '15

19 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9e8b92a9 by Raymond Toy at 2015-12-19T09:38:25Z Add acosh tests. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -268,6 +268,19 @@ (kernel:%scalbn most-negative-double-float 2)))) ;;; These tests taken from github.com/rtoy/fdlibm-js +(define-test acosh-basic-tests + (:tag :fdlibm) + ;; acosh(1) = 0 + (assert-eql 0d0 (acosh 1d0)) + ;; acosh(1.5) = log((sqrt(5)+3)/2, case 1 < x < 2 + (assert-eql 0.9624236501192069d0 (acosh 1.5d0)) + ;; acosh(4) = log(sqrt(15)+4), case 2 < x < 2^28 + (assert-eql 2.0634370688955608d0 (acosh 4d0)) + ;; acosh(2^50), case 2^28 < x + (assert-eql 35.35050620855721d0 (acosh (scale-float 1d0 50))) + ;; No overflow for most positive + (assert-eql 710.4758600739439d0 (acosh most-positive-double-float))) + (define-test asinh-basic-tests (:tag :fdlibm) (assert-eql -0d0 (asinh -0d0)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/9e8b92a941b2b16aade0a9ec8…

1 0

[Git][cmucl/cmucl][master] Add tests for asinh, taken from fdlibm-js.
by Raymond Toy 19 Dec '15

19 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1d604dc6 by Raymond Toy at 2015-12-19T09:32:37Z Add tests for asinh, taken from fdlibm-js. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== --- a/tests/fdlibm.lisp +++ b/tests/fdlibm.lisp @@ -266,3 +266,37 @@ (kernel:%scalbn most-positive-double-float 2)) (assert-equal ext:double-float-negative-infinity (kernel:%scalbn most-negative-double-float 2)))) + +;;; These tests taken from github.com/rtoy/fdlibm-js +(define-test asinh-basic-tests + (:tag :fdlibm) + (assert-eql -0d0 (asinh -0d0)) + (assert-eql 0d0 (asinh 0d0)) + (let ((x (scale-float 1d0 -29))) + ;; asinh(x) = x for x < 2^-28 + (assert-eql x (asinh x)) + (assert-eql (- x) (asinh (- x)))) + (let ((x (scale-float 1d0 -28))) + ;; Case 2 > |x| >= 2^-28 + (assert-eql 3.725290298461914d-9 (asinh x)) + (assert-eql -3.725290298461914d-9 (asinh (- x)))) + (let ((x 1d0)) + ;; Case 2 > |x| >= 2^-28 + (assert-eql 0.881373587019543d0 (asinh x)) + (assert-eql -0.881373587019543d0 (asinh (- x)))) + (let ((x 5d0)) + ;; Case 2^28 > |x| > 2 + (assert-eql 2.3124383412727525d0 (asinh x)) + (assert-eql -2.3124383412727525d0 (asinh (- x)))) + (let ((x (scale-float 1d0 28))) + ;; Case 2^28 > |x| + (assert-eql 20.101268236238415d0 (asinh x)) + (assert-eql -20.101268236238415d0 (asinh (- x)))) + (let ((x most-positive-double-float)) + ;; No overflow for most-positive-double-float + (assert-eql 710.4758600739439d0 (asinh x)) + (assert-eql -710.4758600739439d0 (asinh (- x))))) + + + + \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1d604dc615d00763f303fb035…

1 0

[Git][cmucl/cmucl][rtoy-mmap-anon-control-and-binding-stacks] 10 commits: Rename arguments to RENAME-PACKAGE and update docstring
by Raymond Toy 14 Dec '15

14 Dec '15

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/70f15c09eb7c4cb656ab3802…

1 0

[Git][cmucl/cmucl] Pushed new tag snapshot-2015-12
by Raymond Toy 12 Dec '15

12 Dec '15

Raymond Toy pushed new tag snapshot-2015-12 at cmucl / cmucl

1 0

[Git][cmucl/cmucl][master] Update lisp-unit.
by Raymond Toy 12 Dec '15

12 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: c91ff829 by Raymond Toy at 2015-12-12T08:51:40Z Update lisp-unit. - - - - - 3 changed files: - src/contrib/lisp-unit/internal-test/example-tests.lisp - src/contrib/lisp-unit/lisp-unit.lisp - src/general-info/release-21b.txt Changes: ===================================== 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 @@ -43,6 +43,7 @@ New in this release: * 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: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/c91ff8298e9007102a71242c8…

1 0

[Git][cmucl/cmucl][master] New implementation of the digit shifters.
by Raymond Toy 12 Dec '15

12 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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. - - - - - 1 changed file: - src/compiler/x86/arith.lisp Changes: ===================================== src/compiler/x86/arith.lisp ===================================== --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1445,7 +1445,7 @@ (:translate bignum::%ashr) (:policy :fast-safe) (:args (digit :scs (unsigned-reg unsigned-stack) :target result) - (count :scs (unsigned-reg immediate))) + (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) @@ -1454,53 +1454,52 @@ (:result-types unsigned-num) (:generator 2 (move result digit) - (sc-case count - (unsigned-reg - (move ecx count) - (inst sar result :cl)) - (immediate - (let ((amount (tn-value count))) - ;; If the amount is greater than 31, it's the same as - ;; shifting by 31, leaving just the sign bit. - (inst sar result (if (>= amount vm:word-bits) - (1- vm:word-bits) - amount))))))) + (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 2 - (sc-case count - (unsigned-reg - (move result digit) - (move ecx count) - (inst shr result :cl)) - (immediate - (let ((amount (tn-value count))) - ;; If the amount is greater than 31, the result is 0 because - ;; all the bits get shifted right and out. - (cond ((>= amount vm:word-bits) - (inst mov result 0)) - (t - (move result digit) - (inst shr result count)))))))) + (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 2 - (sc-case count - (unsigned-reg - (move result digit) - (move ecx count) - (inst shl result :cl)) - (immediate - (let ((amount (tn-value count))) - ;; If the amount is greater than 31, the result is 0 because - ;; all the bits get shifted left and out. - (cond ((>= amount vm:word-bits) - (inst mov result 0)) - (t - (move result digit) - (inst shl result amount)))))))) + (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. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/7a1457da0f9169bcd0007a7ac…

1 0

[Git][cmucl/cmucl][master] Update from logs.
by Raymond Toy 06 Dec '15

06 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1d64f63b by Raymond Toy at 2015-12-05T17:01:22Z Update from logs. - - - - - 1 changed file: - src/general-info/release-21b.txt Changes: ===================================== src/general-info/release-21b.txt ===================================== --- a/src/general-info/release-21b.txt +++ b/src/general-info/release-21b.txt @@ -42,10 +42,12 @@ 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. * ANSI compliance fixes: * Bugfixes: + * Linux was missing unix-setitimer which prevented saving cores. * Trac Tickets: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1d64f63b45cfe030f76132521…

1 0

[Git][cmucl/cmucl][master] Regenerated.
by Raymond Toy 06 Dec '15

06 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: be500bc5 by Raymond Toy at 2015-12-05T16:10:46Z 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 @@ -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 "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/be500bc5ecbfb12a4053c9e24…

1 0

[Git][cmucl/cmucl][master] Linux needs unix-setitimer
by Raymond Toy 03 Dec '15

03 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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. - - - - - 1 changed file: - src/code/unix.lisp Changes: ===================================== 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 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/5406768cc69dd57ac8c719287…

1 0

[Git][cmucl/cmucl][master] Handle large (fixed) shift amounts for the digit shifters.
by Raymond Toy 02 Dec '15

02 Dec '15

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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. - - - - - 1 changed file: - src/compiler/x86/arith.lisp Changes: ===================================== src/compiler/x86/arith.lisp ===================================== --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1459,29 +1459,48 @@ (move ecx count) (inst sar result :cl)) (immediate - (inst sar result (tn-value count)))))) + (let ((amount (tn-value count))) + ;; If the amount is greater than 31, it's the same as + ;; shifting by 31, leaving just the sign bit. + (inst sar result (if (>= amount vm:word-bits) + (1- vm:word-bits) + amount))))))) (define-vop (digit-lshr digit-ashr) (:translate bignum::%digit-logical-shift-right) (:generator 2 - (move result digit) (sc-case count (unsigned-reg + (move result digit) (move ecx count) (inst shr result :cl)) (immediate - (inst shr result (tn-value count)))))) + (let ((amount (tn-value count))) + ;; If the amount is greater than 31, the result is 0 because + ;; all the bits get shifted right and out. + (cond ((>= amount vm:word-bits) + (inst mov result 0)) + (t + (move result digit) + (inst shr result count)))))))) (define-vop (digit-ashl digit-ashr) (:translate bignum::%ashl) (:generator 2 - (move result digit) (sc-case count (unsigned-reg + (move result digit) (move ecx count) (inst shl result :cl)) (immediate - (inst shl result (tn-value count)))))) + (let ((amount (tn-value count))) + ;; If the amount is greater than 31, the result is 0 because + ;; all the bits get shifted left and out. + (cond ((>= amount vm:word-bits) + (inst mov result 0)) + (t + (move result digit) + (inst shl result amount)))))))) ;;;; Static functions. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1b8b84be82ebb9fb86ddd5159…

1 0