Skip to content
Snippets Groups Projects
Commit 571091c7 authored by rtoy's avatar rtoy
Browse files

Port of SBCL's float-accuracy compilation policy. Intended to make

double-float-epsilon actually be epsilon on x86.  No effect on other
ports.

The default precision is now 53-bit (double-float) instead of 64-bit
(80-bit floats).  However, to preserve C expectations, all calls to C
have the precision set to 64-bit.  This slows down calls to C, but we
try to make syscalls and such fast by not changing precision for the
call.

By default ext:float-accuracy is 3.

Use boot7.lisp to bootstrap.
parent 5b37fd20
No related branches found
No related tags found
No related merge requests found
;; 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))))
......@@ -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))
......
......@@ -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
;;;
......
......@@ -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))))
......
......@@ -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)
......
......@@ -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
}
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment