-;;;; float mode hackery
-
-(sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
- float-modes)
-
-(def!constant npx-env-size (* 7 n-word-bytes))
-(def!constant npx-cw-offset 0)
-(def!constant npx-sw-offset 4)
-
-(define-vop (floating-point-modes)
- (:results (res :scs (unsigned-reg)))
- (:result-types unsigned-num)
- (:translate floating-point-modes)
- (:policy :fast-safe)
- (:temporary (:sc unsigned-reg :offset eax-offset :target res
- :to :result) eax)
- (:generator 8
- (inst sub rsp-tn npx-env-size) ; Make space on stack.
- (inst wait) ; Catch any pending FPE exceptions
- (inst fstenv (make-ea :dword :base rsp-tn)) ; masks all exceptions
- (inst fldenv (make-ea :dword :base rsp-tn)) ; Restore previous state.
- ;; Move current status to high word.
- (inst movzxd eax (make-ea :dword :base rsp-tn :disp (- npx-sw-offset 2)))
- ;; Move exception mask to low word.
- (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset))
- (inst add rsp-tn npx-env-size) ; Pop stack.
- (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
- (move res eax)))
-
-;;; XXX BROKEN
-(define-vop (set-floating-point-modes)
- (:args (new :scs (unsigned-reg) :to :result :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 unsigned-reg :offset eax-offset
- :from :eval :to :result) eax)
- (:generator 3
- (inst sub rsp-tn npx-env-size) ; Make space on stack.
- (inst wait) ; Catch any pending FPE exceptions.
- (inst fstenv (make-ea :dword :base rsp-tn))
- (inst mov eax new)
- (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
- (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn)
- (inst shr eax 16) ; position status word
- (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn)
- (inst fldenv (make-ea :dword :base rsp-tn))
- (inst add rsp-tn npx-env-size) ; Pop stack.
- (move res new)))
-\f