(defun ea-for-df-stack (tn)
(ea-for-xf-stack tn :double)))
-;;; Telling the FPU to wait is required in order to make signals occur
-;;; at the expected place, but naturally slows things down.
-;;;
-;;; NODE is the node whose compilation policy controls the decision
-;;; whether to just blast through carelessly or carefully emit wait
-;;; instructions and whatnot.
-;;;
-;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
-;;; #'NOTE-NEXT-INSTRUCTION.
-(defun maybe-fp-wait (node &optional note-next-instruction)
- (when (policy node (or (= debug 3) (> safety speed))))
- (when note-next-instruction
- (note-next-instruction note-next-instruction :internal-error))
- #+nil
- (inst wait))
-
;;; complex float stack EAs
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
(declare (ignore kind))
(define-move-vop move-from-double :move
(double-reg) (descriptor-reg))
-#+nil
-(define-vop (move-from-fp-constant)
- (:args (x :scs (fp-constant)))
- (:results (y :scs (descriptor-reg)))
- (:generator 2
- (ecase (sb!c::constant-value (sb!c::tn-leaf x))
- (0f0 (load-symbol-value y *fp-constant-0f0*))
- (1f0 (load-symbol-value y *fp-constant-1f0*))
- (0d0 (load-symbol-value y *fp-constant-0d0*))
- (1d0 (load-symbol-value y *fp-constant-1d0*)))))
-#+nil
-(define-move-vop move-from-fp-constant :move
- (fp-constant) (descriptor-reg))
-
;;; Move from a descriptor to a float register.
(define-vop (move-to-single)
(:args (x :scs (descriptor-reg) :target tmp))
(:single 1)
(:double 2) ))
n-word-bytes)))))
- (with-tn@fp-top(x)
- ,@(ecase format
- (:single '((inst movss ea x)))
- (:double '((inst movsd ea x)))))))))))
+ ,@(ecase format
+ (:single '((inst movss ea x)))
+ (:double '((inst movsd ea x))))))))))
(define-move-vop ,name :move-arg
(,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack :single)
(frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
(frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
-#+nil
-(macrolet ((frob (name translate inst to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (unsigned-reg)))
- (:results (y :scs (,to-sc)))
- (:arg-types unsigned-num)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 6
- (inst ,inst y x)))))
- (frob %single-float/unsigned %single-float cvtsi2ss single-reg single-float)
- (frob %double-float/unsigned %double-float cvtsi2sd double-reg double-float))
-
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
`(define-vop (,name)
(:args (x :scs (,from-sc) :target y))
(frob %unary-round cvtss2si single-reg single-float t)
(frob %unary-round cvtsd2si double-reg double-float t))
-#+nil ;; will we need this?
-(macrolet ((frob (trans from-sc from-type round-p)
- `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
- (:args (x :scs (,from-sc) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- ,@(unless round-p
- '((:temporary (:sc unsigned-stack) stack-temp)
- (:temporary (:sc unsigned-stack) scw)
- (:temporary (:sc any-reg) rcw)))
- (:results (y :scs (unsigned-reg)))
- (:arg-types ,from-type)
- (:result-types unsigned-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- ,@(unless round-p
- '((note-this-location vop :internal-error)
- ;; Catch any pending FPE exceptions.
- (inst wait)))
- ;; Normal mode (for now) is "round to best".
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x))
- ,@(unless round-p
- '((inst fnstcw scw) ; save current control word
- (move rcw scw) ; into 16-bit register
- (inst or rcw (ash #b11 10)) ; CHOP
- (move stack-temp rcw)
- (inst fldcw stack-temp)))
- (inst sub rsp-tn 8)
- (inst fistpl (make-ea :dword :base rsp-tn))
- (inst pop y)
- (inst fld fr0) ; copy fr0 to at least restore stack.
- (inst add rsp-tn 8)
- ,@(unless round-p
- '((inst fldcw scw)))))))
- (frob %unary-truncate single-reg single-float nil)
- (frob %unary-truncate double-reg double-float nil)
- (frob %unary-round single-reg single-float t)
- (frob %unary-round double-reg double-float t))
-
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
:load-if (not (or (and (sc-is bits signed-stack)
(sc-is res single-stack)
(location= bits res))))))
(:results (res :scs (single-reg single-stack)))
- ; (:temporary (:sc signed-stack) stack-temp)
(:arg-types signed-num)
(:result-types single-float)
(:translate make-single-float)
(inst movsd temp float)
(move hi-bits temp))
(double-stack
- (loadw hi-bits ebp-tn (- (tn-offset float))))
+ (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
(descriptor-reg
(loadw hi-bits float double-float-value-slot
other-pointer-lowtag)))
(inst movsd temp float)
(move lo-bits temp))
(double-stack
- (loadw lo-bits ebp-tn (- (tn-offset float))))
+ (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
(descriptor-reg
(loadw lo-bits float double-float-value-slot
other-pointer-lowtag)))
(inst shr lo-bits 32)))
\f
-;;;; 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)
-
-(define-vop (floating-point-modes)
- (:results (res :scs (unsigned-reg)))
- (:result-types unsigned-num)
- (:translate floating-point-modes)
- (:policy :fast-safe)
- (:temporary (:sc unsigned-stack :from :argument :to :result) temp)
- (:generator 8
- (inst stmxcsr temp)
- (move res temp)
- ;; Extract status from bytes 0-5 to bytes 16-21
- (inst and temp (1- (expt 2 6)))
- (inst shl temp 16)
- ;; Extract mask from bytes 7-12 to bytes 0-5
- (inst shr res 7)
- (inst and res (1- (expt 2 6)))
- ;; Flip the bits to convert from "1 means exception masked" to
- ;; "1 means exception enabled".
- (inst xor res (1- (expt 2 6)))
- (inst or res temp)))
-
-(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 :from :argument :to :result) temp1)
- (:temporary (:sc unsigned-stack :from :argument :to :result) temp2)
- (:generator 3
- (move res new)
- (inst stmxcsr temp2)
- ;; Clear status + masks
- (inst and temp2 (lognot (logior (1- (expt 2 6))
- (ash (1- (expt 2 6)) 7))))
- ;; Replace current status
- (move temp1 new)
- (inst shr temp1 16)
- (inst and temp1 (1- (expt 2 6)))
- (inst or temp2 temp1)
- ;; Replace exception masks
- (move temp1 new)
- (inst and temp1 (1- (expt 2 6)))
- (inst xor temp1 (1- (expt 2 6)))
- (inst shl temp1 7)
- (inst or temp2 temp1)
- (inst ldmxcsr temp2)))
-\f
;;;; complex float VOPs