;;;; files for more information.
(in-package "SB!VM")
-
-(file-comment
- "$Header$")
\f
(macrolet ((ea-for-xf-desc (tn slot)
`(make-ea
:dword :base ,tn
- :disp (- (* ,slot sb!vm:word-bytes) sb!vm:other-pointer-type))))
+ :disp (- (* ,slot n-word-bytes)
+ other-pointer-lowtag))))
(defun ea-for-sf-desc (tn)
- (ea-for-xf-desc tn sb!vm:single-float-value-slot))
+ (ea-for-xf-desc tn single-float-value-slot))
(defun ea-for-df-desc (tn)
- (ea-for-xf-desc tn sb!vm:double-float-value-slot))
+ (ea-for-xf-desc tn double-float-value-slot))
#!+long-float
(defun ea-for-lf-desc (tn)
- (ea-for-xf-desc tn sb!vm:long-float-value-slot))
+ (ea-for-xf-desc tn long-float-value-slot))
;; complex floats
(defun ea-for-csf-real-desc (tn)
- (ea-for-xf-desc tn sb!vm:complex-single-float-real-slot))
+ (ea-for-xf-desc tn complex-single-float-real-slot))
(defun ea-for-csf-imag-desc (tn)
- (ea-for-xf-desc tn sb!vm:complex-single-float-imag-slot))
+ (ea-for-xf-desc tn complex-single-float-imag-slot))
(defun ea-for-cdf-real-desc (tn)
- (ea-for-xf-desc tn sb!vm:complex-double-float-real-slot))
+ (ea-for-xf-desc tn complex-double-float-real-slot))
(defun ea-for-cdf-imag-desc (tn)
- (ea-for-xf-desc tn sb!vm:complex-double-float-imag-slot))
+ (ea-for-xf-desc tn complex-double-float-imag-slot))
#!+long-float
(defun ea-for-clf-real-desc (tn)
- (ea-for-xf-desc tn sb!vm:complex-long-float-real-slot))
+ (ea-for-xf-desc tn complex-long-float-real-slot))
#!+long-float
(defun ea-for-clf-imag-desc (tn)
- (ea-for-xf-desc tn sb!vm:complex-long-float-imag-slot)))
+ (ea-for-xf-desc tn complex-long-float-imag-slot)))
(macrolet ((ea-for-xf-stack (tn kind)
`(make-ea
:dword :base ebp-tn
:disp (- (* (+ (tn-offset ,tn)
(ecase ,kind (:single 1) (:double 2) (:long 3)))
- sb!vm:word-bytes)))))
+ n-word-bytes)))))
(defun ea-for-sf-stack (tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
(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
(:double 2)
(:long 3))
(ecase ,slot (:real 1) (:imag 2))))
- sb!vm:word-bytes)))))
+ n-word-bytes)))))
(defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
(ea-for-cxf-stack tn :single :real base))
(defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
;;;
;;; 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))
\f
;;;; move functions
-;;; x is source, y is destination
-(define-move-function (load-single 2) (vop x y)
+;;; X is source, Y is destination.
+(define-move-fun (load-single 2) (vop x y)
((single-stack) (single-reg))
(with-empty-tn@fp-top(y)
(inst fld (ea-for-sf-stack x))))
-(define-move-function (store-single 2) (vop x y)
+(define-move-fun (store-single 2) (vop x y)
((single-reg) (single-stack))
(cond ((zerop (tn-offset x))
(inst fst (ea-for-sf-stack y)))
;; This may not be necessary as ST0 is likely invalid now.
(inst fxch x))))
-(define-move-function (load-double 2) (vop x y)
+(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(with-empty-tn@fp-top(y)
(inst fldd (ea-for-df-stack x))))
-(define-move-function (store-double 2) (vop x y)
+(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(cond ((zerop (tn-offset x))
(inst fstd (ea-for-df-stack y)))
(inst fxch x))))
#!+long-float
-(define-move-function (load-long 2) (vop x y)
+(define-move-fun (load-long 2) (vop x y)
((long-stack) (long-reg))
(with-empty-tn@fp-top(y)
(inst fldl (ea-for-lf-stack x))))
#!+long-float
-(define-move-function (store-long 2) (vop x y)
+(define-move-fun (store-long 2) (vop x y)
((long-reg) (long-stack))
(cond ((zerop (tn-offset x))
(store-long-float (ea-for-lf-stack y)))
;; 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.
-(define-move-function (load-fp-constant 2) (vop x y)
+;;; 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-fun (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))))
(with-empty-tn@fp-top(y)
(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
-(define-move-function (load-complex-single 2) (vop x y)
+;;; X is source, Y is destination.
+(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((real-tn (complex-single-reg-real-tn y)))
(with-empty-tn@fp-top (real-tn)
(with-empty-tn@fp-top (imag-tn)
(inst fld (ea-for-csf-imag-stack x)))))
-(define-move-function (store-complex-single 2) (vop x y)
+(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((real-tn (complex-single-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
(inst fst (ea-for-csf-imag-stack y))
(inst fxch imag-tn)))
-(define-move-function (load-complex-double 2) (vop x y)
+(define-move-fun (load-complex-double 2) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((real-tn (complex-double-reg-real-tn y)))
(with-empty-tn@fp-top(real-tn)
(with-empty-tn@fp-top(imag-tn)
(inst fldd (ea-for-cdf-imag-stack x)))))
-(define-move-function (store-complex-double 2) (vop x y)
+(define-move-fun (store-complex-double 2) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((real-tn (complex-double-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
(inst fxch imag-tn)))
#!+long-float
-(define-move-function (load-complex-long 2) (vop x y)
+(define-move-fun (load-complex-long 2) (vop x y)
((complex-long-stack) (complex-long-reg))
(let ((real-tn (complex-long-reg-real-tn y)))
(with-empty-tn@fp-top(real-tn)
(inst fldl (ea-for-clf-imag-stack x)))))
#!+long-float
-(define-move-function (store-complex-long 2) (vop x y)
+(define-move-fun (store-complex-long 2) (vop x y)
((complex-long-reg) (complex-long-stack))
(let ((real-tn (complex-long-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
\f
;;;; move VOPs
-;;; Float register to register moves.
+;;; float register to register moves
(define-vop (float-move)
(:args (x))
(:results (y))
(:note "float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- sb!vm:single-float-type
- sb!vm:single-float-size node)
+ single-float-widetag
+ single-float-size node)
(with-tn@fp-top(x)
(inst fst (ea-for-sf-desc y))))))
(define-move-vop move-from-single :move
(:note "float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- sb!vm:double-float-type
- sb!vm:double-float-size
+ double-float-widetag
+ double-float-size
node)
(with-tn@fp-top(x)
(inst fstd (ea-for-df-desc y))))))
(:note "float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- sb!vm:long-float-type
- sb!vm:long-float-size
+ long-float-widetag
+ long-float-size
node)
(with-tn@fp-top(x)
(store-long-float (ea-for-lf-desc 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.
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- sb!vm:complex-single-float-type
- sb!vm:complex-single-float-size node)
+ complex-single-float-widetag
+ complex-single-float-size
+ node)
(let ((real-tn (complex-single-reg-real-tn x)))
(with-tn@fp-top(real-tn)
(inst fst (ea-for-csf-real-desc y))))
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- sb!vm:complex-double-float-type
- sb!vm:complex-double-float-size
+ complex-double-float-widetag
+ complex-double-float-size
node)
(let ((real-tn (complex-double-reg-real-tn x)))
(with-tn@fp-top(real-tn)
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- sb!vm:complex-long-float-type
- sb!vm:complex-long-float-size
+ complex-long-float-widetag
+ complex-long-float-size
node)
(let ((real-tn (complex-long-reg-real-tn x)))
(with-tn@fp-top(real-tn)
(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)
(inst fxch x)))))
(,stack-sc
(if (= (tn-offset fp) esp-offset)
- (let* ((offset (* (tn-offset y) word-bytes))
+ (let* ((offset (* (tn-offset y) n-word-bytes))
(ea (make-ea :dword :base fp :disp offset)))
(with-tn@fp-top(x)
,@(ecase format
(:single 1)
(:double 2)
(:long 3)))
- sb!vm:word-bytes)))))
+ n-word-bytes)))))
(with-tn@fp-top(x)
,@(ecase format
(:single '((inst fst ea)))
#!+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
(storew lo-bits ebp-tn (- (1+ offset)))
(with-empty-tn@fp-top(res)
(inst fldd (make-ea :dword :base ebp-tn
- :disp (- (* (1+ offset) word-bytes))))))))
+ :disp (- (* (1+ offset) n-word-bytes))))))))
#!+long-float
(define-vop (make-long-float)
(storew lo-bits ebp-tn (- (+ offset 2)))
(with-empty-tn@fp-top(res)
(inst fldl (make-ea :dword :base ebp-tn
- :disp (- (* (+ offset 2) word-bytes))))))))
+ :disp (- (* (+ offset 2) n-word-bytes))))))))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
(inst mov bits float))
(descriptor-reg
(loadw
- bits float sb!vm:single-float-value-slot
- sb!vm:other-pointer-type))))
+ bits float single-float-value-slot
+ other-pointer-lowtag))))
(signed-stack
(sc-case float
(single-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
:disp (- (* (+ 2 (tn-offset temp))
- word-bytes)))))
+ n-word-bytes)))))
(inst fstd where)))
(loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
(double-stack
(loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
(descriptor-reg
- (loadw hi-bits float (1+ sb!vm:double-float-value-slot)
- sb!vm:other-pointer-type)))))
+ (loadw hi-bits float (1+ double-float-value-slot)
+ other-pointer-lowtag)))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
:disp (- (* (+ 2 (tn-offset temp))
- word-bytes)))))
+ n-word-bytes)))))
(inst fstd where)))
(loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
(double-stack
(loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
(descriptor-reg
- (loadw lo-bits float sb!vm:double-float-value-slot
- sb!vm:other-pointer-type)))))
+ (loadw lo-bits float double-float-value-slot
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-exp-bits)
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
:disp (- (* (+ 3 (tn-offset temp))
- word-bytes)))))
+ n-word-bytes)))))
(store-long-float where)))
(inst movsx exp-bits
(make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset temp))) word-bytes))))
+ :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
(long-stack
(inst movsx exp-bits
(make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset float))) word-bytes))))
+ :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
(descriptor-reg
(inst movsx exp-bits
(make-ea :word :base float
- :disp (- (* (+ 2 sb!vm:long-float-value-slot)
- word-bytes)
- sb!vm:other-pointer-type)))))))
+ :disp (- (* (+ 2 long-float-value-slot)
+ n-word-bytes)
+ other-pointer-lowtag)))))))
#!+long-float
(define-vop (long-float-high-bits)
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
:disp (- (* (+ 3 (tn-offset temp))
- word-bytes)))))
+ n-word-bytes)))))
(store-long-float where)))
(loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
(long-stack
(loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
(descriptor-reg
- (loadw hi-bits float (1+ sb!vm:long-float-value-slot)
- sb!vm:other-pointer-type)))))
+ (loadw hi-bits float (1+ long-float-value-slot)
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-low-bits)
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
:disp (- (* (+ 3 (tn-offset temp))
- word-bytes)))))
+ n-word-bytes)))))
(store-long-float where)))
(loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
(long-stack
(loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
(descriptor-reg
- (loadw lo-bits float sb!vm:long-float-value-slot
- sb!vm:other-pointer-type)))))
+ (loadw lo-bits float long-float-value-slot
+ other-pointer-lowtag)))))
\f
;;;; float mode hackery
(defknown ((setf floating-point-modes)) (float-modes)
float-modes)
-(defconstant npx-env-size (* 7 sb!vm:word-bytes))
+(defconstant npx-env-size (* 7 n-word-bytes))
(defconstant npx-cw-offset 0)
(defconstant npx-sw-offset 4)
(: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)))))))
(:arg-types double-float)
(:result-types double-float)
(:policy :fast-safe)
- ;; FIXME: PENTIUM isn't used on the *FEATURES* list of the CMU CL I based
- ;; SBCL on, even when it is running on a Pentium. Find out what's going
- ;; on here and see what the proper value should be. (Perhaps just use the
- ;; apparently-conservative value of T always?) For more confusion, see also
- ;; apparently-reversed-sense test for the FLOG1P-PENTIUM vop below.
- (:guard #!+pentium nil #!-pentium t)
(:note "inline log1p function")
(:ignore temp)
(:generator 5
(:arg-types double-float)
(:result-types double-float)
(:policy :fast-safe)
- ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
- (:guard #!+pentium t #!-pentium nil)
+ (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
(:note "inline log1p with limited x range function")
(:vop-var vop)
(:save-p :compute-only)
- (:generator 5
+ (:generator 4
(note-this-location vop :internal-error)
(sc-case x
(double-reg
(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)
projects / sbcl.git / blobdiff