#!+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
(with-fixed-allocation (y
single-float-widetag
single-float-size node)
- (with-tn@fp-top(x)
- (inst fst (ea-for-sf-desc y))))))
+ ;; w-f-a checks for empty body
+ nil)
+ (with-tn@fp-top(x)
+ (inst fst (ea-for-sf-desc y)))))
(define-move-vop move-from-single :move
(single-reg) (descriptor-reg))
double-float-widetag
double-float-size
node)
- (with-tn@fp-top(x)
- (inst fstd (ea-for-df-desc y))))))
+ nil)
+ (with-tn@fp-top(x)
+ (inst fstd (ea-for-df-desc y)))))
(define-move-vop move-from-double :move
(double-reg) (descriptor-reg))
long-float-widetag
long-float-size
node)
- (with-tn@fp-top(x)
- (store-long-float (ea-for-lf-desc y))))))
+ nil)
+ (with-tn@fp-top(x)
+ (store-long-float (ea-for-lf-desc y)))))
#!+long-float
(define-move-vop move-from-long :move
(long-reg) (descriptor-reg))
(: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))
#!+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.
-(macrolet ((frob (name translate from-sc from-type to-sc to-type)
+(macrolet ((frob (name translate from-sc from-type to-sc to-type
+ &optional to-stack-sc store-inst load-inst)
`(define-vop (,name)
(:args (x :scs (,from-sc) :target y))
+ ,@(and to-stack-sc
+ `((:temporary (:sc ,to-stack-sc) temp)))
(:results (y :scs (,to-sc)))
(:arg-types ,from-type)
(:result-types ,to-type)
(:vop-var vop)
(:save-p :compute-only)
(:generator 2
- (note-this-location vop :internal-error)
- (unless (location= x y)
- (cond
- ((zerop (tn-offset x))
- ;; x is in ST0, y is in another reg. not ST0
- (inst fst y))
- ((zerop (tn-offset y))
- ;; y is in ST0, x is in another reg. not ST0
- (copy-fp-reg-to-fr0 x))
- (t
- ;; Neither x or y are in ST0, and they are not in
- ;; the same reg.
- (inst fxch x)
- (inst fst y)
- (inst fxch x))))))))
-
- (frob %single-float/double-float %single-float double-reg
- double-float single-reg single-float)
+ (note-this-location vop :internal-error)
+ ,(if to-stack-sc
+ `(progn
+ (with-tn@fp-top (x)
+ (inst ,store-inst temp))
+ (with-empty-tn@fp-top (y)
+ (inst ,load-inst temp)))
+ `(unless (location= x y)
+ (cond
+ ((zerop (tn-offset x))
+ ;; x is in ST0, y is in another reg. not ST0
+ (inst fst y))
+ ((zerop (tn-offset y))
+ ;; y is in ST0, x is in another reg. not ST0
+ (copy-fp-reg-to-fr0 x))
+ (t
+ ;; Neither x or y are in ST0, and they are not in
+ ;; the same reg.
+ (inst fxch x)
+ (inst fst y)
+ (inst fxch x)))))))))
+
+ (frob %single-float/double-float %single-float double-reg double-float
+ single-reg single-float
+ single-stack fst fld)
#!+long-float
(frob %single-float/long-float %single-float long-reg
- long-float single-reg single-float)
+ long-float single-reg single-float
+ single-stack fst fld)
(frob %double-float/single-float %double-float single-reg single-float
double-reg double-float)
#!+long-float
(frob %double-float/long-float %double-float long-reg long-float
- double-reg double-float)
+ double-reg double-float
+ double-stack fstd fldd)
#!+long-float
(frob %long-float/single-float %long-float single-reg single-float
long-reg long-float)
(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
(with-empty-tn@fp-top(res)
(inst fld bits))))))))
+(define-vop (make-single-float-c)
+ (:results (res :scs (single-reg single-stack)))
+ (:arg-types (:constant (signed-byte 32)))
+ (:result-types single-float)
+ (:info bits)
+ (:translate make-single-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 2
+ (sc-case res
+ (single-stack
+ (inst mov res bits))
+ (single-reg
+ (with-empty-tn@fp-top (res)
+ (inst fld (register-inline-constant :dword bits)))))))
+
(define-vop (make-double-float)
(:args (hi-bits :scs (signed-reg))
(lo-bits :scs (unsigned-reg)))
(inst fldd (make-ea :dword :base ebp-tn
:disp (frame-byte-offset (1+ offset))))))))
+(define-vop (make-double-float-c)
+ (:results (res :scs (double-reg)))
+ (:arg-types (:constant (signed-byte 32)) (:constant (unsigned-byte 32)))
+ (:result-types double-float)
+ (:info hi lo)
+ (:translate make-double-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 1
+ (with-empty-tn@fp-top(res)
+ (inst fldd (register-inline-constant
+ :double-float-bits (logior (ash hi 32) lo))))))
+
#!+long-float
(define-vop (make-long-float)
(:args (exp-bits :scs (signed-reg))
(:args (x :scs (double-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
:from :argument :to :result) fr0)
+ ;; FIXME: make that an arbitrary location and
+ ;; FXCH only when range reduction needed
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
(:temporary (:sc unsigned-reg :offset eax-offset
:from :argument :to :result) eax)
(:results (y :scs (double-reg)))
(:save-p :compute-only)
(:ignore eax)
(:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :z DONE)
- ;; Else x was out of range so reduce it; ST0 is unchanged.
- (inst fstp fr0) ; Load 0.0
- (inst fldz)
- DONE
- (unless (zerop (tn-offset y))
- (inst fstd y))))))
+ (let ((DONE (gen-label))
+ (REDUCE (gen-label))
+ (REDUCE-LOOP (gen-label)))
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :nz REDUCE)
+ (emit-label DONE)
+ (unless (zerop (tn-offset y))
+ (inst fstd y))
+ (assemble (*elsewhere*)
+ (emit-label REDUCE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (with-empty-tn@fp-top (fr1)
+ (inst fldpi)
+ (inst fadd fr0))
+ (emit-label REDUCE-LOOP)
+ (inst fprem1)
+ (inst fnstsw)
+ (inst and ah-tn #x04)
+ (inst jmp :nz REDUCE-LOOP)
+ (inst ,op)
+ (inst jmp DONE)))))))
(frob fsin %sin fsin)
(frob fcos %cos fcos))
:sc (sc-or-lose 'double-reg)
:offset (- (tn-offset x) 2)))))
(inst fptan)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :z DONE)
- ;; Else x was out of range so load 0.0
- (inst fxch fr1)
+ (let ((REDUCE (gen-label))
+ (REDUCE-LOOP (gen-label)))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :nz REDUCE)
+ (assemble (*elsewhere*)
+ (emit-label REDUCE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (with-empty-tn@fp-top (fr1)
+ (inst fldpi)
+ (inst fadd fr0))
+ (emit-label REDUCE-LOOP)
+ (inst fprem1)
+ (inst fnstsw)
+ (inst and ah-tn #x04)
+ (inst jmp :nz REDUCE-LOOP)
+ (inst fptan)
+ (inst jmp DONE)))
DONE
;; Result is in fr1
(case (tn-offset y)
projects / sbcl.git / blobdiff