cmucl-cvs April 2015

cmucl-cvs@common-lisp.net

3 participants
318 discussions

Start a nNew thread

[git] CMU Common Lisp branch master updated. snapshot-2013-04-26-gde34b9a
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

1 0

[git] CMU Common Lisp branch master updated. 20e-3-g622b5df
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

1 0

[git] CMU Common Lisp annotated tag snapshot-2013-07 created. snapshot-2013-07
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2013-07 has been created at f301f9439d696cdf8a78e81051aa8b1fe102423f (tag) tagging bb56dbb6572939222d731530c3045b4a87ee7f51 (commit) replaces snapshot-2013-06 tagged by Raymond Toy on Thu Jul 4 11:54:53 2013 -0700 - Log ----------------------------------------------------------------- Snapshot 2013-07 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlHVxQQACgkQJ5IjUmgZO7KWkACfQ5iLHsrs+dIPdupOMBKg2f8Y WvcAnjkqAU9PBgbA5Z/QYAZ1Se4G8H4w =Aai3 -----END PGP SIGNATURE----- Raymond Toy (5): Initialize some variables to get rid of some clang warnings. Add a herald for defsystem. Fix some compiler warnings about unused variables or variables that Update to asdf 3.0.2. Update from logs. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-40-gb48c235
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

1 0

[git] CMU Common Lisp branch master updated. begin-x87-removal-5-g1dbe0c4
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 1dbe0c4b5e5e05cc6a9377bc3c6505a9a3e60efc (commit) via 29359293d89d79c7c0099917c93c98258fae12d1 (commit) from 0592141ab9256ca0382a501b418523194ed66e3c (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 1dbe0c4b5e5e05cc6a9377bc3c6505a9a3e60efc Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Apr 6 08:16:07 2014 -0700 Remove commented-out stuff and clean up comments. diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 93f1072..4b4e69b 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -111,12 +111,14 @@ (declare (ignore type)) (let ((num-results (result-state-num-results state))) (setf (result-state-num-results state) (1+ num-results)) + ;; The XMM registers start at 8. (my-make-wired-tn 'double-float 'double-reg (+ num-results 8)))) (def-alien-type-method (single-float :result-tn) (type state) (declare (ignore type)) (let ((num-results (result-state-num-results state))) (setf (result-state-num-results state) (1+ num-results)) + ;; The XMM registers start at 8. (my-make-wired-tn 'single-float 'single-reg (+ num-results 8)))) (def-alien-type-method (values :result-tn) (type state) diff --git a/src/compiler/x86/sse2-c-call.lisp b/src/compiler/x86/sse2-c-call.lisp index 641f0cb..edd226b 100644 --- a/src/compiler/x86/sse2-c-call.lisp +++ b/src/compiler/x86/sse2-c-call.lisp @@ -44,11 +44,12 @@ (:generator 0 (cond ((policy node (> space speed)) (move eax function) - ;; call_into_c has arranged for the result to be in ST(0) - ;; (aka fr0), so there's nothing we need to do now. The - ;; compiler will move fr0 to the appropriate XMM register. (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)) (when (and results (location= (tn-ref-tn results) xmm0-tn)) + ;; If there is a float result from the foreign call, + ;; call_into_c has arranged for the result to be in XMM0, + ;; as a double. If we wanted a single float, do the + ;; conversion here. (sc-case (tn-ref-tn results) (single-reg (inst cvtsd2ss xmm0-tn xmm0-tn)) @@ -57,42 +58,21 @@ ;; the result as a double. )))) (t - ;; Setup the NPX for C; all the FP registers need to be - ;; empty; pop them all. - #+nil - (dotimes (i 8) - (fp-pop)) - (inst call function) ;; To give the debugger a clue. XX not really internal-error? (note-this-location vop :internal-error) - ;; Restore the NPX for lisp; insure no regs are empty. But - ;; we only do 7 registers here. - #+nil - (dotimes (i 7) - (inst fldz)) - - (cond ((and results - (location= (tn-ref-tn results) xmm0-tn)) - ;; If there's a float result, it would have been - ;; returned in fr0, which is now in fr7, thanks to - ;; the fldz's above. Swap fr7 with fr0. The - ;; compiler will arrange to move fr0 to the - ;; appropriate XMM register. - #+nil - (inst fxch fr7-tn) - (sc-case (tn-ref-tn results) - (single-reg - (inst fstp (ea-for-sf-stack temp-single)) - (inst movss xmm0-tn (ea-for-sf-stack temp-single))) - (double-reg - (inst fstpd (ea-for-df-stack temp-double)) - (inst movsd xmm0-tn (ea-for-df-stack temp-double))))) - (t - ;; Fill up the last x87 register - #+nil - (inst fldz))))))) + (when (and results + (location= (tn-ref-tn results) xmm0-tn)) + ;; If there's a float result, it would have been returned + ;; in fr0 according to the ABI. We want it in xmm0. + (sc-case (tn-ref-tn results) + (single-reg + (inst fstp (ea-for-sf-stack temp-single)) + (inst movss xmm0-tn (ea-for-sf-stack temp-single))) + (double-reg + (inst fstpd (ea-for-df-stack temp-double)) + (inst movsd xmm0-tn (ea-for-df-stack temp-double))))))))) (define-vop (alloc-number-stack-space) (:info amount) diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index a0222c5..b01fa5f 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -98,17 +98,6 @@ FUNCDEF(call_into_c) /* Save the return lisp address in ebx */ popl %ebx -#if 0 -/* Setup the NPX for C */ - fstp %st(0) - fstp %st(0) - fstp %st(0) - fstp %st(0) - fstp %st(0) - fstp %st(0) - fstp %st(0) - fstp %st(0) -#endif call *%eax # normal callout using Lisp stack movl %eax,%ecx # remember integer return value @@ -121,17 +110,6 @@ FUNCDEF(call_into_c) jne Lfp_rtn_value /* The return value is in eax, or eax,edx? */ -#if 0 -/* Setup the NPX stack for lisp */ - fldz # insure no regs are empty - fldz - fldz - fldz - fldz - fldz - fldz - fldz -#endif no_fldz: /* Restore the return value */ movl %ecx,%eax # maybe return value @@ -141,18 +119,13 @@ no_fldz: jmp *%ebx Lfp_rtn_value: -#if 0 -/* The return result is in st(0) */ -/* Setup the NPX stack for lisp, placing the result in st(0) */ - fldz # insure no regs are empty - fldz - fldz - fldz - fldz - fldz - fldz - fxch %st(7) # move the result back to st(0) -#endif + +/* + * The float result is in st(0). We want it in xmm0. For + * consistency, save st(0) out as a double and load it into xmm0 as a + * double. The call-out vop will arrange to convert it to a single-float + * if necessary. + */ subl $8, %esp # Space for a double float fstpl 0(%esp) movsd 0(%esp), %xmm0 @@ -208,17 +181,6 @@ x87_save: fldcw (%esp) # Recover modes popl %eax npx_save_done: -#if 0 - /* Is this still necessary with sse2? */ - fldz # insure no FP regs are empty - fldz - fldz - fldz - fldz - fldz - fldz - fldz -#endif /* Save C regs: ebx esi edi */ pushl %ebx pushl %esi commit 29359293d89d79c7c0099917c93c98258fae12d1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Apr 5 14:46:17 2014 -0700 Simplify call-out for sse2. For sse2, we don't need to do the fldz/fstp dance when doing a foreign function call. A cross-compile is needed! * src/bootfiles/20e/boot-2014-04-cross-x86.lisp: * Cross-compile script to enable these changes. * src/compiler/x86/c-call.lisp: * Make the float result tn be xmm registers, not x87 fpu registers. * src/compiler/x86/sse2-c-call.lisp: * Simplify call-out not to use fldz/fstp except for the minimum required for the 32-bit ABI. * src/lisp/x86-assem.S * Comment out the fstp/fldz insts that aren't needed for SSE2. diff --git a/src/bootfiles/20e/boot-2014-04-cross-x86.lisp b/src/bootfiles/20e/boot-2014-04-cross-x86.lisp new file mode 100644 index 0000000..7bfecf8 --- /dev/null +++ b/src/bootfiles/20e/boot-2014-04-cross-x86.lisp @@ -0,0 +1,8 @@ +;; Cross-compile script needed for updating the SSE2 call-out VOP and +;; x86 call_into_c. In both places, we remove the need to do the fldz +;; and fstp dance to set up the FPU for C and Lisp. SSE2 doesn't use +;; the FPU. + +#+x86 +(load "target:tools/cross-scripts/cross-x86-x86.lisp") + diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 4554a0e..93f1072 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -111,13 +111,13 @@ (declare (ignore type)) (let ((num-results (result-state-num-results state))) (setf (result-state-num-results state) (1+ num-results)) - (my-make-wired-tn 'double-float 'double-reg (* num-results 2)))) + (my-make-wired-tn 'double-float 'double-reg (+ num-results 8)))) (def-alien-type-method (single-float :result-tn) (type state) (declare (ignore type)) (let ((num-results (result-state-num-results state))) (setf (result-state-num-results state) (1+ num-results)) - (my-make-wired-tn 'single-float 'single-reg (* num-results 2)))) + (my-make-wired-tn 'single-float 'single-reg (+ num-results 8)))) (def-alien-type-method (values :result-tn) (type state) (let ((values (alien-values-type-values type))) diff --git a/src/compiler/x86/sse2-c-call.lisp b/src/compiler/x86/sse2-c-call.lisp index a5bd80f..641f0cb 100644 --- a/src/compiler/x86/sse2-c-call.lisp +++ b/src/compiler/x86/sse2-c-call.lisp @@ -34,6 +34,8 @@ :from :eval :to :result) ecx) (:temporary (:sc unsigned-reg :offset edx-offset :from :eval :to :result) edx) + (:temporary (:sc single-stack) temp-single) + (:temporary (:sc double-stack) temp-double) (:node-var node) (:vop-var vop) (:save-p t) @@ -45,10 +47,19 @@ ;; call_into_c has arranged for the result to be in ST(0) ;; (aka fr0), so there's nothing we need to do now. The ;; compiler will move fr0 to the appropriate XMM register. - (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))) + (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)) + (when (and results (location= (tn-ref-tn results) xmm0-tn)) + (sc-case (tn-ref-tn results) + (single-reg + (inst cvtsd2ss xmm0-tn xmm0-tn)) + (double-reg + ;; Nothing needed for double because call_into_c saved + ;; the result as a double. + )))) (t ;; Setup the NPX for C; all the FP registers need to be ;; empty; pop them all. + #+nil (dotimes (i 8) (fp-pop)) @@ -58,19 +69,29 @@ ;; Restore the NPX for lisp; insure no regs are empty. But ;; we only do 7 registers here. + #+nil (dotimes (i 7) (inst fldz)) (cond ((and results - (location= (tn-ref-tn results) fr0-tn)) + (location= (tn-ref-tn results) xmm0-tn)) ;; If there's a float result, it would have been ;; returned in fr0, which is now in fr7, thanks to ;; the fldz's above. Swap fr7 with fr0. The ;; compiler will arrange to move fr0 to the ;; appropriate XMM register. - (inst fxch fr7-tn)) + #+nil + (inst fxch fr7-tn) + (sc-case (tn-ref-tn results) + (single-reg + (inst fstp (ea-for-sf-stack temp-single)) + (inst movss xmm0-tn (ea-for-sf-stack temp-single))) + (double-reg + (inst fstpd (ea-for-df-stack temp-double)) + (inst movsd xmm0-tn (ea-for-df-stack temp-double))))) (t ;; Fill up the last x87 register + #+nil (inst fldz))))))) (define-vop (alloc-number-stack-space) diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index 57b69c0..a0222c5 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -98,6 +98,7 @@ FUNCDEF(call_into_c) /* Save the return lisp address in ebx */ popl %ebx +#if 0 /* Setup the NPX for C */ fstp %st(0) fstp %st(0) @@ -107,6 +108,7 @@ FUNCDEF(call_into_c) fstp %st(0) fstp %st(0) fstp %st(0) +#endif call *%eax # normal callout using Lisp stack movl %eax,%ecx # remember integer return value @@ -119,6 +121,7 @@ FUNCDEF(call_into_c) jne Lfp_rtn_value /* The return value is in eax, or eax,edx? */ +#if 0 /* Setup the NPX stack for lisp */ fldz # insure no regs are empty fldz @@ -128,6 +131,7 @@ FUNCDEF(call_into_c) fldz fldz fldz +#endif no_fldz: /* Restore the return value */ movl %ecx,%eax # maybe return value @@ -137,6 +141,7 @@ no_fldz: jmp *%ebx Lfp_rtn_value: +#if 0 /* The return result is in st(0) */ /* Setup the NPX stack for lisp, placing the result in st(0) */ fldz # insure no regs are empty @@ -147,6 +152,11 @@ Lfp_rtn_value: fldz fldz fxch %st(7) # move the result back to st(0) +#endif + subl $8, %esp # Space for a double float + fstpl 0(%esp) + movsd 0(%esp), %xmm0 + addl $8, %esp /* Don't need to restore eax as the result is in st(0) */ @@ -198,6 +208,7 @@ x87_save: fldcw (%esp) # Recover modes popl %eax npx_save_done: +#if 0 /* Is this still necessary with sse2? */ fldz # insure no FP regs are empty fldz @@ -207,7 +218,7 @@ npx_save_done: fldz fldz fldz - +#endif /* Save C regs: ebx esi edi */ pushl %ebx pushl %esi ----------------------------------------------------------------------- Summary of changes: src/bootfiles/20e/boot-2014-04-cross-x86.lisp | 8 ++++ src/compiler/x86/c-call.lisp | 6 ++- src/compiler/x86/sse2-c-call.lisp | 51 +++++++++++++------------ src/lisp/x86-assem.S | 49 ++++++------------------ 4 files changed, 49 insertions(+), 65 deletions(-) create mode 100644 src/bootfiles/20e/boot-2014-04-cross-x86.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2014-08 created. snapshot-2014-08
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2014-08 has been created at 3d3259cd2f0d437388b69ecf50feedc73246096d (tag) tagging 98319835e05b93ea62e17f6bc3da4144f96ac2c5 (commit) replaces snapshot-2014-06 tagged by Raymond Toy on Thu Aug 7 21:30:43 2014 -0700 - Log ----------------------------------------------------------------- Snapshot 2014-08 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlPkUnoACgkQJ5IjUmgZO7JzgwCgt4mPwW0Qx0sI3qtsXPOttVrq klAAnAxpd/KCElQ6ggJf82ZSVlhRBOJm =4mEx -----END PGP SIGNATURE----- Raymond Toy (101): Change max gen to GC to 3; add inteface to set it. Fix declaration of min-av-mem-age in generation-stats. Import fdlibm trig functions; as is, from netlib. Update to use unions, using the style of e_rem_pio2.c. Add declarations for the fdlibm trig functions. Compile fdlibm trig functions on linux and darwin. Darwin doesn't need fdlibm because the system library is good. Add implmeentation of sincos in C. Comment out all of the trig functions in lisp in favor of calling out Oops. Didn't comment out quite enough. Add sincos for x86 linux. For consistency with sincos, we need to include the fdlibm trig ppc doesn't have sincos in libm so use our own version. Oops. Need k_sin and k_cos for sincos. Add rest of fdblim trig functios so that sincos is consistent with sin Put back the deftransforms for sin/cos/tan so we can call out directly Add fdlibm trig for sparc. Add fdlibm trig routines for NetBSD. Fix stupid typo that causes sin to converted to asin. All platforms have sincos now, so remove the deftransform for cis that Add declaration to ignore unused variable. Rename sin/cos/tan/sincos so we don't collide with libm. Add include guard. Some cleanup of the trig code. Comment code, add license header, and conform to cmucl C style. Ignore emacs ~ files and fasls. Finally remove the Lisp implementation of the trig functions that are Add expm1 to match log1p. All platforms seem to have expm1 as well. Remove the mathcalls section. It's not used and some of it (log1p) is Update to 3.1.3. Fix ticket ##104: Source location for define-condition Add README to document the naming convention of boot files. Add info for cross-compile scripts. CLEAR-OUTPUT should call STREAM-CLEAR-OUTPUT for Gray streams. Implement CLEAR-OUTPUT for FD-STREAM's. Add tests for CLEAR-OUTPUT. Import log1p from fdlibm, as is. Import expm1 from fdlibm, as is. Modify to use unions and change name to include fdlibm prefix. Compile s_log1p and s_expm1. Use fdlibm versions of log1p and expm1. Import pow (ieee754_pow) from fdlibm, as is. Update to use unions. Compile e_pow as a part of lisp. Use __ieee754_pow instead of pow. Compile the new fdlibm routines. Compile the new fdlibm routines. Compile the new fdlibm routines. Add fdlibm routines e_exp and e_log, as is. Update to use unions. Compile fdlibm routines e_exp.c and e_log.c Use the fdlibm routines for exp and log. Import inverse trig functions from fdlibm, as is. Use unions to access the high and low parts of a double. Compile the asin, acos, and atan routines. Use the fdlibm asin, acos, and atan routines. Initialize t to get rid of a compiler warning from clang. Initialize k to get rid of a compiler warning from clang. Remove the sccsid variable. Add some braces to silence the warning from clang about dangling else Add some braces to silence the warning from clang about dangling else Import hyperbolic functions from fdlibm, as is. Use unions to access the high and low parts of a double and update Add parens around && expressions to silence a clang warning. Compile the fdlibm hyperbolic functions. Use fdlibm hyperbolic functions instead of libm. Import inverse hyperbolic functions from fdlibm, as is. Fix up the inverse hyperbolics. Compile the fdlibm inverse hyperbolics. Use the fdlibm inverse hyperbolic functions. Import atan2 function from fdlibm, as is. Fix up atan2 by using unions. Use fdlibm_atan instead of atan. Compile the fdlibm atan2. Use fdlibm atan2. Use correct flags to generate sse2 instructions in the C code and Clean up config files. Remove the list of fdlibm files from here because they're in Forgot to remove e_rem_pio2 and friends. -march=pentium4 imples -msse2, so drop the latter. Update netbsd config. Untested. Forgot to remove e_rem_pio2 and friends from a few more Config files Remove CC_REM_PIO2 and add new CPPFLAGS to force compiling with sse2 add -mtune=generic to get optimization for the most common x86 Update from commit logs. Initialize c to get rid of a compiler warning on Linux with gcc 4.4.1. Add parens around operands of | to silence a compiler warning with gcc Initilize hi and lo to get rid of a compiler warning from gcc 4.4.1 on Fix aliasing issue noted by gcc 4.4.1 on Linux. Fix aliasing issue noted by gcc 4.4.1 on Linux. Oops. Fix typo by removing the extraneous comma that was left in. Fix bug in DOUBLE-FLOAT-BITS vop. Remove -mtune=generic from Config.x86_common. Update LDFLAGS for NetBSD so motifd will build and run correctly on Oops. x86-assem needs -m32. Document that the argument/result timespec starts at 0, not 1. Simplify SSE2-FLOATING-POINT-MODES vop by removing an unneeded Addresses ticket #84 for Linux. Fix typo and add -m32 to LDFLAGS. Remove commented-out LDFLAGS. Regenerated and updated. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-43-gca2bf8c
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via ca2bf8c29d22aaf44caf31f1d7b6ba77ab418be5 (commit) from 894af6c4aaa3b83f3c13d2e59735c33f79abdc20 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit ca2bf8c29d22aaf44caf31f1d7b6ba77ab418be5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Dec 24 12:57:45 2013 -0800 Fix ticket:90 src/code/irrat.lisp: src/code/irrat-dd.lisp: * Remove the special case that made atanh continuous with quadrant III for x < -1 on the branch cut. tests/trig.lisp: * Update tests for atanh * Rename rel-or-abs-error to close-to. diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp index 024ec93..dbe9159 100644 --- a/src/code/irrat-dd.lisp +++ b/src/code/irrat-dd.lisp @@ -1663,63 +1663,59 @@ Z may be any number, but the result is always a complex." (defun dd-complex-atanh (z) _N"Compute atanh z = (log(1+z) - log(1-z))/2" (declare (number z)) - (cond ((and (realp z) (< z -1)) - ;; ATANH is continuous with quadrant III in this case. - (dd-complex-atanh (complex z -0d0))) - (t - (let* ( ;; Constants - (theta (/ (sqrt most-positive-double-float) 4.0w0)) - (rho (/ 4.0w0 (sqrt most-positive-double-float))) - (half-pi dd-pi/2) - (rp (float (realpart z) 1.0w0)) - (beta (float-sign rp 1.0w0)) - (x (* beta rp)) - (y (* beta (- (float (imagpart z) 1.0w0)))) - (eta 0.0w0) - (nu 0.0w0)) - ;; Shouldn't need this declare. - (declare (double-double-float x y)) - (locally - (declare (optimize (speed 3) - (inhibit-warnings 3))) - (cond ((or (> x theta) - (> (abs y) theta)) - ;; To avoid overflow... - (setf nu (float-sign y half-pi)) - ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), - ;; which can cause overflow. Arrange this computation so - ;; that it won't overflow. - (setf eta (let* ((x-bigger (> x (abs y))) - (r (if x-bigger (/ y x) (/ x y))) - (d (+ 1.0d0 (* r r)))) - (if x-bigger - (/ (/ x) d) - (/ (/ r y) d))))) - ((= x 1.0w0) - ;; Should this be changed so that if y is zero, eta is set - ;; to +infinity instead of approx 176? In any case - ;; tanh(176) is 1.0d0 within working precision. - (let ((t1 (+ 4w0 (square y))) - (t2 (+ (abs y) rho))) - (setf eta (dd-%log (/ (sqrt (sqrt t1)) - (sqrt t2)))) - (setf nu (* 0.5d0 - (float-sign y - (+ half-pi (dd-%atan (* 0.5d0 t2)))))))) - (t - (let ((t1 (+ (abs y) rho))) - ;; Normal case using log1p(x) = log(1 + x) - (setf eta (* 0.25d0 - (dd-%log1p (/ (* 4.0d0 x) - (+ (square (- 1.0d0 x)) - (square t1)))))) - (setf nu (* 0.5d0 - (dd-%atan2 (* 2.0d0 y) - (- (* (- 1.0d0 x) - (+ 1.0d0 x)) - (square t1)))))))) - (complex (* beta eta) - (- (* beta nu)))))))) + (let* ( ;; Constants + (theta (/ (sqrt most-positive-double-float) 4.0w0)) + (rho (/ 4.0w0 (sqrt most-positive-double-float))) + (half-pi dd-pi/2) + (rp (float (realpart z) 1.0w0)) + (beta (float-sign rp 1.0w0)) + (x (* beta rp)) + (y (* beta (- (float (imagpart z) 1.0w0)))) + (eta 0.0w0) + (nu 0.0w0)) + ;; Shouldn't need this declare. + (declare (double-double-float x y)) + (locally + (declare (optimize (speed 3) + (inhibit-warnings 3))) + (cond ((or (> x theta) + (> (abs y) theta)) + ;; To avoid overflow... + (setf nu (float-sign y half-pi)) + ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf eta (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x 1.0w0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4w0 (square y))) + (t2 (+ (abs y) rho))) + (setf eta (dd-%log (/ (sqrt (sqrt t1)) + (sqrt t2)))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (dd-%atan (* 0.5d0 t2)))))))) + (t + (let ((t1 (+ (abs y) rho))) + ;; Normal case using log1p(x) = log(1 + x) + (setf eta (* 0.25d0 + (dd-%log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (dd-%atan2 (* 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) + (complex (* beta eta) + (- (* beta nu)))))) (defun dd-complex-tanh (z) _N"Compute tanh z = sinh z / cosh z" diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index ff23a5e..e4e744d 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -1741,62 +1741,59 @@ Z may be any number, but the result is always a complex." (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-atanh (dd-complex-atanh z))) - (if (and (realp z) (< z -1)) - ;; atanh is continuous in quadrant III in this case. - (complex-atanh (complex z -0f0)) - (let* ( ;; Constants - (theta (/ (sqrt most-positive-double-float) 4.0d0)) - (rho (/ 4.0d0 (sqrt most-positive-double-float))) - (half-pi (/ pi 2.0d0)) - (rp (float (realpart z) 1.0d0)) - (beta (float-sign rp 1.0d0)) - (x (* beta rp)) - (y (* beta (- (float (imagpart z) 1.0d0)))) - (eta 0.0d0) - (nu 0.0d0)) - ;; Shouldn't need this declare. - (declare (double-float x y)) - (locally - (declare (optimize (speed 3))) - (cond ((or (> x theta) - (> (abs y) theta)) - ;; To avoid overflow... - (setf nu (float-sign y half-pi)) - ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), - ;; which can cause overflow. Arrange this computation so - ;; that it won't overflow. - (setf eta (let* ((x-bigger (> x (abs y))) - (r (if x-bigger (/ y x) (/ x y))) - (d (+ 1.0d0 (* r r)))) - (if x-bigger - (/ (/ x) d) - (/ (/ r y) d))))) - ((= x 1.0d0) - ;; Should this be changed so that if y is zero, eta is set - ;; to +infinity instead of approx 176? In any case - ;; tanh(176) is 1.0d0 within working precision. - (let ((t1 (+ 4d0 (square y))) - (t2 (+ (abs y) rho))) - (setf eta (log (/ (sqrt (sqrt t1)) - (sqrt t2)))) - (setf nu (* 0.5d0 - (float-sign y - (+ half-pi (atan (* 0.5d0 t2)))))))) - (t - (let ((t1 (+ (abs y) rho))) - ;; Normal case using log1p(x) = log(1 + x) - (setf eta (* 0.25d0 - (%log1p (/ (* 4.0d0 x) - (+ (square (- 1.0d0 x)) - (square t1)))))) - (setf nu (* 0.5d0 - (atan (* 2.0d0 y) - (- (* (- 1.0d0 x) - (+ 1.0d0 x)) - (square t1)))))))) - (coerce-to-complex-type (* beta eta) - (- (* beta nu)) - z))))) + (let* ( ;; Constants + (theta (/ (sqrt most-positive-double-float) 4.0d0)) + (rho (/ 4.0d0 (sqrt most-positive-double-float))) + (half-pi (/ pi 2.0d0)) + (rp (float (realpart z) 1.0d0)) + (beta (float-sign rp 1.0d0)) + (x (* beta rp)) + (y (* beta (- (float (imagpart z) 1.0d0)))) + (eta 0.0d0) + (nu 0.0d0)) + ;; Shouldn't need this declare. + (declare (double-float x y)) + (locally + (declare (optimize (speed 3))) + (cond ((or (> x theta) + (> (abs y) theta)) + ;; To avoid overflow... + (setf nu (float-sign y half-pi)) + ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf eta (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x 1.0d0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4d0 (square y))) + (t2 (+ (abs y) rho))) + (setf eta (log (/ (sqrt (sqrt t1)) + (sqrt t2)))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (atan (* 0.5d0 t2)))))))) + (t + (let ((t1 (+ (abs y) rho))) + ;; Normal case using log1p(x) = log(1 + x) + (setf eta (* 0.25d0 + (%log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (atan (* 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) + (coerce-to-complex-type (* beta eta) + (- (* beta nu)) + z)))) (defun complex-tanh (z) "Compute tanh z = sinh z / cosh z" diff --git a/tests/trig.lisp b/tests/trig.lisp index 05437e5..df76231 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -215,18 +215,20 @@ (assert-eql nil (sincos-test (scale-float 1d0 1023) 1000))) -;; Compute the relative error between actual and expected if expected -;; is not zero. Otherwise, return absolute error between actual and -;; expected. If the error is less than the threshold, return T. -;; Otherwise return the actual (relative or absolute) error. -(defun rel-or-abs-error (actual expected &optional (threshold double-float-epsilon)) +(defun close-to (actual expected &optional (threshold double-float-epsilon)) + "Determine if Actual is close to Expected. If Expected is not zero, + then close-to returns t if |Actual - Expected|/|Expected| <= + Threshold. If Expected is 0, then close-to returns T if |Actual - + Expected| <= threshold. In either of these conditions does not + hold, then a list of the actual error (relative or absolute), the + actual value and the expected value is returned." (let ((err (if (zerop expected) (abs (- actual expected)) (/ (abs (- actual expected)) (abs expected))))) (if (<= err threshold) t - err))) + (list err actual expected)))) ;;; Tests for double-double-floats @@ -239,11 +241,11 @@ (define-test dd-sin.no-reduction "Test sin for small args without reduction" (:tag :sin :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin .5w0) 4.794255386042030002732879352155713880818033679406006751886166131w-1 1w-32)) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin -0.5w0) -4.794255386042030002732879352155713880818033679406006751886166131w-1 1w-32))) @@ -251,7 +253,7 @@ (define-test dd-sin.pi/2 "Test for arg near pi/2" (:tag :sin :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (/ kernel:dd-pi 2)) 1w0 1w-50))) @@ -265,27 +267,27 @@ "Test for sin with arg reduction" (:tag :sin :double-double) ;; Test for argument reduction with n mod 4 = 0 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 7/4 kernel:dd-pi)) -7.07106781186547524400844362104849691328261037289050238659653433w-1 0w0)) ;; Test for argument reduction with n mod 4 = 1 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 9/4 kernel:dd-pi)) 7.07106781186547524400844362104858161816423215627023442400880643w-1 0w0)) ;; Test for argument reduction with n mod 4 = 2 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 11/4 kernel:dd-pi)) 7.071067811865475244008443621048998682901731241858306822215522497w-1 8.716w-33)) ;; Test for argument reduction with n mod 4 = 3 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 13/4 kernel:dd-pi)) -7.071067811865475244008443621048777109664479707052746581685893187w-1 8.716w-33)) ;; Test for argument reduction, big value - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (scale-float 1w0 120)) 3.778201093607520226555484700569229919605866976512306642257987199w-1 8.156w-33))) @@ -299,11 +301,11 @@ (define-test dd-cos.no-reduction "Test cos for small args without reduction" (:tag :cos :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos .5w0) 8.775825618903727161162815826038296519916451971097440529976108683w-1 0w0)) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos -0.5w0) 8.775825618903727161162815826038296519916451971097440529976108683w-1 0w0))) @@ -311,7 +313,7 @@ (define-test dd-cos.pi/2 "Test for arg near pi/2" (:tag :cos :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (/ kernel:dd-pi 2)) -1.497384904859169777320797133937725094986669701841027904483071358w-33 0w0))) @@ -320,27 +322,27 @@ "Test for cos with arg reduction" (:tag :cos :double-double) ;; Test for argument reduction with n mod 4 = 0 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 7/4 kernel:dd-pi)) 7.07106781186547524400844362104849691328261037289050238659653433w-1 0w0)) ;; Test for argument reduction with n mod 4 = 1 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 9/4 kernel:dd-pi)) 7.07106781186547524400844362104858161816423215627023442400880643w-1 3.487w-32)) ;; Test for argument reduction with n mod 4 = 2 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 11/4 kernel:dd-pi)) -7.071067811865475244008443621048998682901731241858306822215522497w-1 1.482w-31)) ;; Test for argument reduction with n mod 4 = 3 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 13/4 kernel:dd-pi)) -7.071067811865475244008443621048777109664479707052746581685893187w-1 7.845w-32)) ;; Test for argument reduction, big value - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (scale-float 1w0 120)) -9.258790228548378673038617641074149467308332099286564602360493726w-1 0w0))) @@ -354,11 +356,11 @@ (define-test dd-tan.no-reduction "Test tan for small args without reduction" (:tag :tan :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan .5w0) 5.463024898437905132551794657802853832975517201797912461640913859w-1 0w0)) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan -0.5w0) -5.463024898437905132551794657802853832975517201797912461640913859w-1 0w0))) @@ -366,7 +368,7 @@ (define-test dd-tan.pi/2 "Test for arg near pi/2" (:tag :tan :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (/ kernel:dd-pi 2)) -6.67830961000672557834948096545679895621313886078988606234681001w32 0w0))) @@ -375,17 +377,17 @@ "Test for tan with arg reduction" (:tag :tan :double-double) ;; Test for argument reduction with n even - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (* 7/4 kernel:dd-pi)) -1.000000000000000000000000000000001844257310064121018312678894979w0 3.422w-49)) ;; Test for argument reduction with n odd - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (* 9/4 kernel:dd-pi)) 1.000000000000000000000000000000025802415787810837455445433037983w0 0w0)) ;; Test for argument reduction, big value - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (scale-float 1w0 120)) -4.080663888418042385451434945255951177650840227682488471558860153w-1 1.888w-33))) @@ -753,7 +755,8 @@ ;; Thus, atanh(-2) is continuous with Quadrant II, NOT continuous with ;; Quadrant III! ;; -;; What do we do? +;; The formula, however, is clear. We will use the formula and ignore +;; the text in the CLHS. (defun atanh-def (z) (r*z 1/2 (- (log (1+z z)) @@ -761,19 +764,19 @@ (define-test branch-cut.atanh (:tag :atanh :branch-cuts) - ;; Test for x < -1, which is continuous with Quadrant III. Use the - ;; the value at #c(-2d0 -1d-20) as the reference. + ;; Test for x < -1, which is continuous with Quadrant II. Use the + ;; the value at #c(-2d0 +1d-20) as the reference. (multiple-value-bind (tr ti) - (get-signs (atanh-def #c(-2d0 -1d-20))) + (get-signs (atanh-def #c(-2d0 1d-20))) (assert-true (check-signs #'atanh -2d0 tr ti)) (assert-true (check-signs #'atanh -2w0 tr ti)) - (assert-true (check-signs #'atanh #c(-2d0 -0d0) tr ti)) - (assert-true (check-signs #'atanh #c(-2w0 -0w0) tr ti))) + (assert-true (check-signs #'atanh #c(-2d0 +0d0) tr ti)) + (assert-true (check-signs #'atanh #c(-2w0 +0w0) tr ti))) ;; Test the other side of the branch cut for x < -1. (multiple-value-bind (tr ti) - (get-signs (atanh-def #c(-2d0 +1d-20))) - (assert-true (check-signs #'atanh #c(-2d0 0d0) tr ti)) - (assert-true (check-signs #'atanh #c(-2w0 0w0) tr ti))) + (get-signs (atanh-def #c(-2d0 -1d-20))) + (assert-true (check-signs #'atanh #c(-2d0 -0d0) tr ti)) + (assert-true (check-signs #'atanh #c(-2w0 -0w0) tr ti))) ;; Test for x > 1, which is continuous with Quadrant I, using the ;; value at #c(+2d0 1d-10) as the reference ----------------------------------------------------------------------- Summary of changes: src/code/irrat-dd.lisp | 110 +++++++++++++++++++++++------------------------- src/code/irrat.lisp | 109 +++++++++++++++++++++++------------------------ tests/trig.lisp | 77 +++++++++++++++++---------------- 3 files changed, 146 insertions(+), 150 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-10-gab44683
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

1 0

[git] CMU Common Lisp branch master updated. begin-x87-removal-19-g87aed56
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 87aed560fb118c488a3ea2824ed3fbddf9930cd2 (commit) via 28455f5114df02062ea6deddb8fb47a9de8c063f (commit) from 7fe70d3a8856058f4bb4b10602d7eadf18444791 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 87aed560fb118c488a3ea2824ed3fbddf9930cd2 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Apr 27 18:18:15 2014 -0700 Remove more sse2 stuff. * Exit if the chip doesn't support sse2. * Treat any mode setting as being the same as sse2 and return the sse2 core name. diff --git a/src/lisp/x86-arch.c b/src/lisp/x86-arch.c index c694cea..841e2cc 100644 --- a/src/lisp/x86-arch.c +++ b/src/lisp/x86-arch.c @@ -108,17 +108,16 @@ arch_init(fpu_mode_t mode) have_sse2 = arch_support_sse2() && os_support_sse2(); + if (!have_sse2) { + fprintf(stderr, "CMUCL requires a SSE2 support; exiting\n"); + abort(); + } + switch (mode) { case AUTO: - if (have_sse2) { - return "lisp-sse2.core"; - } else { - return "lisp-x87.core"; - } - break; case X87: - return "lisp-x87.core"; - break; + fprintf(stderr, "fpu mode AUTO or X87 is not longer supported.\n"); + /* Fall through and return the sse2 core */ case SSE2: return "lisp-sse2.core"; break; commit 28455f5114df02062ea6deddb8fb47a9de8c063f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Apr 27 18:16:45 2014 -0700 Rmove more x87 fpu mode stuff. * Darwin-os.c: * Linux-os.c: * FEATURE_SSE2 is always true so remove the #ifdef's * Don't merge the x87 fpu mode bits with the sse2 ones; we only want sse2. * restore_fpu doesn't need to restore the x87 fpu mode bits. diff --git a/src/lisp/Darwin-os.c b/src/lisp/Darwin-os.c index 693cbf6..5e8ddf9 100644 --- a/src/lisp/Darwin-os.c +++ b/src/lisp/Darwin-os.c @@ -22,6 +22,8 @@ #include <errno.h> #include <dlfcn.h> #include <string.h> +#include <assert.h> + #include "os.h" #include "arch.h" #include "globals.h" @@ -332,7 +334,6 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int index) return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm6; case 7: return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm7; -#ifdef FEATURE_SSE2 case 8: return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_xmm0; case 9: @@ -348,43 +349,21 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int index) case 14: return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_xmm6; case 15: - return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm7; -#endif + return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm7; + default: + return NULL; } - return NULL; } unsigned int os_sigcontext_fpu_modes(ucontext_t *scp) { unsigned int modes; - unsigned int mxcsr; - unsigned short cw, sw; - - /* - * Get the status word and the control word. - */ - memcpy(&cw, &scp->uc_mcontext->__fs.__fpu_fcw, sizeof(cw)); - memcpy(&sw, &scp->uc_mcontext->__fs.__fpu_fsw, sizeof(sw)); - /* - * Put the cw in the upper bits and the status word in the lower 6 - * bits, ignoring everything except the exception masks and the - * exception flags. - */ - modes = ((cw & 0x3f) << 7) | (sw & 0x3f); + assert(fpu_mode == SSE2); - DPRINTF(0, (stderr, "FPU modes = %08x (sw = %4x, cw = %4x)\n", - modes, (unsigned int) sw, (unsigned int) cw)); - - if (fpu_mode == SSE2) { - mxcsr = scp->uc_mcontext->__fs.__fpu_mxcsr; - DPRINTF(0, (stderr, "SSE2 modes = %08x\n", mxcsr)); - - modes |= mxcsr; - } - - DPRINTF(0, (stderr, "modes pre mask = %08x\n", modes)); + modes = scp->uc_mcontext->__fs.__fpu_mxcsr; + DPRINTF(0, (stderr, "SSE2 modes = %08x\n", modes)); /* Convert exception mask to exception enable */ modes ^= (0x3f << 7); @@ -395,16 +374,11 @@ os_sigcontext_fpu_modes(ucontext_t *scp) void restore_fpu(ucontext_t *scp) { - unsigned short cw; unsigned int mxcsr; - memcpy(&cw, &scp->uc_mcontext->__fs.__fpu_fcw, sizeof(cw)); - DPRINTF(0, (stderr, "restore_fpu: FPU cw = 0x%x\n", cw)); - __asm__ __volatile__ ("fclex"); - __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)); - mxcsr = scp->uc_mcontext->__fs.__fpu_mxcsr; DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); + __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); } #endif diff --git a/src/lisp/Linux-os.c b/src/lisp/Linux-os.c index 7f7a4d7..2da60fb 100644 --- a/src/lisp/Linux-os.c +++ b/src/lisp/Linux-os.c @@ -217,16 +217,13 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) if (fpregs) { if (offset < 8) { reg = (unsigned char *) &fpregs->_st[offset]; - } -#ifdef FEATURE_SSE2 - else { + } else if (offset < 16) { struct _fpstate *fpstate; fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; if (fpstate->magic != 0xffff) { reg = (unsigned char *) &fpstate->_xmm[offset - 8]; } } -#endif } return reg; } @@ -234,39 +231,27 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) unsigned int os_sigcontext_fpu_modes(ucontext_t *scp) { - unsigned int modes; - unsigned short cw, sw; - - if (scp->uc_mcontext.fpregs == NULL) { - cw = 0; - sw = 0x3f; - } else { - cw = scp->uc_mcontext.fpregs->cw & 0xffff; - sw = scp->uc_mcontext.fpregs->sw & 0xffff; - } + unsigned int modes = 0; - modes = ((cw & 0x3f) << 7) | (sw & 0x3f); - -#ifdef FEATURE_SSE2 /* - * Add in the SSE2 part, if we're running the sse2 core. + * Get the SSE2 modes. FIXME: What should we do if the magic + * value indicates that the mxcsr value is not in the context? */ - if (fpu_mode == SSE2) { - struct _fpstate *fpstate; - unsigned long mxcsr; - - fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; - if (fpstate->magic == 0xffff) { - mxcsr = 0; - } else { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); - } + struct _fpstate *fpstate; + unsigned long mxcsr; - modes |= mxcsr; + fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; + if (fpstate->magic == 0xffff) { + mxcsr = 0; + } else { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); } -#endif + modes |= mxcsr; + + + /* Convert exception mask to exception enable */ modes ^= (0x3f << 7); return modes; } @@ -543,25 +528,19 @@ void restore_fpu(ucontext_t *context) { if (context->uc_mcontext.fpregs) { - short cw = context->uc_mcontext.fpregs->cw; - DPRINTF(0, (stderr, "restore_fpu: cw = %08x\n", cw)); - __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)); -#ifdef FEATURE_SSE2 - if (fpu_mode == SSE2) { - struct _fpstate *fpstate; - unsigned int mxcsr; + struct _fpstate *fpstate; + unsigned int mxcsr; - fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; - if (fpstate->magic != 0xffff) { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); - __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); - } + fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; + if (fpstate->magic != 0xffff) { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); + __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); } -#endif } } + #ifdef i386 boolean os_support_sse2() ----------------------------------------------------------------------- Summary of changes: src/lisp/Darwin-os.c | 44 +++++++------------------------- src/lisp/Linux-os.c | 69 ++++++++++++++++++-------------------------------- src/lisp/x86-arch.c | 15 +++++------ 3 files changed, 40 insertions(+), 88 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-11-4-gf3c9558
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs April 2015