(in-package "SB!VM")
\f
(macrolet ((ea-for-xf-desc (tn slot)
- `(make-ea
- :dword :base ,tn
- :disp (- (* ,slot n-word-bytes)
- other-pointer-lowtag))))
+ `(make-ea-for-object-slot ,tn ,slot other-pointer-lowtag)))
(defun ea-for-sf-desc (tn)
(ea-for-xf-desc tn single-float-value-slot))
(defun ea-for-df-desc (tn)
(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)))
- n-word-bytes)))))
+ :disp (frame-byte-offset
+ (+ (tn-offset ,tn)
+ (ecase ,kind (:single 0) (:double 1) (:long 2)))))))
(defun ea-for-sf-stack (tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
`(make-ea
:dword :base ,base
- :disp (- (* (+ (tn-offset ,tn)
- (* (ecase ,kind
- (:single 1)
- (:double 2)
- (:long 3))
- (ecase ,slot (:real 1) (:imag 2))))
- n-word-bytes)))))
+ :disp (frame-byte-offset
+ (+ (tn-offset ,tn)
+ -1
+ (* (ecase ,kind
+ (:single 1)
+ (:double 2)
+ (:long 3))
+ (ecase ,slot (:real 1) (:imag 2))))))))
(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))
#!+long-float 'long-float #!-long-float 'double-float))
(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))))
+ (let ((value (tn-value x)))
(with-empty-tn@fp-top(y)
- (cond ((zerop value)
+ (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0))
(inst fldz))
((= value 1e0)
(inst fld1))
+ #!+long-float
((= value (coerce pi *read-default-float-format*))
(inst fldpi))
+ #!+long-float
((= value (log 10e0 2e0))
(inst fldl2t))
+ #!+long-float
((= value (log 2.718281828459045235360287471352662e0 2e0))
(inst fldl2e))
+ #!+long-float
((= value (log 2e0 10e0))
(inst fldlg2))
+ #!+long-float
((= value (log 2e0 2.718281828459045235360287471352662e0))
(inst fldln2))
(t (warn "ignoring bogus i387 constant ~A" value))))))
+
+(define-move-fun (load-fp-immediate 2) (vop x y)
+ ((fp-single-immediate) (single-reg)
+ (fp-double-immediate) (double-reg))
+ (let ((value (register-inline-constant (tn-value x))))
+ (with-empty-tn@fp-top(y)
+ (sc-case y
+ (single-reg
+ (inst fld value))
+ (double-reg
+ (inst fldd value))))))
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format* 'single-float))
\f
(:node-var node)
(:note "complex float to pointer coercion")
(:generator 13
- (with-fixed-allocation (y
- 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))))
- (let ((imag-tn (complex-single-reg-imag-tn x)))
- (with-tn@fp-top(imag-tn)
- (inst fst (ea-for-csf-imag-desc y)))))))
+ (with-fixed-allocation (y
+ 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))))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (with-tn@fp-top(imag-tn)
+ (inst fst (ea-for-csf-imag-desc y)))))))
(define-move-vop move-from-complex-single :move
(complex-single-reg) (descriptor-reg))
(inst fxch x)))))
(,stack-sc
(if (= (tn-offset fp) esp-offset)
+ ;; C-call
(let* ((offset (* (tn-offset y) n-word-bytes))
(ea (make-ea :dword :base fp :disp offset)))
(with-tn@fp-top(x)
(:double '((inst fstd ea)))
#!+long-float
(:long '((store-long-float ea))))))
+ ;; Lisp stack
(let ((ea (make-ea
:dword :base fp
- :disp (- (* (+ (tn-offset y)
- ,(case format
- (:single 1)
- (:double 2)
- (:long 3)))
- n-word-bytes)))))
+ :disp (frame-byte-offset
+ (+ (tn-offset y)
+ ,(case format
+ (:single 0)
+ (:double 1)
+ (:long 2)))))))
(with-tn@fp-top(x)
,@(ecase format
(:single '((inst fst ea)))
(define-vop (=/float)
(:args (x) (y))
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p)
+ (:conditional :e)
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
(inst fxch x)))
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0
- (inst cmp ah-tn #x40)
- (inst jmp (if not-p :ne :e) target)))
+ (inst cmp ah-tn #x40)))
(define-vop (=/single-float =/float)
(:translate =)
(:arg-types single-float single-float)
(:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p)
+ (:conditional :e)
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
(inst fcom (ea-for-sf-desc y)))))
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0
- (inst cmp ah-tn #x01)))
- (inst jmp (if not-p :ne :e) target)))
+ (inst cmp ah-tn #x01)))))
(define-vop (<double-float)
(:translate <)
(:arg-types double-float double-float)
(:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p)
+ (:conditional :e)
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
(inst fcomd (ea-for-df-desc y)))))
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0
- (inst cmp ah-tn #x01)))
- (inst jmp (if not-p :ne :e) target)))
+ (inst cmp ah-tn #x01)))))
#!+long-float
(define-vop (<long-float)
(y :scs (long-reg)))
(:arg-types long-float long-float)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p)
+ (:conditional :e)
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
(inst fcomd x)
(inst fxch y)
(inst fnstsw) ; status word to ax
- (inst and ah-tn #x45))) ; C3 C2 C0
- (inst jmp (if not-p :ne :e) target)))
+ (inst and ah-tn #x45))))) ; C3 C2 C0
+
(define-vop (>single-float)
(:translate >)
(:arg-types single-float single-float)
(:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p)
+ (:conditional :e)
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
(inst fcom (ea-for-sf-stack y))
(inst fcom (ea-for-sf-desc y)))))
(inst fnstsw) ; status word to ax
- (inst and ah-tn #x45)))
- (inst jmp (if not-p :ne :e) target)))
+ (inst and ah-tn #x45)))))
(define-vop (>double-float)
(:translate >)
(:arg-types double-float double-float)
(:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p)
+ (:conditional :e)
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
(inst fcomd (ea-for-df-stack y))
(inst fcomd (ea-for-df-desc y)))))
(inst fnstsw) ; status word to ax
- (inst and ah-tn #x45)))
- (inst jmp (if not-p :ne :e) target)))
+ (inst and ah-tn #x45)))))
#!+long-float
(define-vop (>long-float)
(y :scs (long-reg)))
(:arg-types long-float long-float)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p)
+ (:conditional :e)
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
(inst fcomd y)
(inst fxch x)
(inst fnstsw) ; status word to ax
- (inst and ah-tn #x45)))
- (inst jmp (if not-p :ne :e) target)))
+ (inst and ah-tn #x45)))))
;;; Comparisons with 0 can use the FTST instruction.
(define-vop (float-test)
(:args (x))
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p y)
+ (:conditional :e)
+ (:info y)
(:variant-vars code)
(:policy :fast-safe)
(:vop-var vop)
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0
(unless (zerop code)
- (inst cmp ah-tn code))
- (inst jmp (if not-p :ne :e) target)))
+ (inst cmp ah-tn code))))
(define-vop (=0/single-float float-test)
(:translate =)
(inst mov y stack-temp)))
,@(unless round-p
'((inst fldcw scw)))))))))
- (frob %unary-truncate single-reg single-float nil)
- (frob %unary-truncate double-reg double-float nil)
+ (frob %unary-truncate/single-float single-reg single-float nil)
+ (frob %unary-truncate/double-float double-reg double-float nil)
#!+long-float
- (frob %unary-truncate long-reg long-float nil)
+ (frob %unary-truncate/long-float long-reg long-float nil)
(frob %unary-round single-reg single-float t)
(frob %unary-round double-reg double-float t)
#!+long-float
(inst add esp-tn 4)
,@(unless round-p
'((inst fldcw scw)))))))
- (frob %unary-truncate single-reg single-float nil)
- (frob %unary-truncate double-reg double-float nil)
+ (frob %unary-truncate/single-float single-reg single-float nil)
+ (frob %unary-truncate/double-float double-reg double-float nil)
#!+long-float
- (frob %unary-truncate long-reg long-float nil)
+ (frob %unary-truncate/long-float long-reg long-float nil)
(frob %unary-round single-reg single-float t)
(frob %unary-round double-reg double-float t)
#!+long-float
(:policy :fast-safe)
(:vop-var vop)
(:generator 2
- (let ((offset (1+ (tn-offset temp))))
- (storew hi-bits ebp-tn (- offset))
- (storew lo-bits ebp-tn (- (1+ offset)))
+ (let ((offset (tn-offset temp)))
+ (storew hi-bits ebp-tn (frame-word-offset offset))
+ (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
(with-empty-tn@fp-top(res)
(inst fldd (make-ea :dword :base ebp-tn
- :disp (- (* (1+ offset) n-word-bytes))))))))
+ :disp (frame-byte-offset (1+ offset))))))))
#!+long-float
(define-vop (make-long-float)
(:policy :fast-safe)
(:vop-var vop)
(:generator 3
- (let ((offset (1+ (tn-offset temp))))
- (storew exp-bits ebp-tn (- offset))
- (storew hi-bits ebp-tn (- (1+ offset)))
- (storew lo-bits ebp-tn (- (+ offset 2)))
+ (let ((offset (tn-offset temp)))
+ (storew exp-bits ebp-tn (frame-word-offset offset))
+ (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
+ (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
(with-empty-tn@fp-top(res)
(inst fldl (make-ea :dword :base ebp-tn
- :disp (- (* (+ offset 2) n-word-bytes))))))))
+ :disp (frame-byte-offset (+ offset 2))))))))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
(double-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 2 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (1+ (tn-offset temp))))))
(inst fstd where)))
- (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
+ (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
(double-stack
- (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
+ (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
(descriptor-reg
(loadw hi-bits float (1+ double-float-value-slot)
other-pointer-lowtag)))))
(double-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 2 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (1+ (tn-offset temp))))))
(inst fstd where)))
- (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
+ (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
(double-stack
- (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
+ (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
(descriptor-reg
(loadw lo-bits float double-float-value-slot
other-pointer-lowtag)))))
(long-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
(store-long-float where)))
(inst movsx exp-bits
(make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
+ :disp (frame-byte-offset (tn-offset temp)))))
(long-stack
(inst movsx exp-bits
(make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
+ :disp (frame-byte-offset (tn-offset temp)))))
(descriptor-reg
(inst movsx exp-bits
- (make-ea :word :base float
- :disp (- (* (+ 2 long-float-value-slot)
- n-word-bytes)
- other-pointer-lowtag)))))))
+ (make-ea-for-object-slot float (+ 2 long-float-value-slot)
+ other-pointer-lowtag :word))))))
#!+long-float
(define-vop (long-float-high-bits)
(long-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
(store-long-float where)))
- (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
+ (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
(long-stack
- (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
+ (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
(descriptor-reg
(loadw hi-bits float (1+ long-float-value-slot)
other-pointer-lowtag)))))
(long-reg
(with-tn@fp-top(float)
(let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
+ :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
(store-long-float where)))
- (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
+ (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
(long-stack
- (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
+ (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
(descriptor-reg
(loadw lo-bits float long-float-value-slot
other-pointer-lowtag)))))
projects / sbcl.git / blobdiff