From 26497b49513d1a9931ff7bbf7127b256f761e3b2 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Fri, 7 Dec 1990 18:00:37 +0000 Subject: [PATCH] Added GET-FLOATING-POINT-MODES to read the floating point modes. Added support in SET-FLOATING-POINT-MODES to set all the interesting state. Fixed SIGFPE handler to not signal conditions for exceptions that are not currently trapped (in case the operation had multiple exceptions), some of which were not trapped. --- code/float-trap.lisp | 101 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 88 insertions(+), 13 deletions(-) diff --git a/code/float-trap.lisp b/code/float-trap.lisp index 1c337dd01..feed75396 100644 --- a/code/float-trap.lisp +++ b/code/float-trap.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.3 1990/12/06 17:38:10 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.4 1990/12/07 18:00:37 ram Exp $ ;;; ;;; This file contains stuff for controlling floating point traps. It is ;;; IEEE float specific, but should work for pretty much any FPU where the @@ -18,7 +18,7 @@ (in-package "VM") (export '(current-float-trap floating-point-modes sigfpe-handler)) (in-package "EXTENSIONS") -(export '(set-floating-point-modes)) +(export '(set-floating-point-modes get-floating-point-modes)) (in-package "VM") (eval-when (compile load eval) @@ -30,7 +30,6 @@ (cons :invalid float-invalid-trap-bit) (cons :divide-by-zero float-divide-by-zero-trap-bit))) - ;;; FLOAT-TRAP-MASK -- Internal ;;; ;;; Return a mask with all the specified float trap bits set. @@ -41,6 +40,12 @@ (or (cdr (assoc x float-trap-alist)) (error "Unknown float trap kind: ~S." x))) names))) + +(defconstant rounding-mode-alist + (list (cons :nearest float-round-to-nearest) + (cons :zero float-round-to-zero) + (cons :positive-infinity float-round-to-positive) + (cons :negative-infinity float-round-to-negative))) ); Eval-When (Compile Load Eval) @@ -53,17 +58,86 @@ ;;; SET-FLOATING-POINT-MODES -- Public ;;; -(defun set-floating-point-modes (&key traps) - "Set options for the floating point hardware: - :Traps +(defun set-floating-point-modes (&key (traps nil traps-p) + (rounding-mode nil round-p) + (current-exceptions nil current-x-p) + (accrued-exceptions nil accrued-x-p) + (fast-mode nil fast-mode-p)) + "This function sets options controlling the floating-point hardware. If a + keyword is not supplied, then the current value is preserved. Possible + keywords: + + :TRAPS A list of the exception conditions that should cause traps. Possible - exceptions are :underflow, :overflow, :inexact, :invalid and - :divide-by-zero." - (setf (ldb float-traps-byte (floating-point-modes)) - (float-trap-mask traps)) + exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and + :DIVIDE-BY-ZERO. Initially all traps except :INEXACT are enabled. + + :ROUNDING-MODE + The rounding mode to use when the result is not exact. Possible values + are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO. + Initially, the rounding mode is :NEAREST. + + :CURRENT-EXCEPTIONS + :ACCRUED-EXCEPTIONS + These arguments allow setting of the exception flags. The main use is + setting the accrued exceptions to NIL to clear them. + + :FAST-MODE + Set the hardware's \"fast mode\" flag, if any. When set, IEEE + conformance or debuggability may be impaired. Some machines may not + have this feature, in which case the value is always NIL. + + GET-FLOATING-POINT-MODES may be used to find the floating point modes + currently in effect." + (let ((modes (floating-point-modes))) + (when traps-p + (setf (ldb float-traps-byte modes) (float-trap-mask traps))) + (when round-p + (setf (ldb float-rounding-mode modes) + (or (cdr (assoc rounding-mode rounding-mode-alist)) + (error "Unknown rounding mode: ~S." rounding-mode)))) + (when current-x-p + (setf (ldb float-exceptions-byte modes) + (float-trap-mask current-exceptions))) + (when accrued-x-p + (setf (ldb float-sticky-bits modes) + (float-trap-mask accrued-exceptions))) + (when fast-mode-p + (if fast-mode + (setq modes (logior float-fast-bit modes)) + (setq modes (logand (lognot float-fast-bit) modes)))) + (setf (floating-point-modes) modes)) + (values)) +;;; GET-FLOATING-POINT-MODES -- Public +;;; +(defun get-floating-point-modes () + "This function returns a list representing the state of the floating point + modes. The list is in the same format as the keyword arguments to + SET-FLOATING-POINT-MODES, i.e. + (apply #'set-floating-point-modes (get-floating-point-modes)) + + sets the floating point modes to their current values (and thus is a no-op)." + (flet ((exc-keys (bits) + (macrolet ((frob () + `(collect ((res)) + ,@(mapcar #'(lambda (x) + `(when (logtest bits ,(cdr x)) + (res ',(car x)))) + float-trap-alist) + (res)))) + (frob)))) + (let ((modes (floating-point-modes))) + `(:traps ,(exc-keys (ldb float-traps-byte modes)) + :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) + 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))))) + + ;;; CURRENT-FLOAT-TRAP -- Interface ;;; (defmacro current-float-trap (&rest traps) @@ -80,8 +154,9 @@ ;;; (defun sigfpe-handler (signal code scp) (declare (ignore signal code)) - (let ((traps (ldb float-exceptions-byte - (sigcontext-floating-point-modes scp)))) + (let* ((modes (sigcontext-floating-point-modes scp)) + (traps (logand (ldb float-exceptions-byte modes) + (ldb float-traps-byte modes)))) (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) (error 'division-by-zero)) ((not (zerop (logand float-invalid-trap-bit traps))) @@ -93,4 +168,4 @@ ((not (zerop (logand float-inexact-trap-bit traps))) (error 'ext:floating-point-inexact)) (t - (error "SIGFPE with no current exceptions?"))))) + (error "SIGFPE with no exceptions currently enabled?"))))) -- GitLab