diff --git a/code/float-trap.lisp b/code/float-trap.lisp index 8839d4bc898dd401c990d328914af52bdcfeb3ed..a8b8009d8fa0386834323580ac5c6fd25674bd67 100644 --- a/code/float-trap.lisp +++ b/code/float-trap.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.17 2001/12/06 19:15:40 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.18 2002/01/13 18:25:59 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -48,6 +48,11 @@ (cons :zero float-round-to-zero) (cons :positive-infinity float-round-to-positive) (cons :negative-infinity float-round-to-negative))) + +(defconstant precision-control-alist + (list (cons :24-bit float-precision-24-bit) + (cons :53-bit float-precision-53-bit) + (cons :64-bit float-precision-64-bit))) ); Eval-When (Compile Load Eval) @@ -64,7 +69,8 @@ (rounding-mode nil round-p) (current-exceptions nil current-x-p) (accrued-exceptions nil accrued-x-p) - (fast-mode nil fast-mode-p)) + (fast-mode nil fast-mode-p) + (precision-control nil precision-control-p)) "This function sets options controlling the floating-point hardware. If a keyword is not supplied, then the current value is preserved. Possible keywords: @@ -90,6 +96,11 @@ conformance or debuggability may be impaired. Some machines may not have this feature, in which case the value is always NIL. + :PRECISION-CONTROL + On the x86 architecture, you can set the precision of the arithmetic + to :24-BIT, :53-BIT, or :64-BIT mode, corresponding to IEEE single + precision, double precision, and extended double precision. + GET-FLOATING-POINT-MODES may be used to find the floating point modes currently in effect." (let ((modes (floating-point-modes))) @@ -109,6 +120,15 @@ (if fast-mode (setq modes (logior float-fast-bit modes)) (setq modes (logand (lognot float-fast-bit) modes)))) + #+x86 + (when precision-control-p + (setf (ldb float-precision-control modes) + (or (cdr (assoc precision-control precision-control-alist)) + (error "Unknown precision mode: ~S." precision-control)))) + #-x86 + (when precision-control-p + (warn "Precision control only available for x86")) + (setf (floating-point-modes) modes)) (values)) @@ -138,7 +158,13 @@ rounding-mode-alist)) :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes)) :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes)) - :fast-mode ,(logtest float-fast-bit modes))))) + :fast-mode ,(logtest float-fast-bit modes) + #+x86 + :precision-control + #+x86 + ,(car (rassoc (ldb float-precision-control modes) + precision-control-alist)) + )))) ;;; CURRENT-FLOAT-TRAP -- Interface diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp index 18dc12816a87c532420882457f3337d3fcfda8e9..76f58f694f79d3b009aef9349a9db95af8c4f9df 100644 --- a/compiler/x86/parms.lisp +++ b/compiler/x86/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.16 2000/10/16 17:30:08 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.17 2002/01/13 18:26:00 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -156,6 +156,10 @@ (defconstant float-round-to-positive 2) (defconstant float-round-to-zero 3) +(defconstant float-precision-24-bit 0) +(defconstant float-precision-53-bit 2) +(defconstant float-precision-64-bit 3) + (defconstant float-rounding-mode (byte 2 10)) (defconstant float-sticky-bits (byte 6 16)) (defconstant float-traps-byte (byte 6 0))