diff --git a/bootfiles/19a/boot7.lisp b/bootfiles/19a/boot7.lisp new file mode 100644 index 0000000000000000000000000000000000000000..4d4a90923f3ebf59758b84d3619b5be8c98f2708 --- /dev/null +++ b/bootfiles/19a/boot7.lisp @@ -0,0 +1,21 @@ +;; Implement float-accuracy compilation policy (intended for x86). +;; This means that on x86 cmucl will run with double-float precision +;; (53-bit) for all floating-point operations, unless float-accuracy +;; is not 3, in which case extended-float (64-bit) precision will be +;; used. +;; +;; By changing the default to 53-bit, double-float-epsilon really is +;; double-float epsilon. + +(in-package :extensions) +(export '(float-accuracy)) + +(in-package :c) + +(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) + (defconstant policy-parameter-slots + '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety) + (cspeed . cookie-cspeed) (brevity . cookie-brevity) + (debug . cookie-debug) (float-accuracy . cookie-float-accuracy)))) diff --git a/code/unix-glibc2.lisp b/code/unix-glibc2.lisp index 991ef31e8355967b15b67a164709bc82f32fe30b..74ed61db2747955ba0ce9ba171eed331c011bc89 100644 --- a/code/unix-glibc2.lisp +++ b/code/unix-glibc2.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/unix-glibc2.lisp,v 1.33 2004/08/31 12:39:43 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix-glibc2.lisp,v 1.34 2004/09/11 19:18:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -332,22 +332,26 @@ (format nil "Unknown error [~d]" error-number))) (defmacro syscall ((name &rest arg-types) success-form &rest args) - `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) - ,@args))) - (if (minusp result) - (values nil (unix-errno)) - ,success-form))) + `(locally + (declare (optimize (ext::float-accuracy 0))) + (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (values nil (unix-errno)) + ,success-form)))) ;;; Like syscall, but if it fails, signal an error instead of returning error ;;; codes. Should only be used for syscalls that will never really get an ;;; error. ;;; (defmacro syscall* ((name &rest arg-types) success-form &rest args) - `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) - ,@args))) - (if (minusp result) - (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg)) - ,success-form))) + `(locally + (declare (optimize (ext::float-accuracy 0))) + (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg)) + ,success-form)))) (defmacro void-syscall ((name &rest arg-types) &rest args) `(syscall (,name ,@arg-types) (values t 0) ,@args)) diff --git a/compiler/macros.lisp b/compiler/macros.lisp index dc0e5eb47c1594186b9f8ebbba102161ae49dd57..f5e57625fd77519a4f69540693ffc69a360dd2af 100644 --- a/compiler/macros.lisp +++ b/compiler/macros.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/compiler/macros.lisp,v 1.53 2004/04/07 02:47:53 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.54 2004/09/11 19:18:02 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -52,7 +52,7 @@ (defconstant policy-parameter-slots '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety) (cspeed . cookie-cspeed) (brevity . cookie-brevity) - (debug . cookie-debug))) + (debug . cookie-debug) (float-accuracy . cookie-float-accuracy))) ;;; Find-Used-Parameters -- Internal ;;; diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp index b29b66ad40a7f37abb7340fc42b57dae0c217752..a93cf99da23037a1004ac0ce87bad8d6cff8131e 100644 --- a/compiler/proclaim.lisp +++ b/compiler/proclaim.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/compiler/proclaim.lisp,v 1.41 2004/04/27 15:01:04 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.42 2004/09/11 19:18:02 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,8 @@ (in-package "C") (in-package "EXTENSIONS") -(export '(inhibit-warnings freeze-type optimize-interface constant-function)) +(export '(inhibit-warnings freeze-type optimize-interface constant-function + float-accuracy)) (in-package "KERNEL") (export '(note-name-defined define-function-name undefine-function-name *type-system-initialized* %note-type-defined)) @@ -41,7 +42,16 @@ (safety nil :type (or (rational 0 3) null)) (cspeed nil :type (or (rational 0 3) null)) (brevity nil :type (or (rational 0 3) null)) - (debug nil :type (or (rational 0 3) null))) + (debug nil :type (or (rational 0 3) null)) + ;; float-accuracy is intended for x86 FPU. It has no effect on + ;; other architectures. float-accuracy controls the rounding-mode. + ;; A value of 3 means that when calling out to C, we set the x86 FPU + ;; rounding mode to 64-bits. Otherwise the rounding-mode is left + ;; unchanged. By setting the rounding-mode to 53-bit, + ;; double-float-epsilon really is double-float-epsilon. However + ;; calling out to C with 53-bit mode affects the accuracy of + ;; floating-point functions, which normally want 64-bit. + (float-accuracy 3 :type (or (rational 0 3) null))) ;;; The *default-cookie* represents the current global compiler policy @@ -63,7 +73,8 @@ (defun proclaim-init () (setf *default-cookie* (make-cookie :safety 1 :speed 1 :space 1 :cspeed 1 - :brevity 1 :debug 2)) + :brevity 1 :debug 2 + :float-accuracy 3)) (setf *default-interface-cookie* (make-cookie))) ;;; @@ -302,6 +313,7 @@ (compilation-speed (setf (cookie-cspeed res) value)) ((inhibit-warnings brevity) (setf (cookie-brevity res) value)) ((debug-info debug) (setf (cookie-debug res) value)) + (float-accuracy (setf (cookie-float-accuracy res) value)) (t (compiler-warning "Unknown optimization quality ~S in ~S." (car quality) spec)))) diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp index 276d61c701cdc27da215bf82063b2e663be64774..daae843fd8f3fd676f6137f9f744f2734abbe281 100644 --- a/compiler/x86/c-call.lisp +++ b/compiler/x86/c-call.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/c-call.lisp,v 1.14 2003/05/14 14:38:39 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.15 2004/09/11 19:18:02 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -259,8 +259,17 @@ (define-vop (alloc-number-stack-space) (:info amount) (:results (result :scs (sap-reg any-reg))) + (:node-var node) (:generator 0 (assert (location= result esp-tn)) + ;; Set the rounding precision to 64-bits when calling out to C. + (when (policy node (= float-accuracy 3)) + (inst sub esp-tn 4) + (inst fnstcw (make-ea :word :base esp-tn)) + (inst wait) + (inst or (make-ea :word :base esp-tn) #x300) + (inst fldcw (make-ea :word :base esp-tn)) + (inst wait)) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst sub esp-tn delta))) @@ -268,10 +277,19 @@ (define-vop (dealloc-number-stack-space) (:info amount) + (:node-var node) (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst add esp-tn delta))))) + (inst add esp-tn delta))) + ;; Reset the rounding precision to 53-bits + (when (policy node (= float-accuracy 3)) + (inst fnstcw (make-ea :word :base esp-tn)) + (inst wait) + (inst and (make-ea :word :base esp-tn) #xfeff) + (inst fldcw (make-ea :word :base esp-tn)) + (inst wait) + (inst add esp-tn 4)))) (define-vop (alloc-alien-stack-space) (:info amount) diff --git a/lisp/Linux-os.c b/lisp/Linux-os.c index aedd4a456cc7930edd795e1a9ee8d9401efbcc57..1aeb610fc977c6148a46b9597f768330dbb24cbb 100644 --- a/lisp/Linux-os.c +++ b/lisp/Linux-os.c @@ -15,7 +15,7 @@ * GENCGC support by Douglas Crosher, 1996, 1997. * Alpha support by Julian Dolby, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.20 2004/07/08 04:10:09 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.21 2004/09/11 19:18:02 rtoy Exp $ * */ @@ -44,6 +44,7 @@ #include <netdb.h> #include <link.h> #include <dlfcn.h> +#include <fpu_control.h> #include "validate.h" size_t os_vm_page_size; @@ -83,7 +84,16 @@ void os_init(void) os_vm_page_size = getpagesize(); #if defined(i386) || defined(__x86_64) - setfpucw(0x1372|4|8|16|32); /* No interrupts */ +#if 0 + setfpucw(0x1272|4|8|16|32); /* No interrupts */ +#else + /* + * Round to nearest, double-float precision (not extended!), disable + * interrupts for everything except invalid. + */ + setfpucw(_FPU_RC_NEAREST | _FPU_DOUBLE | _FPU_MASK_PM | _FPU_MASK_UM | + _FPU_MASK_OM | _FPU_MASK_ZM | _FPU_MASK_DM); +#endif #endif }