(setf (deref (context-float-register-addr context index))
(coerce new format)))
+;;; This sets the software fp_control word, which is not the same
+;;; thing as the hardware fpcr. We have to do this so that OS FPU
+;;; completion works properly
+
+;;; Note that this means we can't set rounding modes; we'd have to do
+;;; that separately. That said, almost everybody seems to agree that
+;;; changing the rounding mode is rarely a good idea, because it upsets
+;;; libm functions. So adding that is not a priority. Sorry.
+;;; -dan 2001.02.06
+
+(define-alien-routine
+ ("arch_get_fp_control" floating-point-modes) (sb!alien:unsigned 64))
+
+(define-alien-routine
+ ("arch_set_fp_control" %floating-point-modes-setter) void (fp (sb!alien:unsigned 64)))
+
+(defun (setf floating-point-modes) (val) (%floating-point-modes-setter val))
+
;;; Given a signal context, return the floating point modes word in
;;; the same format as returned by FLOATING-POINT-MODES.
-(defun context-floating-point-modes (context)
- ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
- ;; POSIXness and (at the Lisp level) opaque signal contexts,
- ;; this is stubified. It needs to be rewritten as an
- ;; alien function.
- (warn "stub CONTEXT-FLOATING-POINT-MODES")
-
- ;; old code for Linux:
- #+nil
- (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
- (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
- ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
- ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
- (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
- ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
- ;; Simulate floating-point-modes VOP.
- (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
-
- 0)
+(define-alien-routine ("os_context_fp_control" context-floating-point-modes)
+ (sb!alien:unsigned 64) (context (* os-context-t)))
+
\f
;;;; INTERNAL-ERROR-ARGS
;; FIXME: This list of modes should be defined in one place and
;; explicitly shared between here and REINIT.
- ;;
- ;; FIXME: In CMU CL, this is done "here" (i.e. in the analogous
- ;; lispinit.lisp code) for every processor architecture. But Daniel
- ;; Barlow's Alpha patches suppress it for Alpha. Why the difference?
- #!+alpha
- (set-floating-point-modes :traps '(:overflow
- #!+alpha :underflow
- :invalid
- :divide-by-zero))
+
+ ;; Why was this marked #!+alpha? CMUCL does it here on all architectures
+ (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
(show-and-call !class-finalize)
(signal-cold-init-or-reinit)
(gc-reinit)
(setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
- (set-floating-point-modes :traps
- '(:overflow
- :invalid
- :divide-by-zero
- ;; PRINT seems not to like x86 NPX
- ;; denormal floats like
- ;; LEAST-NEGATIVE-SINGLE-FLOAT, so
- ;; the :UNDERFLOW exceptions are
- ;; disabled by default. Joe User can
- ;; explicitly enable them if
- ;; desired.
- #!+alpha :underflow))
+ ;; PRINT seems not to like x86 NPX denormal floats like
+ ;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are
+ ;; disabled by default. Joe User can explicitly enable them if
+ ;; desired.
+ (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
+
;; Clear pseudo atomic in case this core wasn't compiled with
;; support.
;;
names)))
) ; EVAL-WHEN
-;;; interpreter stubs
-(defun floating-point-modes () (floating-point-modes))
-(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
+;;; interpreter stubs for floating point modes get/setters for the
+;;; alpha have been removed to alpha-vm.lisp, as they are implemented
+;;; in C rather than as VOPs.
+#!-alpha
+(progn
+ (defun floating-point-modes ()
+ (floating-point-modes))
+ (defun (setf floating-point-modes) (new)
+ (setf (floating-point-modes) new)))
;;; This function sets options controlling the floating-point
;;; hardware. If a keyword is not supplied, then the current value is
;;; :TRAPS
;;; A list of the exception conditions that should cause traps.
;;; Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
-;;; :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
-;;; all traps except :INEXACT are enabled.
+;;; :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND.
;;;
;;;: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.
+;;; :ZERO. Setting this away from :NEAREST is liable to upset SBCL's
+;;; maths routines which depend on it.
;;;
;;;:CURRENT-EXCEPTIONS
;;;:ACCRUED-EXCEPTIONS
;;;
;;;: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.
+;;; conformance or debuggability may be impaired. Some machines don't
+;;; have this feature, and some SBCL ports don't implement it anyway
+;;; -- in such cases the value is always NIL.
;;;
;;; GET-FLOATING-POINT-MODES may be used to find the floating point modes
-;;; currently in effect.
+;;; currently in effect. See cold-init.lisp for the list of initially
+;;; enabled traps
+
(defun set-floating-point-modes (&key (traps nil traps-p)
(rounding-mode nil round-p)
(current-exceptions nil current-x-p)
(defun sigfpe-handler (signal info context)
(declare (ignore signal info context))
(declare (type system-area-pointer context))
- ;; FIXME: The find-the-detailed-problem code below went stale with
- ;; the big switchover to POSIX signal handling and signal contexts
- ;; which are opaque at the Lisp level ca. sbcl-0.6.7. It needs to be
- ;; revived, which will require writing a C-level os-dependent
- ;; function to extract floating point modes, and a Lisp-level
- ;; DEFINE-ALIEN-ROUTINE to get to the C-level os-dependent function.
- ;; Meanwhile we just say "something went wrong".
- (error 'floating-point-exception)
- #|
(let* ((modes (context-floating-point-modes
(sb!alien:sap-alien context (* os-context-t))))
(traps (logand (ldb float-exceptions-byte modes)
(error 'floating-point-exception
:traps (getf (get-floating-point-modes) :traps)))
(t
- (error "SIGFPE with no exceptions currently enabled?"))))
- |#
- )
+ (error 'floating-point-exception)))))
;;; Execute BODY with the floating point exceptions listed in TRAPS
;;; masked (disabled). TRAPS should be a list of possible exceptions
;;;; float conversion
(macrolet
- ((frob (name translate inst ld-inst to-sc to-type &optional single)
- (declare (ignorable single))
+ ((frob (name translate inst ld-inst to-sc to-type)
`(define-vop (,name)
(:args (x :scs (signed-reg) :target temp
:load-if (not (sc-is x signed-stack))))
- (:temporary (:scs (single-stack)) temp)
- (:results (y :scs (,to-sc)))
+ (:temporary (:scs (,to-sc)) freg1)
+ (:temporary (:scs (,to-sc)) freg2)
+ (:temporary (:scs (single-stack)) temp)
+
+ (:results (y :scs (,to-sc)))
(:arg-types signed-num)
(:result-types ,to-type)
(:policy :fast-safe)
temp)
(signed-stack
x))))
- (inst ,ld-inst y
+ (inst ,ld-inst freg1
(* (tn-offset stack-tn) n-word-bytes)
(current-nfp-tn vop))
(note-this-location vop :internal-error)
- ,@(when single
- `((inst cvtlq y y)))
- (inst ,inst y y))))))
- (frob %single-float/signed %single-float cvtqs lds single-reg single-float t)
- (frob %double-float/signed %double-float cvtqt lds double-reg double-float t))
-
+ (inst cvtlq freg1 freg2)
+ (inst ,inst freg2 y)
+ (inst excb)
+ )))))
+ (frob %single-float/signed %single-float cvtqs_sui lds single-reg single-float)
+ (frob %double-float/signed %double-float cvtqt_sui lds double-reg double-float))
+
+;;; see previous comment about software trap handlers: also applies here
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
`(define-vop (,name)
- (:args (x :scs (,from-sc)))
- (:results (y :scs (,to-sc)))
- (:arg-types ,from-type)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 2
- (note-this-location vop :internal-error)
- (inst ,inst x y)))))
- (frob %single-float/double-float %single-float cvtts
- double-reg double-float single-reg single-float)
+ (:args (x :scs (,from-sc)))
+ (:results (y :scs (,to-sc) :from :load))
+ (:arg-types ,from-type)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 2
+ (note-this-location vop :internal-error)
+ (inst ,inst x y)
+ (inst excb)
+ ))))
+ (frob %single-float/double-float %single-float cvtts_su
+ double-reg double-float single-reg single-float)
(frob %double-float/single-float %double-float fmove
- single-reg single-float double-reg double-float))
+ single-reg single-float double-reg double-float))
(macrolet
((frob (trans from-sc from-type inst &optional single)
- (declare (ignorable single))
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc) :target temp))
- (:temporary (:from (:argument 0) :sc single-reg) temp)
- (:temporary (:scs (signed-stack)) stack-temp)
- (:results (y :scs (signed-reg)
- :load-if (not (sc-is y signed-stack))))
- (:arg-types ,from-type)
- (:result-types signed-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- (inst ,inst x temp)
- (sc-case y
- (signed-stack
- (inst stt temp
- (* (tn-offset y) n-word-bytes)
- (current-nfp-tn vop)))
- (signed-reg
- (inst stt temp
- (* (tn-offset stack-temp)
- n-word-bytes)
- (current-nfp-tn vop))
- (inst ldq y
- (* (tn-offset stack-temp) n-word-bytes)
- (current-nfp-tn vop))))))))
- (frob %unary-truncate single-reg single-float cvttq/c t)
- (frob %unary-truncate double-reg double-float cvttq/c)
- (frob %unary-round single-reg single-float cvttq t)
- (frob %unary-round double-reg double-float cvttq))
+ (declare (ignorable single))
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc) :target temp))
+ (:temporary (:from :load ;(:argument 0)
+ :sc single-reg) temp)
+ (:temporary (:scs (signed-stack)) stack-temp)
+ (:results (y :scs (signed-reg)
+ :load-if (not (sc-is y signed-stack))))
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (inst ,inst x temp)
+ (sc-case y
+ (signed-stack
+ (inst stt temp
+ (* (tn-offset y) n-word-bytes)
+ (current-nfp-tn vop)))
+ (signed-reg
+ (inst stt temp
+ (* (tn-offset stack-temp)
+ n-word-bytes)
+ (current-nfp-tn vop))
+ (inst ldq y
+ (* (tn-offset stack-temp) n-word-bytes)
+ (current-nfp-tn vop))))
+ (inst excb)
+ ))))
+ (frob %unary-truncate single-reg single-float cvttq/c_sv t)
+ (frob %unary-truncate double-reg double-float cvttq/c_sv)
+ (frob %unary-round single-reg single-float cvttq_sv t)
+ (frob %unary-round double-reg double-float cvttq_sv))
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
(inst mskll lo-bits 4 lo-bits)))
\f
-;;;; float mode hackery
-
-(sb!xc:deftype float-modes () '(unsigned-byte 32)) ;actually 24 -dan
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
- float-modes)
-
-;;; Modes bits are (byte 12 52) of fpcr. Grab and return in low bits.
-(define-vop (floating-point-modes)
- (:results (res :scs (unsigned-reg)))
- (:result-types unsigned-num)
- (:translate floating-point-modes)
- (:policy :fast-safe)
- (:vop-var vop)
- (:temporary (:sc double-stack) temp)
- (:temporary (:sc double-reg) temp1)
- (:generator 5
- (let ((nfp (current-nfp-tn vop)))
- (inst excb)
- (inst mf_fpcr temp1 temp1 temp1)
- (inst excb)
- (inst stt temp1 (* n-word-bytes (tn-offset temp)) nfp)
- (inst ldl res (* (1+ (tn-offset temp)) n-word-bytes) nfp)
- (inst srl res 49 res))))
-
-(define-vop (set-floating-point-modes)
- (:args (new :scs (unsigned-reg) :target res))
- (:results (res :scs (unsigned-reg)))
- (:arg-types unsigned-num)
- (:result-types unsigned-num)
- (:translate (setf floating-point-modes))
- (:policy :fast-safe)
- (:temporary (:sc double-stack) temp)
- (:temporary (:sc double-reg) temp1)
- (:vop-var vop)
- (:generator 8
- (let ((nfp (current-nfp-tn vop)))
- (inst sll new 49 res)
- (inst stl zero-tn (* (tn-offset temp) n-word-bytes) nfp)
- (inst stl res (* (1+ (tn-offset temp)) n-word-bytes) nfp)
- (inst ldt temp1 (* (tn-offset temp) n-word-bytes) nfp)
- (inst excb)
- (inst mt_fpcr temp1 temp1 temp1)
- (inst excb)
- (move res new))))
+;;;; float mode hackery has moved to alpha-vm.lisp
\f
;;;; complex float VOPs
(:translate imagpart)
(:note "complex double float imagpart")
(:variant :imag))
+
(defconstant +suid+ #x7c0)
(define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2)
+ (define-fp-operate cvtqs_sui #x16 (logior +sui+ #x0bc) 2)
(define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
+ (define-fp-operate cvtqt_sui #x16 (logior +sui+ #x0be) 2)
(define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)
+ (define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2)
+ (define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 2)
+
(define-fp-operate adds_su #x16 (logior +su+ #x080))
(define-fp-operate addt_su #x16 (logior +su+ #x0a0))
(define-fp-operate divs_su #x16 (logior +su+ #x083))
(defconstant double-float-digits
(+ (byte-size double-float-significand-byte) n-word-bits 1))
-;; Values in 17f code seem to be same as HPPA. These values are from
-;; DEC Assembly Language Programmers guide. The active bits are
-;; actually in (byte 12 52) of the fpcr. (byte 6 52) contain the
-;; exception flags. Bit 63 is the bitwise logor of all exceptions.
-;; The enable and exception bytes are in a software control word
-;; manipulated via OS functions and the bits in the SCP match those
-;; defs. This mapping follows <machine/fpu.h>
+;;; These values are originally from the DEC Assembly Language
+;;; Programmers guide. Where possible we read/write the software
+;;; fp_control word, which apparently is necessary for the OS FPU
+;;; completion (OS handler which fixes up non-IEEE answers that the
+;;; hardware occasionally gives us) to work properly. The rounding
+;;; mode, however, can't be set that way, so we have to deal with that
+;;; directly. (FIXME: we actually don't suport setting the rounding mode
+;;; at the moment anyway)
+
+;;; Short guide to floating point trap terminology: an "exception" is
+;;; cheap and can happen at almost any time. An exception will only
+;;; generate a trap if that trap is enabled, otherwise a default value
+;;; will be substituted. A "trap" will end up somewhere in the
+;;; kernel, which may play by its own rules, (on Alpha it allegedly
+;;; actually fixes up some non-IEEE compliant results to get the
+;;; _right_ answer) but if something is really wrong will eventually
+;;; signal SIGFPE and let us sort it out.
+
+;;; Old comment follows: The active bits are actually in (byte 12 52)
+;;; of the fpcr. (byte 6 52) contain the exception flags. Bit 63 is the
+;;; bitwise logor of all exceptions. The enable and exception bytes
+;;; are in a software control word manipulated via OS functions and the
+;;; bits in the SCP match those defs. This mapping follows
+;;; <machine/fpu.h>
+
+;;; trap enables are set in software (fp_control)
(defconstant float-inexact-trap-bit (ash 1 4)) ; rw
(defconstant float-underflow-trap-bit (ash 1 3)) ; rw
(defconstant float-overflow-trap-bit (ash 1 2)) ; ro
(defconstant float-divide-by-zero-trap-bit (ash 1 1)) ; ro
(defconstant float-invalid-trap-bit (ash 1 0)) ; ro
+(defconstant-eqx float-traps-byte (byte 6 1) #'equalp)
+;;; exceptions are also read/written in software (by syscalls, no less).
+;;; This is kind of dumb, but has to be done
+(defconstant-eqx float-sticky-bits (byte 6 17) #'equalp) ; fp_control
+
+;;; (We don't actually _have_ "current exceptions" on Alpha; the
+;;; hardware only ever sets bits. So, set this the same as accrued
+;;; exceptions)
+(defconstant-eqx float-exceptions-byte (byte 6 17) #'equalp)
+
+;;; Rounding modes can only be set by frobbing the hardware fpcr directly
(defconstant float-round-to-zero 0)
(defconstant float-round-to-negative 1)
(defconstant float-round-to-nearest 2)
(defconstant float-round-to-positive 3)
+(defconstant-eqx float-rounding-mode (byte 2 58) #'equalp)
-;; These aren't quite correct yet. Work in progress.
-(defconstant-eqx float-rounding-mode (byte 2 58) #'equalp) ; hardware fpcr
-(defconstant-eqx float-exceptions-byte (byte 6 52) #'equalp) ; hardware fpcr
-(defconstant-eqx float-sticky-bits (byte 6 17) #'equalp) ; software (clear only)
-(defconstant-eqx float-traps-byte (byte 6 1) #'equalp) ; software fp control word
-(defconstant float-condition-bit (ash 1 63)) ; summary - not used?? XXX
+;;; Miscellaneous stuff - I think it's far to say that you deserve
+;;; what you get if you ask for fast mode.
(defconstant float-fast-bit 0)
); eval-when
# else.
CFLAGS += -mcpu=pca56 -Dalpha
LD = ld -taso
-LINKFLAGS = -v -g -Wl,-T -Wl,ld-script.alpha-linux
+LINKFLAGS = -dynamic -v -g -Wl,-T -Wl,ld-script.alpha-linux
NM = nm -p
ASSEM_SRC = alpha-assem.S ldso-stubs.S
}
}
-static void sigfpe_handler(int signal, int code, os_context_t *context)
+unsigned long
+arch_get_fp_control()
{
- /* what should this contain? interesting question. If it really
- * is empty, why don't we just ignore the signal? -dan 2001.08.10
- */
+ return ieee_get_fp_control();
+}
+
+void
+arch_set_fp_control(unsigned long fp)
+{
+ ieee_set_fp_control(fp);
}
+
void arch_install_interrupt_handlers()
{
undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler);
- undoably_install_low_level_interrupt_handler(SIGFPE, sigfpe_handler);
}
extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
#include <sys/time.h>
#include <sys/stat.h>
#include <unistd.h>
+#include <asm/fpu.h>
#include "validate.h"
size_t os_vm_page_size;
return &context->uc_sigmask;
}
+unsigned long
+os_context_fp_control(os_context_t *context)
+{
+ return ieee_fpcr_to_swcr((context->uc_mcontext).sc_fpcr);
+}
+
+
void os_flush_icache(os_vm_address_t address, os_vm_size_t length)
{
asm volatile ("imb" : : : "memory" );
sigaddset(s, SIGPIPE);
sigaddset(s, SIGALRM);
sigaddset(s, SIGURG);
+ sigaddset(s, SIGFPE);
sigaddset(s, SIGTSTP);
sigaddset(s, SIGCHLD);
sigaddset(s, SIGIO);
{
undo_fake_foreign_function_call(context);
}
- fprintf(stderr,"interrupt-handle-pending: back from MAYBE_GC\n");
}
/* FIXME: This isn't very clear. It would be good to reverse
LDSO_STUBIFY(log)
LDSO_STUBIFY(log10)
LDSO_STUBIFY(sqrt)
-#endif
\ No newline at end of file
+#endif
+#if defined alpha
+ LDSO_STUBIFY(ieee_get_fp_control)
+ LDSO_STUBIFY(ieee_set_fp_control)
+#endif
return &context->uc_mcontext.gregs[17];
}
+unsigned long
+os_context_fp_control(os_context_t *context)
+{
+ /* probably the code snippet
+ * #ifdef __linux__
+ * SET_FPU_CONTROL_WORD(context->__fpregs_mem.cw);
+ * #endif
+ * is relevant to implementing this correctly */
+
+ /* Note that currently this is not called, as there is an analogous
+ * stub in lisp-land (x86-vm.lisp), also returning 0, with the old
+ * lisp fp-control code. This is here more as a signpost of a possible
+ * way of restoring functionality, and if it is the way to go would
+ * need to be included for other architectures as well. */
+ return 0;
+}
+
sigset_t *
os_context_sigmask_addr(os_context_t *context)
{
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.1.41"
+"0.7.1.42"
projects / sbcl.git / commitdiff