(defun ea-for-lf-stack (tn)
(ea-for-xf-stack tn :long)))
-;;; Complex float stack EAs
+;;; 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))
+ (inst wait))
+
+;;; complex float stack EAs
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
`(make-ea
:dword :base ,base
;;;
;;; Using a Pop then load.
(defun copy-fp-reg-to-fr0 (reg)
- (assert (not (zerop (tn-offset reg))))
+ (aver (not (zerop (tn-offset reg))))
(inst fstp fr0-tn)
(inst fld (make-random-tn :kind :normal
:sc (sc-or-lose 'double-reg)
;;; Using Fxch then Fst to restore the original reg contents.
#+nil
(defun copy-fp-reg-to-fr0 (reg)
- (assert (not (zerop (tn-offset reg))))
+ (aver (not (zerop (tn-offset reg))))
(inst fxch reg)
(inst fst reg))
;; This may not be necessary as ST0 is likely invalid now.
(inst fxch x))))
-;;; The i387 has instructions to load some useful constants.
-;;; This doesn't save much time but might cut down on memory
-;;; access and reduce the size of the constant vector (CV).
-;;; Intel claims they are stored in a more precise form on chip.
-;;; Anyhow, might as well use the feature. It can be turned
-;;; off by hacking the "immediate-constant-sc" in vm.lisp.
+;;; The i387 has instructions to load some useful constants. This
+;;; doesn't save much time but might cut down on memory access and
+;;; reduce the size of the constant vector (CV). Intel claims they are
+;;; stored in a more precise form on chip. Anyhow, might as well use
+;;; the feature. It can be turned off by hacking the
+;;; "immediate-constant-sc" in vm.lisp.
(define-move-function (load-fp-constant 2) (vop x y)
((fp-constant) (single-reg double-reg #!+long-float long-reg))
(let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
(inst fldlg2))
((= value (log 2l0 2.718281828459045235360287471352662L0))
(inst fldln2))
- (t (warn "Ignoring bogus i387 Constant ~A" value))))))
+ (t (warn "ignoring bogus i387 constant ~A" value))))))
\f
;;;; complex float move functions
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
:offset (1+ (tn-offset x))))
-;;; x is source, y is destination
+;;; x is source, y is destination.
(define-move-function (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((real-tn (complex-single-reg-real-tn y)))
\f
;;;; move VOPs
-;;; Float register to register moves.
+;;; float register to register moves
(define-vop (float-move)
(:args (x))
(:results (y))
(define-move-vop move-from-fp-constant :move
(fp-constant) (descriptor-reg))
-;;; Move from a descriptor to a float register
+;;; Move from a descriptor to a float register.
(define-vop (move-to-single)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (single-reg)))
(inst fldl (ea-for-lf-desc x)))))
#!+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
-
\f
;;; Move from complex float to a descriptor reg. allocating a new
;;; complex float object in the process.
(define-move-vop move-from-complex-long :move
(complex-long-reg) (descriptor-reg))
-;;; Move from a descriptor to a complex float register
+;;; Move from a descriptor to a complex float register.
(macrolet ((frob (name sc format)
`(progn
(define-vop (,name)
(frob move-to-complex-double complex-double-reg :double)
#!+long-float
(frob move-to-complex-double complex-long-reg :long))
-
\f
-;;;; The move argument vops.
+;;;; the move argument vops
;;;;
-;;;; Note these are also used to stuff fp numbers onto the c-call stack
-;;;; so the order is different than the lisp-stack.
+;;;; Note these are also used to stuff fp numbers onto the c-call
+;;;; stack so the order is different than the lisp-stack.
-;;; The general move-argument vop
+;;; the general move-argument vop
(macrolet ((frob (name sc stack-sc format)
`(progn
(define-vop (,name)
#!+long-float
(frob move-long-float-argument long-reg long-stack :long))
-;;;; Complex float move-argument vop
+;;;; complex float move-argument vop
(macrolet ((frob (name sc stack-sc format)
`(progn
(define-vop (,name)
\f
;;;; arithmetic VOPs
-;;; dtc: The floating point arithmetic vops.
+;;; dtc: the floating point arithmetic vops
;;;
;;; Note: Although these can accept x and y on the stack or pointed to
;;; from a descriptor register, they will work with register loading
(inst fld (ea-for-sf-desc y)))))
;; ST(i) = ST(i) op ST0
(inst ,fop-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; y and r are the same register.
((and (sc-is y single-reg) (location= y r))
(cond ((zerop (tn-offset r))
(inst fld (ea-for-sf-desc x)))))
;; ST(i) = ST(0) op ST(i)
(inst ,fopr-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
- ;; The default case
+ (maybe-fp-wait node vop))
+ ;; the default case
(t
;; Get the result to ST0.
(note-next-instruction vop :internal-error)
- ;; Finally save the result
+ ;; Finally save the result.
(sc-case r
(single-reg
(cond ((zerop (tn-offset r))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst r))))
(single-stack
(:save-p :compute-only)
(:node-var node)
(:generator ,dcost
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; x, y, and r are the same register.
((and (sc-is x double-reg) (location= x r) (location= y r))
(inst fldd (ea-for-df-desc y)))))
;; ST(i) = ST(i) op ST0
(inst ,fop-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; y and r are the same register.
((and (sc-is y double-reg) (location= y r))
(cond ((zerop (tn-offset r))
(inst fldd (ea-for-df-desc x)))))
;; ST(i) = ST(0) op ST(i)
(inst ,fopr-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
- ;; The default case
+ (maybe-fp-wait node vop))
+ ;; the default case
(t
;; Get the result to ST0.
(note-next-instruction vop :internal-error)
- ;; Finally save the result
+ ;; Finally save the result.
(sc-case r
(double-reg
(cond ((zerop (tn-offset r))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst r))))
(double-stack
(:save-p :compute-only)
(:node-var node)
(:generator ,lcost
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; x, y, and r are the same register.
((and (location= x r) (location= y r))
(copy-fp-reg-to-fr0 y))
;; ST(i) = ST(i) op ST0
(inst ,fop-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; y and r are the same register.
((location= y r)
(cond ((zerop (tn-offset r))
(copy-fp-reg-to-fr0 x))
;; ST(i) = ST(0) op ST(i)
(inst ,fopr-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; the default case
(t
;; Get the result to ST0.
;; Finally save the result.
(cond ((zerop (tn-offset r))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst r))))))))))
(unless (zerop (tn-offset x))
(inst fxch x) ; x to top of stack
(unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,inst) ; clobber st0
+ (inst fst x))) ; Maybe save it.
+ (inst ,inst) ; Clobber st0.
(unless (zerop (tn-offset y))
(inst fst y))))))
(y :scs (long-reg)))
(:arg-types long-float long-float))
-
(define-vop (<single-float)
(:translate <)
(:args (x :scs (single-reg single-stack descriptor-reg))
(:note "inline float comparison")
(:ignore temp)
(:generator 3
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; y is ST0.
((and (sc-is y single-reg) (zerop (tn-offset y)))
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45))
- ;; General case when y is not in ST0.
+ ;; general case when y is not in ST0
(t
;; x to ST0
(sc-case x
(:note "inline float comparison")
(:ignore temp)
(:generator 3
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; y is ST0.
((and (sc-is y single-reg) (zerop (tn-offset y)))
(inst and ah-tn #x45)
(inst cmp ah-tn #x01))
- ;; General case when y is not in ST0.
+ ;; general case when y is not in ST0
(t
;; x to ST0
(sc-case x
(:note "inline float comparison")
(:ignore temp)
(:generator 3
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; y is ST0.
((and (sc-is y double-reg) (zerop (tn-offset y)))
(inst and ah-tn #x45)
(inst cmp ah-tn #x01))
- ;; General case when y is not in ST0.
+ ;; general case when y is not in ST0
(t
;; x to ST0
(sc-case x
#!+long-float
(frob %long-float/unsigned %long-float long-reg long-float))
-;;; These should be no-ops but the compiler might want to move
-;;; some things around
+;;; These should be no-ops but the compiler might want to move some
+;;; things around.
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
`(define-vop (,name)
(:args (x :scs (,from-sc) :target y))
;; Catch any pending FPE exceptions.
(inst wait)))
(,(if round-p 'progn 'pseudo-atomic)
- ;; normal mode (for now) is "round to best"
+ ;; Normal mode (for now) is "round to best".
(with-tn@fp-top (x)
,@(unless round-p
- '((inst fnstcw scw) ; save current control word
+ '((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)
'((note-this-location vop :internal-error)
;; Catch any pending FPE exceptions.
(inst wait)))
- ;; normal mode (for now) is "round to best"
+ ;; Normal mode (for now) is "round to best".
(unless (zerop (tn-offset x))
(copy-fp-reg-to-fr0 x))
,@(unless round-p
(signed-reg
(inst mov res bits))
(signed-stack
- (assert (location= bits res)))))
+ (aver (location= bits res)))))
(single-reg
(sc-case bits
(signed-reg
(:temporary (:sc unsigned-reg :offset eax-offset :target res
:to :result) eax)
(:generator 8
- (inst sub esp-tn npx-env-size) ; make space on stack
- (inst wait) ; Catch any pending FPE exceptions
+ (inst sub esp-tn npx-env-size) ; Make space on stack.
+ (inst wait) ; Catch any pending FPE exceptions
(inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
- (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
- ;; Current status to high word
+ (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
+ ;; Move current status to high word.
(inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
- ;; Exception mask to low word
+ ;; Move exception mask to low word.
(inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
- (inst add esp-tn npx-env-size) ; Pop stack
- (inst xor eax #x3f) ; Flip exception mask to trap enable bits
+ (inst add esp-tn npx-env-size) ; Pop stack.
+ (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
(move res eax)))
(define-vop (set-floating-point-modes)
(:temporary (:sc unsigned-reg :offset eax-offset
:from :eval :to :result) eax)
(:generator 3
- (inst sub esp-tn npx-env-size) ; make space on stack
- (inst wait) ; Catch any pending FPE exceptions
+ (inst sub esp-tn npx-env-size) ; Make space on stack.
+ (inst wait) ; Catch any pending FPE exceptions.
(inst fstenv (make-ea :dword :base esp-tn))
(inst mov eax new)
- (inst xor eax #x3f) ; turn trap enable bits into exception mask
+ (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
(inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
(inst shr eax 16) ; position status word
(inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
(inst fldenv (make-ea :dword :base esp-tn))
- (inst add esp-tn npx-env-size) ; Pop stack
+ (inst add esp-tn npx-env-size) ; Pop stack.
(move res new)))
\f
#!-long-float
(inst fst x))) ; maybe save it
(inst ,op) ; clobber st0
(cond ((zerop (tn-offset y))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst y)))))))
(case (tn-offset r)
((0 1))
(t (inst fstd r)))))
-
-) ; progn #!-long-float
-
+) ; PROGN #!-LONG-FLOAT
\f
-
#!+long-float
(progn
(inst fst x))) ; maybe save it
(inst ,op) ; clobber st0
(cond ((zerop (tn-offset y))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst y)))))))
- ;; Quick versions of fsin and fcos that require the argument to be
+ ;; Quick versions of FSIN and FCOS that require the argument to be
;; within range 2^63.
(frob fsin-quick %sin-quick fsin)
(frob fcos-quick %cos-quick fcos)
((0 1))
(t (inst fstd r)))))
-) ; progn #!+long-float
-
+) ; PROGN #!+LONG-FLOAT
\f
-;;;; Complex float VOPs
+;;;; complex float VOPs
(define-vop (make-complex-single-float)
(:translate complex)
(1 (ea-for-clf-imag-desc x)))))))
(with-empty-tn@fp-top(r)
(inst fldl ea))))
- (t (error "Complex-float-value VOP failure")))))
+ (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
(define-vop (realpart/complex-single-float complex-float-value)
(:translate realpart)
(:result-types long-float)
(:note "complex float imagpart")
(:variant 1))
-
\f
-;;; A hack dummy VOP to bias the representation selection of its
-;;; argument towards a FP register which can help avoid consing at
-;;; inappropriate locations.
-
+;;; hack dummy VOPs to bias the representation selection of their
+;;; arguments towards a FP register, which can help avoid consing at
+;;; inappropriate locations
(defknown double-float-reg-bias (double-float) (values))
(define-vop (double-float-reg-bias)
(:translate double-float-reg-bias)
(:note "inline dummy FP register bias")
(:ignore x)
(:generator 0))
-
(defknown single-float-reg-bias (single-float) (values))
(define-vop (single-float-reg-bias)
(:translate single-float-reg-bias)