X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=bde111ae43f86bd92b6a31e59d3f729323b5c26e;hb=2230ea0c1765a95fd2aa0a8996b3555b93ba3745;hp=f935c1ff619970fce8bbeaacd19a84385fe4d700;hpb=816248ab4fe04775879a7e5a5ce1b4c613afe9d5;p=sbcl.git diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index f935c1f..bde111a 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -12,10 +12,7 @@ (in-package "SB!VM") (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) @@ -40,11 +37,11 @@ (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))) - n-word-bytes))))) + `(make-ea + :dword :base ebp-tn + :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) @@ -62,23 +59,31 @@ ;;; ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to ;;; #'NOTE-NEXT-INSTRUCTION. +;;; +;;; Until 2004-03-15, the implementation of this was buggy; it +;;; unconditionally emitted the WAIT instruction. It turns out that +;;; this is the right thing to do anyway; omitting them can lead to +;;; system corruption on conforming code. -- CSR (defun maybe-fp-wait (node &optional note-next-instruction) + (declare (ignore node)) + #+nil (when (policy node (or (= debug 3) (> safety speed)))) - (when note-next-instruction - (note-next-instruction note-next-instruction :internal-error)) - (inst wait)) + (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 - :disp (- (* (+ (tn-offset ,tn) - (* (ecase ,kind - (:single 1) - (:double 2) - (:long 3)) - (ecase ,slot (:real 1) (:imag 2)))) - n-word-bytes))))) + `(make-ea + :dword :base ,base + :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)) @@ -104,8 +109,8 @@ (aver (not (zerop (tn-offset reg)))) (inst fstp fr0-tn) (inst fld (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset reg))))) + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset reg))))) ;;; Using Fxch then Fst to restore the original reg contents. #+nil (defun copy-fp-reg-to-fr0 (reg) @@ -132,12 +137,12 @@ (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))) - (t - (inst fxch x) - (inst fst (ea-for-sf-stack y)) - ;; This may not be necessary as ST0 is likely invalid now. - (inst fxch x)))) + (inst fst (ea-for-sf-stack y))) + (t + (inst fxch x) + (inst fst (ea-for-sf-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) (define-move-fun (load-double 2) (vop x y) ((double-stack) (double-reg)) @@ -147,12 +152,12 @@ (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))) - (t - (inst fxch x) - (inst fstd (ea-for-df-stack y)) - ;; This may not be necessary as ST0 is likely invalid now. - (inst fxch x)))) + (inst fstd (ea-for-df-stack y))) + (t + (inst fxch x) + (inst fstd (ea-for-df-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) #!+long-float (define-move-fun (load-long 2) (vop x y) @@ -164,12 +169,12 @@ (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))) - (t - (inst fxch x) - (store-long-float (ea-for-lf-stack y)) - ;; This may not be necessary as ST0 is likely invalid now. - (inst fxch x)))) + (store-long-float (ea-for-lf-stack y))) + (t + (inst fxch 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 @@ -177,51 +182,71 @@ ;;; 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. +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* + #!+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) - (inst fldz)) - ((= value 1l0) - (inst fld1)) - ((= value pi) - (inst fldpi)) - ((= value (log 10l0 2l0)) - (inst fldl2t)) - ((= value (log 2.718281828459045235360287471352662L0 2l0)) - (inst fldl2e)) - ((= value (log 2l0 10l0)) - (inst fldlg2)) - ((= value (log 2l0 2.718281828459045235360287471352662L0)) - (inst fldln2)) - (t (warn "ignoring bogus i387 constant ~A" 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)) ;;;; complex float move functions (defun complex-single-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) - :offset (tn-offset x))) + :offset (tn-offset x))) (defun complex-single-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) - :offset (1+ (tn-offset x)))) + :offset (1+ (tn-offset x)))) (defun complex-double-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) - :offset (tn-offset x))) + :offset (tn-offset x))) (defun complex-double-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) - :offset (1+ (tn-offset x)))) + :offset (1+ (tn-offset x)))) #!+long-float (defun complex-long-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg) - :offset (tn-offset x))) + :offset (tn-offset x))) #!+long-float (defun complex-long-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg) - :offset (1+ (tn-offset x)))) + :offset (1+ (tn-offset x)))) ;;; X is source, Y is destination. (define-move-fun (load-complex-single 2) (vop x y) @@ -237,11 +262,11 @@ ((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-real-stack y))) - (t - (inst fxch real-tn) - (inst fst (ea-for-csf-real-stack y)) - (inst fxch real-tn)))) + (inst fst (ea-for-csf-real-stack y))) + (t + (inst fxch real-tn) + (inst fst (ea-for-csf-real-stack y)) + (inst fxch real-tn)))) (let ((imag-tn (complex-single-reg-imag-tn x))) (inst fxch imag-tn) (inst fst (ea-for-csf-imag-stack y)) @@ -260,11 +285,11 @@ ((complex-double-reg) (complex-double-stack)) (let ((real-tn (complex-double-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) - (inst fstd (ea-for-cdf-real-stack y))) - (t - (inst fxch real-tn) - (inst fstd (ea-for-cdf-real-stack y)) - (inst fxch real-tn)))) + (inst fstd (ea-for-cdf-real-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cdf-real-stack y)) + (inst fxch real-tn)))) (let ((imag-tn (complex-double-reg-imag-tn x))) (inst fxch imag-tn) (inst fstd (ea-for-cdf-imag-stack y)) @@ -285,11 +310,11 @@ ((complex-long-reg) (complex-long-stack)) (let ((real-tn (complex-long-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) - (store-long-float (ea-for-clf-real-stack y))) - (t - (inst fxch real-tn) - (store-long-float (ea-for-clf-real-stack y)) - (inst fxch real-tn)))) + (store-long-float (ea-for-clf-real-stack y))) + (t + (inst fxch real-tn) + (store-long-float (ea-for-clf-real-stack y)) + (inst fxch real-tn)))) (let ((imag-tn (complex-long-reg-imag-tn x))) (inst fxch imag-tn) (store-long-float (ea-for-clf-imag-stack y)) @@ -305,14 +330,14 @@ (:note "float move") (:generator 0 (unless (location= x y) - (cond ((zerop (tn-offset y)) - (copy-fp-reg-to-fr0 x)) - ((zerop (tn-offset x)) - (inst fstd y)) - (t - (inst fxch x) - (inst fstd y) - (inst fxch x)))))) + (cond ((zerop (tn-offset y)) + (copy-fp-reg-to-fr0 x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (inst fxch x)))))) (define-vop (single-move float-move) (:args (x :scs (single-reg) :target y :load-if (not (location= x y)))) @@ -341,31 +366,31 @@ ;; Note the complex-float-regs are aligned to every second ;; float register so there is not need to worry about overlap. (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (cond ((zerop (tn-offset y-real)) - (copy-fp-reg-to-fr0 x-real)) - ((zerop (tn-offset x-real)) - (inst fstd y-real)) - (t - (inst fxch x-real) - (inst fstd y-real) - (inst fxch x-real)))) + (y-real (complex-double-reg-real-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fxch x-imag) - (inst fstd y-imag) - (inst fxch x-imag))))) + (y-imag (complex-double-reg-imag-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag))))) (define-vop (complex-single-move complex-float-move) (:args (x :scs (complex-single-reg) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))) (define-move-vop complex-single-move :move (complex-single-reg) (complex-single-reg)) (define-vop (complex-double-move complex-float-move) (:args (x :scs (complex-double-reg) - :target y :load-if (not (location= x y)))) + :target y :load-if (not (location= x y)))) (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))) (define-move-vop complex-double-move :move (complex-double-reg) (complex-double-reg)) @@ -373,7 +398,7 @@ #!+long-float (define-vop (complex-long-move complex-float-move) (:args (x :scs (complex-long-reg) - :target y :load-if (not (location= x y)))) + :target y :load-if (not (location= x y)))) (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))) #!+long-float (define-move-vop complex-long-move :move @@ -388,10 +413,10 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - single-float-widetag - single-float-size node) + single-float-widetag + single-float-size node) (with-tn@fp-top(x) - (inst fst (ea-for-sf-desc y)))))) + (inst fst (ea-for-sf-desc y)))))) (define-move-vop move-from-single :move (single-reg) (descriptor-reg)) @@ -402,11 +427,11 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - double-float-widetag - double-float-size - node) + double-float-widetag + double-float-size + node) (with-tn@fp-top(x) - (inst fstd (ea-for-df-desc y)))))) + (inst fstd (ea-for-df-desc y)))))) (define-move-vop move-from-double :move (double-reg) (descriptor-reg)) @@ -418,11 +443,11 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - long-float-widetag - long-float-size - node) + long-float-widetag + long-float-size + node) (with-tn@fp-top(x) - (store-long-float (ea-for-lf-desc y)))))) + (store-long-float (ea-for-lf-desc y)))))) #!+long-float (define-move-vop move-from-long :move (long-reg) (descriptor-reg)) @@ -432,8 +457,8 @@ (:results (y :scs (descriptor-reg))) (:generator 2 (ecase (sb!c::constant-value (sb!c::tn-leaf x)) - (0f0 (load-symbol-value y *fp-constant-0s0*)) - (1f0 (load-symbol-value y *fp-constant-1s0*)) + (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*)) #!+long-float @@ -446,12 +471,12 @@ (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*)) #!+long-float (#.(log 2.718281828459045235360287471352662L0 2l0) - (load-symbol-value y *fp-constant-l2e*)) + (load-symbol-value y *fp-constant-l2e*)) #!+long-float (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*)) #!+long-float (#.(log 2l0 2.718281828459045235360287471352662L0) - (load-symbol-value y *fp-constant-ln2*))))) + (load-symbol-value y *fp-constant-ln2*))))) (define-move-vop move-from-fp-constant :move (fp-constant) (descriptor-reg)) @@ -493,16 +518,16 @@ (: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)) @@ -513,15 +538,15 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - complex-double-float-widetag - complex-double-float-size - node) + complex-double-float-widetag + complex-double-float-size + node) (let ((real-tn (complex-double-reg-real-tn x))) - (with-tn@fp-top(real-tn) - (inst fstd (ea-for-cdf-real-desc y)))) + (with-tn@fp-top(real-tn) + (inst fstd (ea-for-cdf-real-desc y)))) (let ((imag-tn (complex-double-reg-imag-tn x))) - (with-tn@fp-top(imag-tn) - (inst fstd (ea-for-cdf-imag-desc y))))))) + (with-tn@fp-top(imag-tn) + (inst fstd (ea-for-cdf-imag-desc y))))))) (define-move-vop move-from-complex-double :move (complex-double-reg) (descriptor-reg)) @@ -533,46 +558,46 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - complex-long-float-widetag - complex-long-float-size - node) + complex-long-float-widetag + complex-long-float-size + node) (let ((real-tn (complex-long-reg-real-tn x))) - (with-tn@fp-top(real-tn) - (store-long-float (ea-for-clf-real-desc y)))) + (with-tn@fp-top(real-tn) + (store-long-float (ea-for-clf-real-desc y)))) (let ((imag-tn (complex-long-reg-imag-tn x))) - (with-tn@fp-top(imag-tn) - (store-long-float (ea-for-clf-imag-desc y))))))) + (with-tn@fp-top(imag-tn) + (store-long-float (ea-for-clf-imag-desc y))))))) #!+long-float (define-move-vop move-from-complex-long :move (complex-long-reg) (descriptor-reg)) ;;; Move from a descriptor to a complex float register. (macrolet ((frob (name sc format) - `(progn - (define-vop (,name) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (,sc))) - (:note "pointer to complex float coercion") - (:generator 2 - (let ((real-tn (complex-double-reg-real-tn y))) - (with-empty-tn@fp-top(real-tn) - ,@(ecase format - (:single '((inst fld (ea-for-csf-real-desc x)))) - (:double '((inst fldd (ea-for-cdf-real-desc x)))) - #!+long-float - (:long '((inst fldl (ea-for-clf-real-desc x))))))) - (let ((imag-tn (complex-double-reg-imag-tn y))) - (with-empty-tn@fp-top(imag-tn) - ,@(ecase format - (:single '((inst fld (ea-for-csf-imag-desc x)))) - (:double '((inst fldd (ea-for-cdf-imag-desc x)))) - #!+long-float - (:long '((inst fldl (ea-for-clf-imag-desc x))))))))) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-complex-single complex-single-reg :single) - (frob move-to-complex-double complex-double-reg :double) - #!+long-float - (frob move-to-complex-double complex-long-reg :long)) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + ,@(ecase format + (:single '((inst fld (ea-for-csf-real-desc x)))) + (:double '((inst fldd (ea-for-cdf-real-desc x)))) + #!+long-float + (:long '((inst fldl (ea-for-clf-real-desc x))))))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + ,@(ecase format + (:single '((inst fld (ea-for-csf-imag-desc x)))) + (:double '((inst fldd (ea-for-cdf-imag-desc x)))) + #!+long-float + (:long '((inst fldl (ea-for-clf-imag-desc x))))))))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-complex-single complex-single-reg :single) + (frob move-to-complex-double complex-double-reg :double) + #!+long-float + (frob move-to-complex-double complex-long-reg :long)) ;;;; the move argument vops ;;;; @@ -581,51 +606,53 @@ ;;; the general MOVE-ARG VOP (macrolet ((frob (name sc stack-sc format) - `(progn - (define-vop (,name) - (:args (x :scs (,sc) :target y) - (fp :scs (any-reg) - :load-if (not (sc-is y ,sc)))) - (:results (y)) - (:note "float argument move") - (:generator ,(case format (:single 2) (:double 3) (:long 4)) - (sc-case y - (,sc - (unless (location= x y) - (cond ((zerop (tn-offset y)) - (copy-fp-reg-to-fr0 x)) - ((zerop (tn-offset x)) - (inst fstd y)) - (t - (inst fxch x) - (inst fstd y) - (inst fxch x))))) - (,stack-sc - (if (= (tn-offset fp) esp-offset) - (let* ((offset (* (tn-offset y) n-word-bytes)) - (ea (make-ea :dword :base fp :disp offset))) - (with-tn@fp-top(x) - ,@(ecase format - (:single '((inst fst ea))) - (:double '((inst fstd ea))) - #!+long-float - (:long '((store-long-float ea)))))) - (let ((ea (make-ea - :dword :base fp - :disp (- (* (+ (tn-offset y) - ,(case format - (:single 1) - (:double 2) - (:long 3))) - n-word-bytes))))) - (with-tn@fp-top(x) - ,@(ecase format - (:single '((inst fst ea))) - (:double '((inst fstd ea))) - #!+long-float - (:long '((store-long-float ea))))))))))) - (define-move-vop ,name :move-arg - (,sc descriptor-reg) (,sc))))) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float argument move") + (:generator ,(case format (:single 2) (:double 3) (:long 4)) + (sc-case y + (,sc + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (copy-fp-reg-to-fr0 x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (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) + ,@(ecase format + (:single '((inst fst ea))) + (:double '((inst fstd ea))) + #!+long-float + (:long '((store-long-float ea)))))) + ;; Lisp stack + (let ((ea (make-ea + :dword :base fp + :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))) + (:double '((inst fstd ea))) + #!+long-float + (:long '((store-long-float ea))))))))))) + (define-move-vop ,name :move-arg + (,sc descriptor-reg) (,sc))))) (frob move-single-float-arg single-reg single-stack :single) (frob move-double-float-arg double-reg double-stack :double) #!+long-float @@ -633,81 +660,81 @@ ;;;; complex float MOVE-ARG VOP (macrolet ((frob (name sc stack-sc format) - `(progn - (define-vop (,name) - (:args (x :scs (,sc) :target y) - (fp :scs (any-reg) - :load-if (not (sc-is y ,sc)))) - (:results (y)) - (:note "complex float argument move") - (:generator ,(ecase format (:single 2) (:double 3) (:long 4)) - (sc-case y - (,sc - (unless (location= x y) - (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (cond ((zerop (tn-offset y-real)) - (copy-fp-reg-to-fr0 x-real)) - ((zerop (tn-offset x-real)) - (inst fstd y-real)) - (t - (inst fxch x-real) - (inst fstd y-real) - (inst fxch x-real)))) - (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fxch x-imag) - (inst fstd y-imag) - (inst fxch x-imag)))) - (,stack-sc - (let ((real-tn (complex-double-reg-real-tn x))) - (cond ((zerop (tn-offset real-tn)) - ,@(ecase format - (:single - '((inst fst - (ea-for-csf-real-stack y fp)))) - (:double - '((inst fstd - (ea-for-cdf-real-stack y fp)))) - #!+long-float - (:long - '((store-long-float - (ea-for-clf-real-stack y fp)))))) - (t - (inst fxch real-tn) - ,@(ecase format - (:single - '((inst fst - (ea-for-csf-real-stack y fp)))) - (:double - '((inst fstd - (ea-for-cdf-real-stack y fp)))) - #!+long-float - (:long - '((store-long-float - (ea-for-clf-real-stack y fp))))) - (inst fxch real-tn)))) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (inst fxch imag-tn) - ,@(ecase format - (:single - '((inst fst (ea-for-csf-imag-stack y fp)))) - (:double - '((inst fstd (ea-for-cdf-imag-stack y fp)))) - #!+long-float - (:long - '((store-long-float - (ea-for-clf-imag-stack y fp))))) - (inst fxch imag-tn)))))) - (define-move-vop ,name :move-arg - (,sc descriptor-reg) (,sc))))) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "complex float argument move") + (:generator ,(ecase format (:single 2) (:double 3) (:long 4)) + (sc-case y + (,sc + (unless (location= x y) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)))) + (,stack-sc + (let ((real-tn (complex-double-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + ,@(ecase format + (:single + '((inst fst + (ea-for-csf-real-stack y fp)))) + (:double + '((inst fstd + (ea-for-cdf-real-stack y fp)))) + #!+long-float + (:long + '((store-long-float + (ea-for-clf-real-stack y fp)))))) + (t + (inst fxch real-tn) + ,@(ecase format + (:single + '((inst fst + (ea-for-csf-real-stack y fp)))) + (:double + '((inst fstd + (ea-for-cdf-real-stack y fp)))) + #!+long-float + (:long + '((store-long-float + (ea-for-clf-real-stack y fp))))) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst fxch imag-tn) + ,@(ecase format + (:single + '((inst fst (ea-for-csf-imag-stack y fp)))) + (:double + '((inst fstd (ea-for-cdf-imag-stack y fp)))) + #!+long-float + (:long + '((store-long-float + (ea-for-clf-imag-stack y fp))))) + (inst fxch imag-tn)))))) + (define-move-vop ,name :move-arg + (,sc descriptor-reg) (,sc))))) (frob move-complex-single-float-arg - complex-single-reg complex-single-stack :single) + complex-single-reg complex-single-stack :single) (frob move-complex-double-float-arg - complex-double-reg complex-double-stack :double) + complex-double-reg complex-double-stack :double) #!+long-float (frob move-complex-long-float-arg - complex-long-reg complex-long-stack :long)) + complex-long-reg complex-long-stack :long)) (define-move-vop move-arg :move-arg (single-reg double-reg #!+long-float long-reg @@ -734,428 +761,428 @@ ;;; 22-Jul-97: descriptor args lose in some simple cases when ;;; a function result computed in a loop. Then Python insists ;;; on consing the intermediate values! For example -#| -(defun test(a n) - (declare (type (simple-array double-float (*)) a) - (fixnum n)) - (let ((sum 0d0)) - (declare (type double-float sum)) - (dotimes (i n) - (incf sum (* (aref a i)(aref a i)))) - sum)) -|# +;;; +;;; (defun test(a n) +;;; (declare (type (simple-array double-float (*)) a) +;;; (fixnum n)) +;;; (let ((sum 0d0)) +;;; (declare (type double-float sum)) +;;; (dotimes (i n) +;;; (incf sum (* (aref a i)(aref a i)))) +;;; sum)) +;;; ;;; So, disabling descriptor args until this can be fixed elsewhere. (macrolet ((frob (op fop-sti fopr-sti - fop fopr sname scost - fopd foprd dname dcost - lname lcost) + fop fopr sname scost + fopd foprd dname dcost + lname lcost) #!-long-float (declare (ignore lcost lname)) `(progn - (define-vop (,sname) - (:translate ,op) - (:args (x :scs (single-reg single-stack #+nil descriptor-reg) - :to :eval) - (y :scs (single-reg single-stack #+nil descriptor-reg) - :to :eval)) - (:temporary (:sc single-reg :offset fr0-offset - :from :eval :to :result) fr0) - (:results (r :scs (single-reg single-stack))) - (:arg-types single-float single-float) - (:result-types single-float) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (:generator ,scost - ;; Handle a few special cases - (cond - ;; x, y, and r are the same register. - ((and (sc-is x single-reg) (location= x r) (location= y r)) - (cond ((zerop (tn-offset r)) - (inst ,fop fr0)) - (t - (inst fxch r) - (inst ,fop fr0) - ;; XX the source register will not be valid. - (note-next-instruction vop :internal-error) - (inst fxch r)))) - - ;; x and r are the same register. - ((and (sc-is x single-reg) (location= x r)) - (cond ((zerop (tn-offset r)) - (sc-case y - (single-reg - ;; ST(0) = ST(0) op ST(y) - (inst ,fop y)) - (single-stack - ;; ST(0) = ST(0) op Mem - (inst ,fop (ea-for-sf-stack y))) - (descriptor-reg - (inst ,fop (ea-for-sf-desc y))))) - (t - ;; y to ST0 - (sc-case y - (single-reg - (unless (zerop (tn-offset y)) - (copy-fp-reg-to-fr0 y))) - ((single-stack descriptor-reg) - (inst fstp fr0) - (if (sc-is y single-stack) - (inst fld (ea-for-sf-stack y)) - (inst fld (ea-for-sf-desc y))))) - ;; ST(i) = ST(i) op ST0 - (inst ,fop-sti r))) - (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)) - (sc-case x - (single-reg - ;; ST(0) = ST(x) op ST(0) - (inst ,fopr x)) - (single-stack - ;; ST(0) = Mem op ST(0) - (inst ,fopr (ea-for-sf-stack x))) - (descriptor-reg - (inst ,fopr (ea-for-sf-desc x))))) - (t - ;; x to ST0 - (sc-case x - (single-reg - (unless (zerop (tn-offset x)) - (copy-fp-reg-to-fr0 x))) - ((single-stack descriptor-reg) - (inst fstp fr0) - (if (sc-is x single-stack) - (inst fld (ea-for-sf-stack x)) - (inst fld (ea-for-sf-desc x))))) - ;; ST(i) = ST(0) op ST(i) - (inst ,fopr-sti r))) - (maybe-fp-wait node vop)) - ;; the default case - (t - ;; Get the result to ST0. - - ;; Special handling is needed if x or y are in ST0, and - ;; simpler code is generated. - (cond - ;; x is in ST0 - ((and (sc-is x single-reg) (zerop (tn-offset x))) - ;; ST0 = ST0 op y - (sc-case y - (single-reg - (inst ,fop y)) - (single-stack - (inst ,fop (ea-for-sf-stack y))) - (descriptor-reg - (inst ,fop (ea-for-sf-desc y))))) - ;; y is in ST0 - ((and (sc-is y single-reg) (zerop (tn-offset y))) - ;; ST0 = x op ST0 - (sc-case x - (single-reg - (inst ,fopr x)) - (single-stack - (inst ,fopr (ea-for-sf-stack x))) - (descriptor-reg - (inst ,fopr (ea-for-sf-desc x))))) - (t - ;; x to ST0 - (sc-case x - (single-reg - (copy-fp-reg-to-fr0 x)) - (single-stack - (inst fstp fr0) - (inst fld (ea-for-sf-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fld (ea-for-sf-desc x)))) - ;; ST0 = ST0 op y - (sc-case y - (single-reg - (inst ,fop y)) - (single-stack - (inst ,fop (ea-for-sf-stack y))) - (descriptor-reg - (inst ,fop (ea-for-sf-desc y)))))) - - (note-next-instruction vop :internal-error) - - ;; Finally save the result. - (sc-case r - (single-reg - (cond ((zerop (tn-offset r)) - (maybe-fp-wait node)) - (t - (inst fst r)))) - (single-stack - (inst fst (ea-for-sf-stack r)))))))) - - (define-vop (,dname) - (:translate ,op) - (:args (x :scs (double-reg double-stack #+nil descriptor-reg) - :to :eval) - (y :scs (double-reg double-stack #+nil descriptor-reg) - :to :eval)) - (:temporary (:sc double-reg :offset fr0-offset - :from :eval :to :result) fr0) - (:results (r :scs (double-reg double-stack))) - (:arg-types double-float double-float) - (:result-types double-float) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (:generator ,dcost - ;; 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)) - (cond ((zerop (tn-offset r)) - (inst ,fop fr0)) - (t - (inst fxch x) - (inst ,fopd fr0) - ;; XX the source register will not be valid. - (note-next-instruction vop :internal-error) - (inst fxch r)))) - - ;; x and r are the same register. - ((and (sc-is x double-reg) (location= x r)) - (cond ((zerop (tn-offset r)) - (sc-case y - (double-reg - ;; ST(0) = ST(0) op ST(y) - (inst ,fopd y)) - (double-stack - ;; ST(0) = ST(0) op Mem - (inst ,fopd (ea-for-df-stack y))) - (descriptor-reg - (inst ,fopd (ea-for-df-desc y))))) - (t - ;; y to ST0 - (sc-case y - (double-reg - (unless (zerop (tn-offset y)) - (copy-fp-reg-to-fr0 y))) - ((double-stack descriptor-reg) - (inst fstp fr0) - (if (sc-is y double-stack) - (inst fldd (ea-for-df-stack y)) - (inst fldd (ea-for-df-desc y))))) - ;; ST(i) = ST(i) op ST0 - (inst ,fop-sti r))) - (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)) - (sc-case x - (double-reg - ;; ST(0) = ST(x) op ST(0) - (inst ,foprd x)) - (double-stack - ;; ST(0) = Mem op ST(0) - (inst ,foprd (ea-for-df-stack x))) - (descriptor-reg - (inst ,foprd (ea-for-df-desc x))))) - (t - ;; x to ST0 - (sc-case x - (double-reg - (unless (zerop (tn-offset x)) - (copy-fp-reg-to-fr0 x))) - ((double-stack descriptor-reg) - (inst fstp fr0) - (if (sc-is x double-stack) - (inst fldd (ea-for-df-stack x)) - (inst fldd (ea-for-df-desc x))))) - ;; ST(i) = ST(0) op ST(i) - (inst ,fopr-sti r))) - (maybe-fp-wait node vop)) - ;; the default case - (t - ;; Get the result to ST0. - - ;; Special handling is needed if x or y are in ST0, and - ;; simpler code is generated. - (cond - ;; x is in ST0 - ((and (sc-is x double-reg) (zerop (tn-offset x))) - ;; ST0 = ST0 op y - (sc-case y - (double-reg - (inst ,fopd y)) - (double-stack - (inst ,fopd (ea-for-df-stack y))) - (descriptor-reg - (inst ,fopd (ea-for-df-desc y))))) - ;; y is in ST0 - ((and (sc-is y double-reg) (zerop (tn-offset y))) - ;; ST0 = x op ST0 - (sc-case x - (double-reg - (inst ,foprd x)) - (double-stack - (inst ,foprd (ea-for-df-stack x))) - (descriptor-reg - (inst ,foprd (ea-for-df-desc x))))) - (t - ;; x to ST0 - (sc-case x - (double-reg - (copy-fp-reg-to-fr0 x)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc x)))) - ;; ST0 = ST0 op y - (sc-case y - (double-reg - (inst ,fopd y)) - (double-stack - (inst ,fopd (ea-for-df-stack y))) - (descriptor-reg - (inst ,fopd (ea-for-df-desc y)))))) - - (note-next-instruction vop :internal-error) - - ;; Finally save the result. - (sc-case r - (double-reg - (cond ((zerop (tn-offset r)) - (maybe-fp-wait node)) - (t - (inst fst r)))) - (double-stack - (inst fstd (ea-for-df-stack r)))))))) - - #!+long-float - (define-vop (,lname) - (:translate ,op) - (:args (x :scs (long-reg) :to :eval) - (y :scs (long-reg) :to :eval)) - (:temporary (:sc long-reg :offset fr0-offset - :from :eval :to :result) fr0) - (:results (r :scs (long-reg))) - (:arg-types long-float long-float) - (:result-types long-float) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (:generator ,lcost - ;; Handle a few special cases. - (cond - ;; x, y, and r are the same register. - ((and (location= x r) (location= y r)) - (cond ((zerop (tn-offset r)) - (inst ,fop fr0)) - (t - (inst fxch x) - (inst ,fopd fr0) - ;; XX the source register will not be valid. - (note-next-instruction vop :internal-error) - (inst fxch r)))) - - ;; x and r are the same register. - ((location= x r) - (cond ((zerop (tn-offset r)) - ;; ST(0) = ST(0) op ST(y) - (inst ,fopd y)) - (t - ;; y to ST0 - (unless (zerop (tn-offset y)) - (copy-fp-reg-to-fr0 y)) - ;; ST(i) = ST(i) op ST0 - (inst ,fop-sti r))) - (maybe-fp-wait node vop)) - ;; y and r are the same register. - ((location= y r) - (cond ((zerop (tn-offset r)) - ;; ST(0) = ST(x) op ST(0) - (inst ,foprd x)) - (t - ;; x to ST0 - (unless (zerop (tn-offset x)) - (copy-fp-reg-to-fr0 x)) - ;; ST(i) = ST(0) op ST(i) - (inst ,fopr-sti r))) - (maybe-fp-wait node vop)) - ;; the default case - (t - ;; Get the result to ST0. - - ;; Special handling is needed if x or y are in ST0, and - ;; simpler code is generated. - (cond - ;; x is in ST0. - ((zerop (tn-offset x)) - ;; ST0 = ST0 op y - (inst ,fopd y)) - ;; y is in ST0 - ((zerop (tn-offset y)) - ;; ST0 = x op ST0 - (inst ,foprd x)) - (t - ;; x to ST0 - (copy-fp-reg-to-fr0 x) - ;; ST0 = ST0 op y - (inst ,fopd y))) - - (note-next-instruction vop :internal-error) - - ;; Finally save the result. - (cond ((zerop (tn-offset r)) - (maybe-fp-wait node)) - (t - (inst fst r)))))))))) + (define-vop (,sname) + (:translate ,op) + (:args (x :scs (single-reg single-stack #+nil descriptor-reg) + :to :eval) + (y :scs (single-reg single-stack #+nil descriptor-reg) + :to :eval)) + (:temporary (:sc single-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (single-reg single-stack))) + (:arg-types single-float single-float) + (:result-types single-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,scost + ;; Handle a few special cases + (cond + ;; x, y, and r are the same register. + ((and (sc-is x single-reg) (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch r) + (inst ,fop fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x single-reg) (location= x r)) + (cond ((zerop (tn-offset r)) + (sc-case y + (single-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fop y)) + (single-stack + ;; ST(0) = ST(0) op Mem + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y))))) + (t + ;; y to ST0 + (sc-case y + (single-reg + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y))) + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is y single-stack) + (inst fld (ea-for-sf-stack y)) + (inst fld (ea-for-sf-desc y))))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (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)) + (sc-case x + (single-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,fopr x)) + (single-stack + ;; ST(0) = Mem op ST(0) + (inst ,fopr (ea-for-sf-stack x))) + (descriptor-reg + (inst ,fopr (ea-for-sf-desc x))))) + (t + ;; x to ST0 + (sc-case x + (single-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (maybe-fp-wait node vop)) + ;; the default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x single-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y))))) + ;; y is in ST0 + ((and (sc-is y single-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (single-reg + (inst ,fopr x)) + (single-stack + (inst ,fopr (ea-for-sf-stack x))) + (descriptor-reg + (inst ,fopr (ea-for-sf-desc x))))) + (t + ;; x to ST0 + (sc-case x + (single-reg + (copy-fp-reg-to-fr0 x)) + (single-stack + (inst fstp fr0) + (inst fld (ea-for-sf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fld (ea-for-sf-desc x)))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result. + (sc-case r + (single-reg + (cond ((zerop (tn-offset r)) + (maybe-fp-wait node)) + (t + (inst fst r)))) + (single-stack + (inst fst (ea-for-sf-stack r)))))))) + + (define-vop (,dname) + (:translate ,op) + (:args (x :scs (double-reg double-stack #+nil descriptor-reg) + :to :eval) + (y :scs (double-reg double-stack #+nil descriptor-reg) + :to :eval)) + (:temporary (:sc double-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (double-reg double-stack))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,dcost + ;; 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)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch x) + (inst ,fopd fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x double-reg) (location= x r)) + (cond ((zerop (tn-offset r)) + (sc-case y + (double-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fopd y)) + (double-stack + ;; ST(0) = ST(0) op Mem + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y))))) + (t + ;; y to ST0 + (sc-case y + (double-reg + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is y double-stack) + (inst fldd (ea-for-df-stack y)) + (inst fldd (ea-for-df-desc y))))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (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)) + (sc-case x + (double-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,foprd x)) + (double-stack + ;; ST(0) = Mem op ST(0) + (inst ,foprd (ea-for-df-stack x))) + (descriptor-reg + (inst ,foprd (ea-for-df-desc x))))) + (t + ;; x to ST0 + (sc-case x + (double-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (maybe-fp-wait node vop)) + ;; the default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y))))) + ;; y is in ST0 + ((and (sc-is y double-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (double-reg + (inst ,foprd x)) + (double-stack + (inst ,foprd (ea-for-df-stack x))) + (descriptor-reg + (inst ,foprd (ea-for-df-desc x))))) + (t + ;; x to ST0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x)))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result. + (sc-case r + (double-reg + (cond ((zerop (tn-offset r)) + (maybe-fp-wait node)) + (t + (inst fst r)))) + (double-stack + (inst fstd (ea-for-df-stack r)))))))) + + #!+long-float + (define-vop (,lname) + (:translate ,op) + (:args (x :scs (long-reg) :to :eval) + (y :scs (long-reg) :to :eval)) + (:temporary (:sc long-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,lcost + ;; Handle a few special cases. + (cond + ;; x, y, and r are the same register. + ((and (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch x) + (inst ,fopd fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((location= x r) + (cond ((zerop (tn-offset r)) + ;; ST(0) = ST(0) op ST(y) + (inst ,fopd y)) + (t + ;; y to ST0 + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y)) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (maybe-fp-wait node vop)) + ;; y and r are the same register. + ((location= y r) + (cond ((zerop (tn-offset r)) + ;; ST(0) = ST(x) op ST(0) + (inst ,foprd x)) + (t + ;; x to ST0 + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x)) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (maybe-fp-wait node vop)) + ;; the default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0. + ((zerop (tn-offset x)) + ;; ST0 = ST0 op y + (inst ,fopd y)) + ;; y is in ST0 + ((zerop (tn-offset y)) + ;; ST0 = x op ST0 + (inst ,foprd x)) + (t + ;; x to ST0 + (copy-fp-reg-to-fr0 x) + ;; ST0 = ST0 op y + (inst ,fopd y))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result. + (cond ((zerop (tn-offset r)) + (maybe-fp-wait node)) + (t + (inst fst r)))))))))) (frob + fadd-sti fadd-sti - fadd fadd +/single-float 2 - faddd faddd +/double-float 2 - +/long-float 2) + fadd fadd +/single-float 2 + faddd faddd +/double-float 2 + +/long-float 2) (frob - fsub-sti fsubr-sti - fsub fsubr -/single-float 2 - fsubd fsubrd -/double-float 2 - -/long-float 2) + fsub fsubr -/single-float 2 + fsubd fsubrd -/double-float 2 + -/long-float 2) (frob * fmul-sti fmul-sti - fmul fmul */single-float 3 - fmuld fmuld */double-float 3 - */long-float 3) + fmul fmul */single-float 3 + fmuld fmuld */double-float 3 + */long-float 3) (frob / fdiv-sti fdivr-sti - fdiv fdivr //single-float 12 - fdivd fdivrd //double-float 12 - //long-float 12)) + fdiv fdivr //single-float 12 + fdivd fdivrd //double-float 12 + //long-float 12)) (macrolet ((frob (name inst translate sc type) - `(define-vop (,name) - (:args (x :scs (,sc) :target fr0)) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:ignore fr0) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (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 ,inst) ; Clobber st0. - (unless (zerop (tn-offset y)) - (inst fst y)))))) + `(define-vop (,name) + (:args (x :scs (,sc) :target fr0)) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (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 ,inst) ; Clobber st0. + (unless (zerop (tn-offset y)) + (inst fst y)))))) (frob abs/single-float fabs abs single-reg single-float) (frob abs/double-float fabs abs double-reg double-float) @@ -1171,8 +1198,7 @@ (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) @@ -1197,39 +1223,37 @@ (inst fxch x) (inst fucom y) (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 fnstsw) ; status word to ax + (inst and ah-tn #x45) ; C3 C2 C0 + (inst cmp ah-tn #x40))) (define-vop (=/single-float =/float) (:translate =) (:args (x :scs (single-reg)) - (y :scs (single-reg))) + (y :scs (single-reg))) (:arg-types single-float single-float)) (define-vop (=/double-float =/float) (:translate =) (:args (x :scs (double-reg)) - (y :scs (double-reg))) + (y :scs (double-reg))) (:arg-types double-float double-float)) #!+long-float (define-vop (=/long-float =/float) (:translate =) (:args (x :scs (long-reg)) - (y :scs (long-reg))) + (y :scs (long-reg))) (:arg-types long-float long-float)) (define-vop (single-float) (:translate >) (:args (x :scs (single-reg single-stack descriptor-reg)) - (y :scs (single-reg single-stack descriptor-reg))) + (y :scs (single-reg single-stack descriptor-reg))) (: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) @@ -1376,13 +1395,13 @@ ;; y is ST0. ((and (sc-is y single-reg) (zerop (tn-offset y))) (sc-case x - (single-reg - (inst fcom x)) - ((single-stack descriptor-reg) - (if (sc-is x single-stack) - (inst fcom (ea-for-sf-stack x)) - (inst fcom (ea-for-sf-desc x))))) - (inst fnstsw) ; status word to ax + (single-reg + (inst fcom x)) + ((single-stack descriptor-reg) + (if (sc-is x single-stack) + (inst fcom (ea-for-sf-stack x)) + (inst fcom (ea-for-sf-desc x))))) + (inst fnstsw) ; status word to ax (inst and ah-tn #x45) (inst cmp ah-tn #x01)) @@ -1390,34 +1409,32 @@ (t ;; x to ST0 (sc-case x - (single-reg - (unless (zerop (tn-offset x)) - (copy-fp-reg-to-fr0 x))) - ((single-stack descriptor-reg) - (inst fstp fr0) - (if (sc-is x single-stack) - (inst fld (ea-for-sf-stack x)) - (inst fld (ea-for-sf-desc x))))) + (single-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) (sc-case y - (single-reg - (inst fcom y)) - ((single-stack descriptor-reg) - (if (sc-is y single-stack) - (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))) + (single-reg + (inst fcom y)) + ((single-stack descriptor-reg) + (if (sc-is y single-stack) + (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))))) (define-vop (>double-float) (:translate >) (:args (x :scs (double-reg double-stack descriptor-reg)) - (y :scs (double-reg double-stack descriptor-reg))) + (y :scs (double-reg double-stack descriptor-reg))) (: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) @@ -1427,13 +1444,13 @@ ;; y is ST0. ((and (sc-is y double-reg) (zerop (tn-offset y))) (sc-case x - (double-reg - (inst fcomd x)) - ((double-stack descriptor-reg) - (if (sc-is x double-stack) - (inst fcomd (ea-for-df-stack x)) - (inst fcomd (ea-for-df-desc x))))) - (inst fnstsw) ; status word to ax + (double-reg + (inst fcomd x)) + ((double-stack descriptor-reg) + (if (sc-is x double-stack) + (inst fcomd (ea-for-df-stack x)) + (inst fcomd (ea-for-df-desc x))))) + (inst fnstsw) ; status word to ax (inst and ah-tn #x45) (inst cmp ah-tn #x01)) @@ -1441,34 +1458,32 @@ (t ;; x to ST0 (sc-case x - (double-reg - (unless (zerop (tn-offset x)) - (copy-fp-reg-to-fr0 x))) - ((double-stack descriptor-reg) - (inst fstp fr0) - (if (sc-is x double-stack) - (inst fldd (ea-for-df-stack x)) - (inst fldd (ea-for-df-desc x))))) + (double-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) (sc-case y - (double-reg - (inst fcomd y)) - ((double-stack descriptor-reg) - (if (sc-is y double-stack) - (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))) + (double-reg + (inst fcomd y)) + ((double-stack descriptor-reg) + (if (sc-is y double-stack) + (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))))) #!+long-float (define-vop (>long-float) (:translate >) (:args (x :scs (long-reg)) - (y :scs (long-reg))) + (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) @@ -1477,13 +1492,13 @@ ;; y is in ST0; x is in any reg. ((zerop (tn-offset y)) (inst fcomd x) - (inst fnstsw) ; status word to ax + (inst fnstsw) ; status word to ax (inst and ah-tn #x45) (inst cmp ah-tn #x01)) ;; x is in ST0; y is in another reg. ((zerop (tn-offset x)) (inst fcomd y) - (inst fnstsw) ; status word to ax + (inst fnstsw) ; status word to ax (inst and ah-tn #x45)) ;; y and x are the same register, not ST0 ;; y and x are different registers, neither ST0. @@ -1491,17 +1506,16 @@ (inst fxch x) (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 fnstsw) ; status word to ax + (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) @@ -1519,144 +1533,116 @@ (inst fxch x) (inst ftst) (inst fxch x))) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x45) ; C3 C2 C0 + (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 =) (:args (x :scs (single-reg))) - #!-negative-zero-is-not-zero (:arg-types single-float (:constant (single-float 0f0 0f0))) - #!+negative-zero-is-not-zero - (:arg-types single-float (:constant (single-float -0f0 0f0))) (:variant #x40)) (define-vop (=0/double-float float-test) (:translate =) (:args (x :scs (double-reg))) - #!-negative-zero-is-not-zero (:arg-types double-float (:constant (double-float 0d0 0d0))) - #!+negative-zero-is-not-zero - (:arg-types double-float (:constant (double-float -0d0 0d0))) (:variant #x40)) #!+long-float (define-vop (=0/long-float float-test) (:translate =) (:args (x :scs (long-reg))) - #!-negative-zero-is-not-zero (:arg-types long-float (:constant (long-float 0l0 0l0))) - #!+negative-zero-is-not-zero - (:arg-types long-float (:constant (long-float -0l0 0l0))) (:variant #x40)) (define-vop (<0/single-float float-test) (:translate <) (:args (x :scs (single-reg))) - #!-negative-zero-is-not-zero (:arg-types single-float (:constant (single-float 0f0 0f0))) - #!+negative-zero-is-not-zero - (:arg-types single-float (:constant (single-float -0f0 0f0))) (:variant #x01)) (define-vop (<0/double-float float-test) (:translate <) (:args (x :scs (double-reg))) - #!-negative-zero-is-not-zero (:arg-types double-float (:constant (double-float 0d0 0d0))) - #!+negative-zero-is-not-zero - (:arg-types double-float (:constant (double-float -0d0 0d0))) (:variant #x01)) #!+long-float (define-vop (<0/long-float float-test) (:translate <) (:args (x :scs (long-reg))) - #!-negative-zero-is-not-zero (:arg-types long-float (:constant (long-float 0l0 0l0))) - #!+negative-zero-is-not-zero - (:arg-types long-float (:constant (long-float -0l0 0l0))) (:variant #x01)) (define-vop (>0/single-float float-test) (:translate >) (:args (x :scs (single-reg))) - #!-negative-zero-is-not-zero (:arg-types single-float (:constant (single-float 0f0 0f0))) - #!+negative-zero-is-not-zero - (:arg-types single-float (:constant (single-float -0f0 0f0))) (:variant #x00)) (define-vop (>0/double-float float-test) (:translate >) (:args (x :scs (double-reg))) - #!-negative-zero-is-not-zero (:arg-types double-float (:constant (double-float 0d0 0d0))) - #!+negative-zero-is-not-zero - (:arg-types double-float (:constant (double-float -0d0 0d0))) (:variant #x00)) #!+long-float (define-vop (>0/long-float float-test) (:translate >) (:args (x :scs (long-reg))) - #!-negative-zero-is-not-zero (:arg-types long-float (:constant (long-float 0l0 0l0))) - #!+negative-zero-is-not-zero - (:arg-types long-float (:constant (long-float -0l0 0l0))) (:variant #x00)) #!+long-float (deftransform eql ((x y) (long-float long-float)) `(and (= (long-float-low-bits x) (long-float-low-bits y)) - (= (long-float-high-bits x) (long-float-high-bits y)) - (= (long-float-exp-bits x) (long-float-exp-bits y)))) + (= (long-float-high-bits x) (long-float-high-bits y)) + (= (long-float-exp-bits x) (long-float-exp-bits y)))) ;;;; conversion (macrolet ((frob (name translate to-sc to-type) - `(define-vop (,name) - (:args (x :scs (signed-stack signed-reg) :target temp)) - (:temporary (:sc signed-stack) temp) - (:results (y :scs (,to-sc))) - (:arg-types signed-num) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (sc-case x - (signed-reg - (inst mov temp x) - (with-empty-tn@fp-top(y) - (note-this-location vop :internal-error) - (inst fild temp))) - (signed-stack - (with-empty-tn@fp-top(y) - (note-this-location vop :internal-error) - (inst fild x)))))))) + `(define-vop (,name) + (:args (x :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc signed-stack) temp) + (:results (y :scs (,to-sc))) + (:arg-types signed-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (sc-case x + (signed-reg + (inst mov temp x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild temp))) + (signed-stack + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild x)))))))) (frob %single-float/signed %single-float single-reg single-float) (frob %double-float/signed %double-float double-reg double-float) #!+long-float (frob %long-float/signed %long-float long-reg long-float)) (macrolet ((frob (name translate 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 push 0) - (inst push x) - (with-empty-tn@fp-top(y) - (note-this-location vop :internal-error) - (inst fildl (make-ea :dword :base esp-tn))) - (inst add esp-tn 8))))) + `(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 push 0) + (inst push x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fildl (make-ea :dword :base esp-tn))) + (inst add esp-tn 8))))) (frob %single-float/unsigned %single-float single-reg single-float) (frob %double-float/unsigned %double-float double-reg double-float) #!+long-float @@ -1665,87 +1651,87 @@ ;;; 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)) - (:results (y :scs (,to-sc))) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (: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)))))))) + `(define-vop (,name) + (:args (x :scs (,from-sc) :target y)) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (: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) + double-float single-reg single-float) #!+long-float (frob %single-float/long-float %single-float long-reg - long-float single-reg single-float) + long-float single-reg single-float) (frob %double-float/single-float %double-float single-reg single-float - double-reg double-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) #!+long-float (frob %long-float/single-float %long-float single-reg single-float - long-reg long-float) + long-reg long-float) #!+long-float (frob %long-float/double-float %long-float double-reg double-float - long-reg long-float)) + long-reg long-float)) (macrolet ((frob (trans from-sc from-type round-p) - `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc))) - (:temporary (:sc signed-stack) stack-temp) - ,@(unless round-p - '((:temporary (:sc unsigned-stack) scw) - (:temporary (:sc any-reg) rcw))) - (:results (y :scs (signed-reg))) - (:arg-types ,from-type) - (:result-types signed-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))) - (,(if round-p 'progn 'pseudo-atomic) - ;; Normal mode (for now) is "round to best". - (with-tn@fp-top (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))) - (sc-case y - (signed-stack - (inst fist y)) - (signed-reg - (inst fist stack-temp) - (inst mov y stack-temp))) - ,@(unless round-p - '((inst fldcw scw))))))))) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc))) + (:temporary (:sc signed-stack) stack-temp) + ,@(unless round-p + '((:temporary (:sc unsigned-stack) scw) + (:temporary (:sc any-reg) rcw))) + (:results (y :scs (signed-reg))) + (:arg-types ,from-type) + (:result-types signed-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))) + (,(if round-p 'progn 'pseudo-atomic) + ;; Normal mode (for now) is "round to best". + (with-tn@fp-top (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))) + (sc-case y + (signed-stack + (inst fist y)) + (signed-reg + (inst fist stack-temp) + (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) #!+long-float @@ -1756,43 +1742,43 @@ (frob %unary-round long-reg long-float t)) (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 esp-tn 8) - (inst fistpl (make-ea :dword :base esp-tn)) - (inst pop y) - (inst fld fr0) ; copy fr0 to at least restore stack. - (inst add esp-tn 4) - ,@(unless round-p - '((inst fldcw scw))))))) + `(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 esp-tn 8) + (inst fistpl (make-ea :dword :base esp-tn)) + (inst pop y) + (inst fld fr0) ; copy fr0 to at least restore stack. + (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) #!+long-float @@ -1804,11 +1790,11 @@ (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-reg)) - (and (sc-is bits signed-stack) - (sc-is res single-stack) - (location= bits res)))))) + :load-if (not (or (and (sc-is bits signed-stack) + (sc-is res single-reg)) + (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) @@ -1819,25 +1805,25 @@ (:generator 4 (sc-case res (single-stack - (sc-case bits - (signed-reg - (inst mov res bits)) - (signed-stack - (aver (location= bits res))))) + (sc-case bits + (signed-reg + (inst mov res bits)) + (signed-stack + (aver (location= bits res))))) (single-reg - (sc-case bits - (signed-reg - ;; source must be in memory - (inst mov stack-temp bits) - (with-empty-tn@fp-top(res) - (inst fld stack-temp))) - (signed-stack - (with-empty-tn@fp-top(res) - (inst fld bits)))))))) + (sc-case bits + (signed-reg + ;; source must be in memory + (inst mov stack-temp bits) + (with-empty-tn@fp-top(res) + (inst fld stack-temp))) + (signed-stack + (with-empty-tn@fp-top(res) + (inst fld bits)))))))) (define-vop (make-double-float) (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) + (lo-bits :scs (unsigned-reg))) (:results (res :scs (double-reg))) (:temporary (:sc double-stack) temp) (:arg-types signed-num unsigned-num) @@ -1846,18 +1832,18 @@ (: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)))))))) + (inst fldd (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (1+ offset)))))))) #!+long-float (define-vop (make-long-float) (:args (exp-bits :scs (signed-reg)) - (hi-bits :scs (unsigned-reg)) - (lo-bits :scs (unsigned-reg))) + (hi-bits :scs (unsigned-reg)) + (lo-bits :scs (unsigned-reg))) (:results (res :scs (long-reg))) (:temporary (:sc long-stack) temp) (:arg-types signed-num unsigned-num unsigned-num) @@ -1866,17 +1852,17 @@ (: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)))))))) + (inst fldl (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ offset 2)))))))) (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) - :load-if (not (sc-is float single-stack)))) + :load-if (not (sc-is float single-stack)))) (:results (bits :scs (signed-reg))) (:temporary (:sc signed-stack :from :argument :to :result) stack-temp) (:arg-types single-float) @@ -1888,25 +1874,25 @@ (sc-case bits (signed-reg (sc-case float - (single-reg - (with-tn@fp-top(float) - (inst fst stack-temp) - (inst mov bits stack-temp))) - (single-stack - (inst mov bits float)) - (descriptor-reg - (loadw - bits float single-float-value-slot - other-pointer-lowtag)))) + (single-reg + (with-tn@fp-top(float) + (inst fst stack-temp) + (inst mov bits stack-temp))) + (single-stack + (inst mov bits float)) + (descriptor-reg + (loadw + bits float single-float-value-slot + other-pointer-lowtag)))) (signed-stack (sc-case float - (single-reg - (with-tn@fp-top(float) - (inst fst bits)))))))) + (single-reg + (with-tn@fp-top(float) + (inst fst bits)))))))) (define-vop (double-float-high-bits) (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) + :load-if (not (sc-is float double-stack)))) (:results (hi-bits :scs (signed-reg))) (:temporary (:sc double-stack) temp) (:arg-types double-float) @@ -1917,21 +1903,20 @@ (:generator 5 (sc-case float (double-reg - (with-tn@fp-top(float) - (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 2 (tn-offset temp)) - n-word-bytes))))) - (inst fstd where))) - (loadw hi-bits ebp-tn (- (1+ (tn-offset temp))))) + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (1+ (tn-offset temp)))))) + (inst fstd where))) + (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))))) + (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) - :load-if (not (sc-is float double-stack)))) + :load-if (not (sc-is float double-stack)))) (:results (lo-bits :scs (unsigned-reg))) (:temporary (:sc double-stack) temp) (:arg-types double-float) @@ -1942,22 +1927,21 @@ (:generator 5 (sc-case float (double-reg - (with-tn@fp-top(float) - (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 2 (tn-offset temp)) - n-word-bytes))))) - (inst fstd where))) - (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp))))) + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (1+ (tn-offset temp)))))) + (inst fstd where))) + (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))))) + (loadw lo-bits float double-float-value-slot + other-pointer-lowtag))))) #!+long-float (define-vop (long-float-exp-bits) (:args (float :scs (long-reg descriptor-reg) - :load-if (not (sc-is float long-stack)))) + :load-if (not (sc-is float long-stack)))) (:results (exp-bits :scs (signed-reg))) (:temporary (:sc long-stack) temp) (:arg-types long-float) @@ -1968,29 +1952,26 @@ (:generator 5 (sc-case float (long-reg - (with-tn@fp-top(float) - (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 3 (tn-offset temp)) - n-word-bytes))))) - (store-long-float where))) - (inst movsx exp-bits - (make-ea :word :base ebp-tn - :disp (* (- (1+ (tn-offset temp))) n-word-bytes)))) + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) + (store-long-float where))) + (inst movsx exp-bits + (make-ea :word :base ebp-tn + :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)))) + (inst movsx exp-bits + (make-ea :word :base ebp-tn + :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))))))) + (inst movsx exp-bits + (make-ea-for-object-slot float (+ 2 long-float-value-slot) + other-pointer-lowtag :word)))))) #!+long-float (define-vop (long-float-high-bits) (:args (float :scs (long-reg descriptor-reg) - :load-if (not (sc-is float long-stack)))) + :load-if (not (sc-is float long-stack)))) (:results (hi-bits :scs (unsigned-reg))) (:temporary (:sc long-stack) temp) (:arg-types long-float) @@ -2001,22 +1982,21 @@ (:generator 5 (sc-case float (long-reg - (with-tn@fp-top(float) - (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 3 (tn-offset temp)) - n-word-bytes))))) - (store-long-float where))) - (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2)))) + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) + (store-long-float where))) + (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))))) + (loadw hi-bits float (1+ long-float-value-slot) + other-pointer-lowtag))))) #!+long-float (define-vop (long-float-low-bits) (:args (float :scs (long-reg descriptor-reg) - :load-if (not (sc-is float long-stack)))) + :load-if (not (sc-is float long-stack)))) (:results (lo-bits :scs (unsigned-reg))) (:temporary (:sc long-stack) temp) (:arg-types long-float) @@ -2027,17 +2007,16 @@ (:generator 5 (sc-case float (long-reg - (with-tn@fp-top(float) - (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 3 (tn-offset temp)) - n-word-bytes))))) - (store-long-float where))) - (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3)))) + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) + (store-long-float where))) + (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))))) + (loadw lo-bits float long-float-value-slot + other-pointer-lowtag))))) ;;;; float mode hackery @@ -2046,9 +2025,9 @@ (defknown ((setf floating-point-modes)) (float-modes) float-modes) -(defconstant npx-env-size (* 7 n-word-bytes)) -(defconstant npx-cw-offset 0) -(defconstant npx-sw-offset 4) +(def!constant npx-env-size (* 7 n-word-bytes)) +(def!constant npx-cw-offset 0) +(def!constant npx-sw-offset 4) (define-vop (floating-point-modes) (:results (res :scs (unsigned-reg))) @@ -2056,18 +2035,18 @@ (:translate floating-point-modes) (:policy :fast-safe) (:temporary (:sc unsigned-reg :offset eax-offset :target res - :to :result) eax) + :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. ;; Move current status to high word. (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2))) ;; 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) @@ -2078,18 +2057,18 @@ (:translate (setf floating-point-modes)) (:policy :fast-safe) (:temporary (:sc unsigned-reg :offset eax-offset - :from :eval :to :result) eax) + :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 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))) #!-long-float @@ -2101,31 +2080,31 @@ ;;; to remove the inlined alien routine def. (macrolet ((frob (func trans op) - `(define-vop (,func) - (:args (x :scs (double-reg) :target fr0)) - (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:ignore fr0) - (:results (y :scs (double-reg))) - (:arg-types double-float) - (:result-types double-float) - (:translate ,trans) - (:policy :fast-safe) - (:note "inline NPX function") - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (: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) ; clobber st0 - (cond ((zerop (tn-offset y)) - (maybe-fp-wait node)) - (t - (inst fst y))))))) + `(define-vop (,func) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline NPX function") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (: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) ; clobber st0 + (cond ((zerop (tn-offset y)) + (maybe-fp-wait node)) + (t + (inst fst y))))))) ;; Quick versions of fsin and fcos that require the argument to be ;; within range 2^63. @@ -2139,9 +2118,9 @@ (:translate %tan-quick) (:args (x :scs (double-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2153,177 +2132,72 @@ (note-this-location vop :internal-error) (case (tn-offset x) (0 - (inst fstp fr1)) + (inst fstp fr1)) (1 - (inst fstp fr0)) + (inst fstp fr0)) (t - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2))))) + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) (inst fptan) ;; Result is in fr1 (case (tn-offset y) (0 - (inst fxch fr1)) + (inst fxch fr1)) (1) (t - (inst fxch fr1) - (inst fstd y))))) + (inst fxch fr1) + (inst fstd y))))) -;;; These versions of fsin, fcos, and ftan try to use argument -;;; reduction but to do this accurately requires greater precision and -;;; it is hopelessly inaccurate. -#+nil +;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0 +;;; result if the argument is out of range 2^63 and would thus be +;;; hopelessly inaccurate. (macrolet ((frob (func trans op) - `(define-vop (,func) - (:translate ,trans) - (:args (x :scs (double-reg) :target fr0)) - (:temporary (:sc unsigned-reg :offset eax-offset - :from :eval :to :result) eax) - (:temporary (:sc unsigned-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc unsigned-reg :offset fr1-offset - :from :argument :to :result) fr1) - (:results (y :scs (double-reg))) - (:arg-types double-float) - (:result-types double-float) - (:policy :fast-safe) - (:note "inline sin/cos function") - (:vop-var vop) - (: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 fr1) ; Load 2*PI - (inst fldpi) - (inst fadd fr0) - (inst fxch fr1) - LOOP - (inst fprem1) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x04) ; C2 - (inst jmp :nz LOOP) - (inst ,op) - DONE - (unless (zerop (tn-offset y)) - (inst fstd y)))))) - (frob fsin %sin fsin) - (frob fcos %cos fcos)) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :argument :to :result) eax) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (: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)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) -#+nil (define-vop (ftan) (:translate %tan) (:args (x :scs (double-reg) :target fr0)) - (:temporary (:sc unsigned-reg :offset eax-offset - :from :argument :to :result) eax) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) - (:results (y :scs (double-reg))) - (:arg-types double-float) - (:result-types double-float) - (:policy :fast-safe) - (:note "inline tan function") - (:vop-var vop) - (:save-p :compute-only) - (:ignore eax) - (:generator 5 - (note-this-location vop :internal-error) - (case (tn-offset x) - (0 - (inst fstp fr1)) - (1 - (inst fstp fr0)) - (t - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :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 reduce it; ST0 is unchanged. - (inst fldpi) ; Load 2*PI - (inst fadd fr0) - (inst fxch fr1) - LOOP - (inst fprem1) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x04) ; C2 - (inst jmp :nz LOOP) - (inst fstp fr1) - (inst fptan) - DONE - ;; Result is in fr1 - (case (tn-offset y) - (0 - (inst fxch fr1)) - (1) - (t - (inst fxch fr1) - (inst fstd y))))) - -;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if -;;; the argument is out of range 2^63 and would thus be hopelessly -;;; inaccurate. -(macrolet ((frob (func trans op) - `(define-vop (,func) - (:translate ,trans) - (:args (x :scs (double-reg) :target fr0)) - (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc unsigned-reg :offset eax-offset - :from :argument :to :result) eax) - (:results (y :scs (double-reg))) - (:arg-types double-float) - (:result-types double-float) - (:policy :fast-safe) - (:note "inline sin/cos function") - (:vop-var vop) - (: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)))))) - (frob fsin %sin fsin) - (frob fcos %cos fcos)) - -(define-vop (ftan) - (:translate %tan) - (:args (x :scs (double-reg) :target fr0)) - (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc unsigned-reg :offset eax-offset - :from :argument :to :result) eax) + :from :argument :to :result) eax) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2337,95 +2211,43 @@ (note-this-location vop :internal-error) (case (tn-offset x) (0 - (inst fstp fr1)) + (inst fstp fr1)) (1 - (inst fstp fr0)) + (inst fstp fr0)) (t - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2))))) + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :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 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 fldz) ; Load 0.0 + ;; Else x was out of range so load 0.0 (inst fxch fr1) DONE ;; Result is in fr1 (case (tn-offset y) (0 - (inst fxch fr1)) + (inst fxch fr1)) (1) (t - (inst fxch fr1) - (inst fstd y))))) - -#+nil -(define-vop (fexp) - (:translate %exp) - (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) - (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) - (:temporary (:sc double-reg :offset fr2-offset - :from :argument :to :result) fr2) - (:results (y :scs (double-reg))) - (:arg-types double-float) - (:result-types double-float) - (:policy :fast-safe) - (:note "inline exp function") - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (note-this-location vop :internal-error) - (sc-case x - (double-reg - (cond ((zerop (tn-offset x)) - ;; x is in fr0 - (inst fstp fr1) - (inst fldl2e) - (inst fmul fr1)) - (t - ;; x is in a FP reg, not fr0 - (inst fstp fr0) - (inst fldl2e) - (inst fmul x)))) - ((double-stack descriptor-reg) - (inst fstp fr0) - (inst fldl2e) - (if (sc-is x double-stack) - (inst fmuld (ea-for-df-stack x)) - (inst fmuld (ea-for-df-desc x))))) - ;; Now fr0=x log2(e) - (inst fst fr1) - (inst frndint) - (inst fst fr2) - (inst fsubp-sti fr1) - (inst f2xm1) - (inst fld1) - (inst faddp-sti fr1) - (inst fscale) - (inst fld fr0) - (case (tn-offset y) - ((0 1)) - (t (inst fstd y))))) + (inst fxch fr1) + (inst fstd y))))) -;;; Modified exp that handles the following special cases: -;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN. +;;; %exp that handles the following special cases: exp(+Inf) is +Inf; +;;; exp(-Inf) is 0; exp(NaN) is NaN. (define-vop (fexp) (:translate %exp) (:args (x :scs (double-reg) :target fr0)) (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc double-reg :offset fr2-offset - :from :argument :to :result) fr2) + :from :argument :to :result) fr2) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2437,18 +2259,18 @@ (:generator 5 (note-this-location vop :internal-error) (unless (zerop (tn-offset x)) - (inst fxch x) ; x to top of stack + (inst fxch x) ; x to top of stack (unless (location= x y) - (inst fst x))) ; maybe save it + (inst fst x))) ; maybe save it ;; Check for Inf or NaN (inst fxam) (inst fnstsw) (inst sahf) - (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. - (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. - (inst and ah-tn #x02) ; Test sign of Inf. - (inst jmp :z DONE) ; +Inf gives +Inf. - (inst fstp fr0) ; -Inf gives 0 + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives 0 (inst fldz) (inst jmp-short DONE) NOINFNAN @@ -2467,7 +2289,7 @@ (inst fld fr0) DONE (unless (zerop (tn-offset y)) - (inst fstd y)))) + (inst fstd y)))) ;;; Expm1 = exp(x) - 1. ;;; Handles the following special cases: @@ -2477,11 +2299,11 @@ (:args (x :scs (double-reg) :target fr0)) (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc double-reg :offset fr2-offset - :from :argument :to :result) fr2) + :from :argument :to :result) fr2) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2493,18 +2315,18 @@ (:generator 5 (note-this-location vop :internal-error) (unless (zerop (tn-offset x)) - (inst fxch x) ; x to top of stack + (inst fxch x) ; x to top of stack (unless (location= x y) - (inst fst x))) ; maybe save it + (inst fst x))) ; maybe save it ;; Check for Inf or NaN (inst fxam) (inst fnstsw) (inst sahf) - (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. - (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. - (inst and ah-tn #x02) ; Test sign of Inf. - (inst jmp :z DONE) ; +Inf gives +Inf. - (inst fstp fr0) ; -Inf gives -1.0 + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives -1.0 (inst fld1) (inst fchs) (inst jmp-short DONE) @@ -2513,7 +2335,7 @@ (inst fstp fr2) (inst fstp fr0) (inst fldl2e) - (inst fmul fr1) ; Now fr0 = x log2(e) + (inst fmul fr1) ; Now fr0 = x log2(e) (inst fst fr1) (inst frndint) (inst fsub-sti fr1) @@ -2535,9 +2357,9 @@ (:translate %log) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2548,35 +2370,35 @@ (:generator 5 (note-this-location vop :internal-error) (sc-case x - (double-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1) - (inst fldln2) - (inst fxch fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0) - (inst fldln2) - (inst fxch fr1)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x)))))) - (inst fyl2x)) - ((double-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (if (sc-is x double-stack) - (inst fldd (ea-for-df-stack x)) - (inst fldd (ea-for-df-desc x))) - (inst fyl2x))) + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) (inst fld fr0) (case (tn-offset y) ((0 1)) @@ -2586,9 +2408,9 @@ (:translate %log10) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2599,35 +2421,35 @@ (:generator 5 (note-this-location vop :internal-error) (sc-case x - (double-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1) - (inst fldlg2) - (inst fxch fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0) - (inst fldlg2) - (inst fxch fr1)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldlg2) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x)))))) - (inst fyl2x)) - ((double-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (inst fldlg2) - (if (sc-is x double-stack) - (inst fldd (ea-for-df-stack x)) - (inst fldd (ea-for-df-desc x))) - (inst fyl2x))) + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldlg2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldlg2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) (inst fld fr0) (case (tn-offset y) ((0 1)) @@ -2636,13 +2458,13 @@ (define-vop (fpow) (:translate %pow) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) - (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) (:temporary (:sc double-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from (:argument 1) :to :result) fr1) + :from (:argument 1) :to :result) fr1) (:temporary (:sc double-reg :offset fr2-offset - :from :load :to :result) fr2) + :from :load :to :result) fr2) (:results (r :scs (double-reg))) (:arg-types double-float double-float) (:result-types double-float) @@ -2656,83 +2478,83 @@ (cond ;; x in fr0; y in fr1 ((and (sc-is x double-reg) (zerop (tn-offset x)) - (sc-is y double-reg) (= 1 (tn-offset y)))) + (sc-is y double-reg) (= 1 (tn-offset y)))) ;; y in fr1; x not in fr0 ((and (sc-is y double-reg) (= 1 (tn-offset y))) ;; Load x to fr0 (sc-case x - (double-reg - (copy-fp-reg-to-fr0 x)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc x))))) + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) ;; x in fr0; y not in fr1 ((and (sc-is x double-reg) (zerop (tn-offset x))) (inst fxch fr1) ;; Now load y to fr0 (sc-case y - (double-reg - (copy-fp-reg-to-fr0 y)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc y)))) + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) (inst fxch fr1)) ;; x in fr1; y not in fr1 ((and (sc-is x double-reg) (= 1 (tn-offset x))) ;; Load y to fr0 (sc-case y - (double-reg - (copy-fp-reg-to-fr0 y)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc y)))) + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) (inst fxch fr1)) ;; y in fr0; ((and (sc-is y double-reg) (zerop (tn-offset y))) (inst fxch fr1) ;; Now load x to fr0 (sc-case x - (double-reg - (copy-fp-reg-to-fr0 x)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc x))))) + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) ;; Neither x or y are in either fr0 or fr1 (t ;; Load y then x (inst fstp fr0) (inst fstp fr0) (sc-case y - (double-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset y) 2)))) - (double-stack - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fldd (ea-for-df-desc y)))) + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) ;; Load x to fr0 (sc-case x - (double-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))) - (double-stack - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fldd (ea-for-df-desc x)))))) + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) ;; Now have x at fr0; and y at fr1 (inst fyl2x) @@ -2753,9 +2575,9 @@ (define-vop (fscalen) (:translate %scalbn) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) - (y :scs (signed-stack signed-reg) :target temp)) + (y :scs (signed-stack signed-reg) :target temp)) (:temporary (:sc double-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1) (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) (:results (r :scs (double-reg))) @@ -2767,49 +2589,49 @@ ;; Setup x in fr0 and y in fr1 (sc-case x (double-reg - (case (tn-offset x) - (0 - (inst fstp fr1) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (inst fxch fr1)) - (1 - (inst fstp fr0) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (inst fxch fr1)) - (t - (inst fstp fr0) - (inst fstp fr0) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (inst fld (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))))) + (case (tn-offset x) + (0 + (inst fstp fr1) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (1 + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (t + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) ((double-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (if (sc-is x double-stack) - (inst fldd (ea-for-df-stack x)) - (inst fldd (ea-for-df-desc x))))) + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) (inst fscale) (unless (zerop (tn-offset r)) (inst fstd r)))) @@ -2817,11 +2639,11 @@ (define-vop (fscale) (:translate %scalb) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) - (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) (:temporary (:sc double-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from (:argument 1) :to :result) fr1) + :from (:argument 1) :to :result) fr1) (:results (r :scs (double-reg))) (:arg-types double-float double-float) (:result-types double-float) @@ -2835,96 +2657,96 @@ (cond ;; x in fr0; y in fr1 ((and (sc-is x double-reg) (zerop (tn-offset x)) - (sc-is y double-reg) (= 1 (tn-offset y)))) + (sc-is y double-reg) (= 1 (tn-offset y)))) ;; y in fr1; x not in fr0 ((and (sc-is y double-reg) (= 1 (tn-offset y))) ;; Load x to fr0 (sc-case x - (double-reg - (copy-fp-reg-to-fr0 x)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc x))))) + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) ;; x in fr0; y not in fr1 ((and (sc-is x double-reg) (zerop (tn-offset x))) (inst fxch fr1) ;; Now load y to fr0 (sc-case y - (double-reg - (copy-fp-reg-to-fr0 y)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc y)))) + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) (inst fxch fr1)) ;; x in fr1; y not in fr1 ((and (sc-is x double-reg) (= 1 (tn-offset x))) ;; Load y to fr0 (sc-case y - (double-reg - (copy-fp-reg-to-fr0 y)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc y)))) + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) (inst fxch fr1)) ;; y in fr0; ((and (sc-is y double-reg) (zerop (tn-offset y))) (inst fxch fr1) ;; Now load x to fr0 (sc-case x - (double-reg - (copy-fp-reg-to-fr0 x)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc x))))) + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) ;; Neither x or y are in either fr0 or fr1 (t ;; Load y then x (inst fstp fr0) (inst fstp fr0) (sc-case y - (double-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset y) 2)))) - (double-stack - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fldd (ea-for-df-desc y)))) + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) ;; Load x to fr0 (sc-case x - (double-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))) - (double-stack - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fldd (ea-for-df-desc x)))))) + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) ;; Now have x at fr0; and y at fr1 (inst fscale) (unless (zerop (tn-offset r)) - (inst fstd r)))) + (inst fstd r)))) (define-vop (flog1p) (:translate %log1p) (:args (x :scs (double-reg) :to :result)) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) (:results (y :scs (double-reg))) (:arg-types double-float) @@ -2937,22 +2759,22 @@ (inst fstp fr0) (inst fstp fr0) (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2))) + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))) ;; Check the range - (inst push #x3e947ae1) ; Constant 0.29 + (inst push #x3e947ae1) ; Constant 0.29 (inst fabs) (inst fld (make-ea :dword :base esp-tn)) (inst fcompp) (inst add esp-tn 4) - (inst fnstsw) ; status word to ax + (inst fnstsw) ; status word to ax (inst and ah-tn #x45) (inst jmp :z WITHIN-RANGE) ;; Out of range for fyl2xp1. (inst fld1) (inst faddd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 1))) + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) (inst fldln2) (inst fxch fr1) (inst fyl2x) @@ -2961,8 +2783,8 @@ WITHIN-RANGE (inst fldln2) (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 1))) + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) (inst fyl2xp1) DONE (inst fld fr0) @@ -2976,9 +2798,9 @@ (:translate %log1p) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2990,33 +2812,33 @@ (:generator 4 (note-this-location vop :internal-error) (sc-case x - (double-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1) - (inst fldln2) - (inst fxch fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0) - (inst fldln2) - (inst fxch fr1)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))))) - ((double-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (if (sc-is x double-stack) - (inst fldd (ea-for-df-stack x)) - (inst fldd (ea-for-df-desc x))))) + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) (inst fyl2xp1) (inst fld fr0) (case (tn-offset y) @@ -3027,9 +2849,9 @@ (:translate %logb) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -3040,42 +2862,42 @@ (:generator 5 (note-this-location vop :internal-error) (sc-case x - (double-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2)))))) - ((double-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (if (sc-is x double-stack) - (inst fldd (ea-for-df-stack x)) - (inst fldd (ea-for-df-desc x))))) + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) (inst fxtract) (case (tn-offset y) (0 - (inst fxch fr1)) + (inst fxch fr1)) (1) (t (inst fxch fr1) - (inst fstd y))))) + (inst fstd y))))) (define-vop (fatan) (:translate %atan) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from (:argument 0) :to :result) fr1) + :from (:argument 0) :to :result) fr1) (:results (r :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -3099,14 +2921,14 @@ (inst fstp fr0) (inst fstp fr0) (sc-case x - (double-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2)))) - (double-stack - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fldd (ea-for-df-desc x)))))) + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) (inst fld1) ;; Now have x at fr1; and 1.0 at fr0 (inst fpatan) @@ -3118,11 +2940,11 @@ (define-vop (fatan2) (:translate %atan2) (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1) - (y :scs (double-reg double-stack descriptor-reg) :target fr0)) + (y :scs (double-reg double-stack descriptor-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset - :from (:argument 1) :to :result) fr0) + :from (:argument 1) :to :result) fr0) (:temporary (:sc double-reg :offset fr1-offset - :from (:argument 0) :to :result) fr1) + :from (:argument 0) :to :result) fr1) (:results (r :scs (double-reg))) (:arg-types double-float double-float) (:result-types double-float) @@ -3136,83 +2958,87 @@ (cond ;; y in fr0; x in fr1 ((and (sc-is y double-reg) (zerop (tn-offset y)) - (sc-is x double-reg) (= 1 (tn-offset x)))) + (sc-is x double-reg) (= 1 (tn-offset x)))) ;; x in fr1; y not in fr0 ((and (sc-is x double-reg) (= 1 (tn-offset x))) ;; Load y to fr0 (sc-case y - (double-reg - (copy-fp-reg-to-fr0 y)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc y))))) + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y))))) + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (zerop (tn-offset x))) + ;; copy x to fr1 + (inst fst fr1)) ;; y in fr0; x not in fr1 ((and (sc-is y double-reg) (zerop (tn-offset y))) (inst fxch fr1) ;; Now load x to fr0 (sc-case x - (double-reg - (copy-fp-reg-to-fr0 x)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc x)))) + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x)))) (inst fxch fr1)) ;; y in fr1; x not in fr1 ((and (sc-is y double-reg) (= 1 (tn-offset y))) ;; Load x to fr0 (sc-case x - (double-reg - (copy-fp-reg-to-fr0 x)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc x)))) + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x)))) (inst fxch fr1)) ;; x in fr0; ((and (sc-is x double-reg) (zerop (tn-offset x))) (inst fxch fr1) ;; Now load y to fr0 (sc-case y - (double-reg - (copy-fp-reg-to-fr0 y)) - (double-stack - (inst fstp fr0) - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldd (ea-for-df-desc y))))) + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y))))) ;; Neither y or x are in either fr0 or fr1 (t ;; Load x then y (inst fstp fr0) (inst fstp fr0) (sc-case x - (double-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2)))) - (double-stack - (inst fldd (ea-for-df-stack x))) - (descriptor-reg - (inst fldd (ea-for-df-desc x)))) + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))) ;; Load y to fr0 (sc-case y - (double-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset y))))) - (double-stack - (inst fldd (ea-for-df-stack y))) - (descriptor-reg - (inst fldd (ea-for-df-desc y)))))) + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))))) ;; Now have y at fr0; and x at fr1 (inst fpatan) @@ -3231,31 +3057,31 @@ ;;; to remove the inlined alien routine def. (macrolet ((frob (func trans op) - `(define-vop (,func) - (:args (x :scs (long-reg) :target fr0)) - (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:ignore fr0) - (:results (y :scs (long-reg))) - (:arg-types long-float) - (:result-types long-float) - (:translate ,trans) - (:policy :fast-safe) - (:note "inline NPX function") - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (: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) ; clobber st0 - (cond ((zerop (tn-offset y)) - (maybe-fp-wait node)) - (t - (inst fst y))))))) + `(define-vop (,func) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline NPX function") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (: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) ; clobber st0 + (cond ((zerop (tn-offset y)) + (maybe-fp-wait node)) + (t + (inst fst y))))))) ;; Quick versions of FSIN and FCOS that require the argument to be ;; within range 2^63. @@ -3269,9 +3095,9 @@ (:translate %tan-quick) (:args (x :scs (long-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -3283,177 +3109,72 @@ (note-this-location vop :internal-error) (case (tn-offset x) (0 - (inst fstp fr1)) + (inst fstp fr1)) (1 - (inst fstp fr0)) + (inst fstp fr0)) (t - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2))))) + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) (inst fptan) ;; Result is in fr1 (case (tn-offset y) (0 - (inst fxch fr1)) - (1) - (t - (inst fxch fr1) - (inst fstd y))))) - -;;; These versions of fsin, fcos, and ftan try to use argument -;;; reduction but to do this accurately requires greater precision and -;;; it is hopelessly inaccurate. -#+nil -(macrolet ((frob (func trans op) - `(define-vop (,func) - (:translate ,trans) - (:args (x :scs (long-reg) :target fr0)) - (:temporary (:sc unsigned-reg :offset eax-offset - :from :eval :to :result) eax) - (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) - (:results (y :scs (long-reg))) - (:arg-types long-float) - (:result-types long-float) - (:policy :fast-safe) - (:note "inline sin/cos function") - (:vop-var vop) - (: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 fr1) ; Load 2*PI - (inst fldpi) - (inst fadd fr0) - (inst fxch fr1) - LOOP - (inst fprem1) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x04) ; C2 - (inst jmp :nz LOOP) - (inst ,op) - DONE - (unless (zerop (tn-offset y)) - (inst fstd y)))))) - (frob fsin %sin fsin) - (frob fcos %cos fcos)) - -#+nil -(define-vop (ftan) - (:translate %tan) - (:args (x :scs (long-reg) :target fr0)) - (:temporary (:sc unsigned-reg :offset eax-offset - :from :argument :to :result) eax) - (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) - (:results (y :scs (long-reg))) - (:arg-types long-float) - (:result-types long-float) - (:policy :fast-safe) - (:note "inline tan function") - (:vop-var vop) - (:save-p :compute-only) - (:ignore eax) - (:generator 5 - (note-this-location vop :internal-error) - (case (tn-offset x) - (0 - (inst fstp fr1)) - (1 - (inst fstp fr0)) - (t - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :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 reduce it; ST0 is unchanged. - (inst fldpi) ; Load 2*PI - (inst fadd fr0) - (inst fxch fr1) - LOOP - (inst fprem1) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x04) ; C2 - (inst jmp :nz LOOP) - (inst fstp fr1) - (inst fptan) - DONE - ;; Result is in fr1 - (case (tn-offset y) - (0 - (inst fxch fr1)) + (inst fxch fr1)) (1) (t - (inst fxch fr1) - (inst fstd y))))) + (inst fxch fr1) + (inst fstd y))))) ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if ;;; the argument is out of range 2^63 and would thus be hopelessly ;;; inaccurate. (macrolet ((frob (func trans op) - `(define-vop (,func) - (:translate ,trans) - (:args (x :scs (long-reg) :target fr0)) - (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc unsigned-reg :offset eax-offset - :from :argument :to :result) eax) - (:results (y :scs (long-reg))) - (:arg-types long-float) - (:result-types long-float) - (:policy :fast-safe) - (:note "inline sin/cos function") - (:vop-var vop) - (: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)))))) - (frob fsin %sin fsin) - (frob fcos %cos fcos)) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :argument :to :result) eax) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (: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)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) (define-vop (ftan) (:translate %tan) (:args (x :scs (long-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc unsigned-reg :offset eax-offset - :from :argument :to :result) eax) + :from :argument :to :result) eax) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -3467,31 +3188,31 @@ (note-this-location vop :internal-error) (case (tn-offset x) (0 - (inst fstp fr1)) + (inst fstp fr1)) (1 - (inst fstp fr0)) + (inst fstp fr0)) (t - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2))))) + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :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 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 fldz) ; Load 0.0 + (inst fldz) ; Load 0.0 (inst fxch fr1) DONE ;; Result is in fr1 (case (tn-offset y) (0 - (inst fxch fr1)) + (inst fxch fr1)) (1) (t - (inst fxch fr1) - (inst fstd y))))) + (inst fxch fr1) + (inst fstd y))))) ;;; Modified exp that handles the following special cases: ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN. @@ -3500,11 +3221,11 @@ (:args (x :scs (long-reg) :target fr0)) (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc long-reg :offset fr2-offset - :from :argument :to :result) fr2) + :from :argument :to :result) fr2) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -3516,18 +3237,18 @@ (: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 fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it ;; Check for Inf or NaN (inst fxam) (inst fnstsw) (inst sahf) - (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. - (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. - (inst and ah-tn #x02) ; Test sign of Inf. - (inst jmp :z DONE) ; +Inf gives +Inf. - (inst fstp fr0) ; -Inf gives 0 + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives 0 (inst fldz) (inst jmp-short DONE) NOINFNAN @@ -3546,7 +3267,7 @@ (inst fld fr0) DONE (unless (zerop (tn-offset y)) - (inst fstd y)))) + (inst fstd y)))) ;;; Expm1 = exp(x) - 1. ;;; Handles the following special cases: @@ -3556,11 +3277,11 @@ (:args (x :scs (long-reg) :target fr0)) (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc long-reg :offset fr2-offset - :from :argument :to :result) fr2) + :from :argument :to :result) fr2) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -3572,18 +3293,18 @@ (:generator 5 (note-this-location vop :internal-error) (unless (zerop (tn-offset x)) - (inst fxch x) ; x to top of stack + (inst fxch x) ; x to top of stack (unless (location= x y) - (inst fst x))) ; maybe save it + (inst fst x))) ; maybe save it ;; Check for Inf or NaN (inst fxam) (inst fnstsw) (inst sahf) - (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. - (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. - (inst and ah-tn #x02) ; Test sign of Inf. - (inst jmp :z DONE) ; +Inf gives +Inf. - (inst fstp fr0) ; -Inf gives -1.0 + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives -1.0 (inst fld1) (inst fchs) (inst jmp-short DONE) @@ -3592,7 +3313,7 @@ (inst fstp fr2) (inst fstp fr0) (inst fldl2e) - (inst fmul fr1) ; Now fr0 = x log2(e) + (inst fmul fr1) ; Now fr0 = x log2(e) (inst fst fr1) (inst frndint) (inst fsub-sti fr1) @@ -3614,9 +3335,9 @@ (:translate %log) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -3627,35 +3348,35 @@ (:generator 5 (note-this-location vop :internal-error) (sc-case x - (long-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1) - (inst fldln2) - (inst fxch fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0) - (inst fldln2) - (inst fxch fr1)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x)))))) - (inst fyl2x)) - ((long-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (if (sc-is x long-stack) - (inst fldl (ea-for-lf-stack x)) - (inst fldl (ea-for-lf-desc x))) - (inst fyl2x))) + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))) + (inst fyl2x))) (inst fld fr0) (case (tn-offset y) ((0 1)) @@ -3665,9 +3386,9 @@ (:translate %log10) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -3678,35 +3399,35 @@ (:generator 5 (note-this-location vop :internal-error) (sc-case x - (long-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1) - (inst fldlg2) - (inst fxch fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0) - (inst fldlg2) - (inst fxch fr1)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldlg2) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x)))))) - (inst fyl2x)) - ((long-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (inst fldlg2) - (if (sc-is x long-stack) - (inst fldl (ea-for-lf-stack x)) - (inst fldl (ea-for-lf-desc x))) - (inst fyl2x))) + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldlg2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldlg2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))) + (inst fyl2x))) (inst fld fr0) (case (tn-offset y) ((0 1)) @@ -3715,13 +3436,13 @@ (define-vop (fpow) (:translate %pow) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) - (y :scs (long-reg long-stack descriptor-reg) :target fr1)) + (y :scs (long-reg long-stack descriptor-reg) :target fr1)) (:temporary (:sc long-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from (:argument 1) :to :result) fr1) + :from (:argument 1) :to :result) fr1) (:temporary (:sc long-reg :offset fr2-offset - :from :load :to :result) fr2) + :from :load :to :result) fr2) (:results (r :scs (long-reg))) (:arg-types long-float long-float) (:result-types long-float) @@ -3735,83 +3456,83 @@ (cond ;; x in fr0; y in fr1 ((and (sc-is x long-reg) (zerop (tn-offset x)) - (sc-is y long-reg) (= 1 (tn-offset y)))) + (sc-is y long-reg) (= 1 (tn-offset y)))) ;; y in fr1; x not in fr0 ((and (sc-is y long-reg) (= 1 (tn-offset y))) ;; Load x to fr0 (sc-case x - (long-reg - (copy-fp-reg-to-fr0 x)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc x))))) + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) ;; x in fr0; y not in fr1 ((and (sc-is x long-reg) (zerop (tn-offset x))) (inst fxch fr1) ;; Now load y to fr0 (sc-case y - (long-reg - (copy-fp-reg-to-fr0 y)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc y)))) + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) (inst fxch fr1)) ;; x in fr1; y not in fr1 ((and (sc-is x long-reg) (= 1 (tn-offset x))) ;; Load y to fr0 (sc-case y - (long-reg - (copy-fp-reg-to-fr0 y)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc y)))) + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) (inst fxch fr1)) ;; y in fr0; ((and (sc-is y long-reg) (zerop (tn-offset y))) (inst fxch fr1) ;; Now load x to fr0 (sc-case x - (long-reg - (copy-fp-reg-to-fr0 x)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc x))))) + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) ;; Neither x or y are in either fr0 or fr1 (t ;; Load y then x (inst fstp fr0) (inst fstp fr0) (sc-case y - (long-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset y) 2)))) - (long-stack - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fldl (ea-for-lf-desc y)))) + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))) ;; Load x to fr0 (sc-case x - (long-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))) - (long-stack - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fldl (ea-for-lf-desc x)))))) + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) ;; Now have x at fr0; and y at fr1 (inst fyl2x) @@ -3832,9 +3553,9 @@ (define-vop (fscalen) (:translate %scalbn) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) - (y :scs (signed-stack signed-reg) :target temp)) + (y :scs (signed-stack signed-reg) :target temp)) (:temporary (:sc long-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1) (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) (:results (r :scs (long-reg))) @@ -3846,49 +3567,49 @@ ;; Setup x in fr0 and y in fr1 (sc-case x (long-reg - (case (tn-offset x) - (0 - (inst fstp fr1) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (inst fxch fr1)) - (1 - (inst fstp fr0) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (inst fxch fr1)) - (t - (inst fstp fr0) - (inst fstp fr0) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (inst fld (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))))) + (case (tn-offset x) + (0 + (inst fstp fr1) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (1 + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (t + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) ((long-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (sc-case y - (signed-reg - (inst mov temp y) - (inst fild temp)) - (signed-stack - (inst fild y))) - (if (sc-is x long-stack) - (inst fldl (ea-for-lf-stack x)) - (inst fldl (ea-for-lf-desc x))))) + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) (inst fscale) (unless (zerop (tn-offset r)) (inst fstd r)))) @@ -3896,11 +3617,11 @@ (define-vop (fscale) (:translate %scalb) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) - (y :scs (long-reg long-stack descriptor-reg) :target fr1)) + (y :scs (long-reg long-stack descriptor-reg) :target fr1)) (:temporary (:sc long-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from (:argument 1) :to :result) fr1) + :from (:argument 1) :to :result) fr1) (:results (r :scs (long-reg))) (:arg-types long-float long-float) (:result-types long-float) @@ -3914,96 +3635,96 @@ (cond ;; x in fr0; y in fr1 ((and (sc-is x long-reg) (zerop (tn-offset x)) - (sc-is y long-reg) (= 1 (tn-offset y)))) + (sc-is y long-reg) (= 1 (tn-offset y)))) ;; y in fr1; x not in fr0 ((and (sc-is y long-reg) (= 1 (tn-offset y))) ;; Load x to fr0 (sc-case x - (long-reg - (copy-fp-reg-to-fr0 x)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc x))))) + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) ;; x in fr0; y not in fr1 ((and (sc-is x long-reg) (zerop (tn-offset x))) (inst fxch fr1) ;; Now load y to fr0 (sc-case y - (long-reg - (copy-fp-reg-to-fr0 y)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc y)))) + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) (inst fxch fr1)) ;; x in fr1; y not in fr1 ((and (sc-is x long-reg) (= 1 (tn-offset x))) ;; Load y to fr0 (sc-case y - (long-reg - (copy-fp-reg-to-fr0 y)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc y)))) + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) (inst fxch fr1)) ;; y in fr0; ((and (sc-is y long-reg) (zerop (tn-offset y))) (inst fxch fr1) ;; Now load x to fr0 (sc-case x - (long-reg - (copy-fp-reg-to-fr0 x)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc x))))) + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) ;; Neither x or y are in either fr0 or fr1 (t ;; Load y then x (inst fstp fr0) (inst fstp fr0) (sc-case y - (long-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset y) 2)))) - (long-stack - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fldl (ea-for-lf-desc y)))) + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))) ;; Load x to fr0 (sc-case x - (long-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))) - (long-stack - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fldl (ea-for-lf-desc x)))))) + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) ;; Now have x at fr0; and y at fr1 (inst fscale) (unless (zerop (tn-offset r)) - (inst fstd r)))) + (inst fstd r)))) (define-vop (flog1p) (:translate %log1p) (:args (x :scs (long-reg) :to :result)) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) (:results (y :scs (long-reg))) (:arg-types long-float) @@ -4020,22 +3741,22 @@ (inst fstp fr0) (inst fstp fr0) (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2))) + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))) ;; Check the range - (inst push #x3e947ae1) ; Constant 0.29 + (inst push #x3e947ae1) ; Constant 0.29 (inst fabs) (inst fld (make-ea :dword :base esp-tn)) (inst fcompp) (inst add esp-tn 4) - (inst fnstsw) ; status word to ax + (inst fnstsw) ; status word to ax (inst and ah-tn #x45) (inst jmp :z WITHIN-RANGE) ;; Out of range for fyl2xp1. (inst fld1) (inst faddd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 1))) + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) (inst fldln2) (inst fxch fr1) (inst fyl2x) @@ -4044,8 +3765,8 @@ WITHIN-RANGE (inst fldln2) (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 1))) + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) (inst fyl2xp1) DONE (inst fld fr0) @@ -4059,9 +3780,9 @@ (:translate %log1p) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -4070,33 +3791,33 @@ (:note "inline log1p function") (:generator 5 (sc-case x - (long-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1) - (inst fldln2) - (inst fxch fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0) - (inst fldln2) - (inst fxch fr1)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset x))))))) - ((long-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (inst fldln2) - (if (sc-is x long-stack) - (inst fldl (ea-for-lf-stack x)) - (inst fldl (ea-for-lf-desc x))))) + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) (inst fyl2xp1) (inst fld fr0) (case (tn-offset y) @@ -4107,9 +3828,9 @@ (:translate %logb) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from :argument :to :result) fr0) + :from :argument :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from :argument :to :result) fr1) + :from :argument :to :result) fr1) (:results (y :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -4120,42 +3841,42 @@ (:generator 5 (note-this-location vop :internal-error) (sc-case x - (long-reg - (case (tn-offset x) - (0 - ;; x is in fr0 - (inst fstp fr1)) - (1 - ;; x is in fr1 - (inst fstp fr0)) - (t - ;; x is in a FP reg, not fr0 or fr1 - (inst fstp fr0) - (inst fstp fr0) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2)))))) - ((long-stack descriptor-reg) - (inst fstp fr0) - (inst fstp fr0) - (if (sc-is x long-stack) - (inst fldl (ea-for-lf-stack x)) - (inst fldl (ea-for-lf-desc x))))) + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))))) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) (inst fxtract) (case (tn-offset y) (0 - (inst fxch fr1)) + (inst fxch fr1)) (1) (t (inst fxch fr1) - (inst fstd y))))) + (inst fstd y))))) (define-vop (fatan) (:translate %atan) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from (:argument 0) :to :result) fr0) + :from (:argument 0) :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from (:argument 0) :to :result) fr1) + :from (:argument 0) :to :result) fr1) (:results (r :scs (long-reg))) (:arg-types long-float) (:result-types long-float) @@ -4179,14 +3900,14 @@ (inst fstp fr0) (inst fstp fr0) (sc-case x - (long-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2)))) - (long-stack - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fldl (ea-for-lf-desc x)))))) + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) (inst fld1) ;; Now have x at fr1; and 1.0 at fr0 (inst fpatan) @@ -4198,11 +3919,11 @@ (define-vop (fatan2) (:translate %atan2) (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1) - (y :scs (long-reg long-stack descriptor-reg) :target fr0)) + (y :scs (long-reg long-stack descriptor-reg) :target fr0)) (:temporary (:sc long-reg :offset fr0-offset - :from (:argument 1) :to :result) fr0) + :from (:argument 1) :to :result) fr0) (:temporary (:sc long-reg :offset fr1-offset - :from (:argument 0) :to :result) fr1) + :from (:argument 0) :to :result) fr1) (:results (r :scs (long-reg))) (:arg-types long-float long-float) (:result-types long-float) @@ -4216,83 +3937,83 @@ (cond ;; y in fr0; x in fr1 ((and (sc-is y long-reg) (zerop (tn-offset y)) - (sc-is x long-reg) (= 1 (tn-offset x)))) + (sc-is x long-reg) (= 1 (tn-offset x)))) ;; x in fr1; y not in fr0 ((and (sc-is x long-reg) (= 1 (tn-offset x))) ;; Load y to fr0 (sc-case y - (long-reg - (copy-fp-reg-to-fr0 y)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc y))))) + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y))))) ;; y in fr0; x not in fr1 ((and (sc-is y long-reg) (zerop (tn-offset y))) (inst fxch fr1) ;; Now load x to fr0 (sc-case x - (long-reg - (copy-fp-reg-to-fr0 x)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc x)))) + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x)))) (inst fxch fr1)) ;; y in fr1; x not in fr1 ((and (sc-is y long-reg) (= 1 (tn-offset y))) ;; Load x to fr0 (sc-case x - (long-reg - (copy-fp-reg-to-fr0 x)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc x)))) + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x)))) (inst fxch fr1)) ;; x in fr0; ((and (sc-is x long-reg) (zerop (tn-offset x))) (inst fxch fr1) ;; Now load y to fr0 (sc-case y - (long-reg - (copy-fp-reg-to-fr0 y)) - (long-stack - (inst fstp fr0) - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fstp fr0) - (inst fldl (ea-for-lf-desc y))))) + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y))))) ;; Neither y or x are in either fr0 or fr1 (t ;; Load x then y (inst fstp fr0) (inst fstp fr0) (sc-case x - (long-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (- (tn-offset x) 2)))) - (long-stack - (inst fldl (ea-for-lf-stack x))) - (descriptor-reg - (inst fldl (ea-for-lf-desc x)))) + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))) ;; Load y to fr0 (sc-case y - (long-reg - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (1- (tn-offset y))))) - (long-stack - (inst fldl (ea-for-lf-stack y))) - (descriptor-reg - (inst fldl (ea-for-lf-desc y)))))) + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))))) ;; Now have y at fr0; and x at fr1 (inst fpatan) @@ -4308,11 +4029,11 @@ (define-vop (make-complex-single-float) (:translate complex) (:args (real :scs (single-reg) :to :result :target r - :load-if (not (location= real r))) - (imag :scs (single-reg) :to :save)) + :load-if (not (location= real r))) + (imag :scs (single-reg) :to :save)) (:arg-types single-float single-float) (:results (r :scs (complex-single-reg) :from (:argument 0) - :load-if (not (sc-is r complex-single-stack)))) + :load-if (not (sc-is r complex-single-stack)))) (:result-types complex-single-float) (:note "inline complex single-float creation") (:policy :fast-safe) @@ -4320,31 +4041,31 @@ (sc-case r (complex-single-reg (let ((r-real (complex-double-reg-real-tn r))) - (unless (location= real r-real) - (cond ((zerop (tn-offset r-real)) - (copy-fp-reg-to-fr0 real)) - ((zerop (tn-offset real)) - (inst fstd r-real)) - (t - (inst fxch real) - (inst fstd r-real) - (inst fxch real))))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) (let ((r-imag (complex-double-reg-imag-tn r))) - (unless (location= imag r-imag) - (cond ((zerop (tn-offset imag)) - (inst fstd r-imag)) - (t - (inst fxch imag) - (inst fstd r-imag) - (inst fxch imag)))))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) (complex-single-stack (unless (location= real r) - (cond ((zerop (tn-offset real)) - (inst fst (ea-for-csf-real-stack r))) - (t - (inst fxch real) - (inst fst (ea-for-csf-real-stack r)) - (inst fxch real)))) + (cond ((zerop (tn-offset real)) + (inst fst (ea-for-csf-real-stack r))) + (t + (inst fxch real) + (inst fst (ea-for-csf-real-stack r)) + (inst fxch real)))) (inst fxch imag) (inst fst (ea-for-csf-imag-stack r)) (inst fxch imag))))) @@ -4352,11 +4073,11 @@ (define-vop (make-complex-double-float) (:translate complex) (:args (real :scs (double-reg) :target r - :load-if (not (location= real r))) - (imag :scs (double-reg) :to :save)) + :load-if (not (location= real r))) + (imag :scs (double-reg) :to :save)) (:arg-types double-float double-float) (:results (r :scs (complex-double-reg) :from (:argument 0) - :load-if (not (sc-is r complex-double-stack)))) + :load-if (not (sc-is r complex-double-stack)))) (:result-types complex-double-float) (:note "inline complex double-float creation") (:policy :fast-safe) @@ -4364,31 +4085,31 @@ (sc-case r (complex-double-reg (let ((r-real (complex-double-reg-real-tn r))) - (unless (location= real r-real) - (cond ((zerop (tn-offset r-real)) - (copy-fp-reg-to-fr0 real)) - ((zerop (tn-offset real)) - (inst fstd r-real)) - (t - (inst fxch real) - (inst fstd r-real) - (inst fxch real))))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) (let ((r-imag (complex-double-reg-imag-tn r))) - (unless (location= imag r-imag) - (cond ((zerop (tn-offset imag)) - (inst fstd r-imag)) - (t - (inst fxch imag) - (inst fstd r-imag) - (inst fxch imag)))))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) (complex-double-stack (unless (location= real r) - (cond ((zerop (tn-offset real)) - (inst fstd (ea-for-cdf-real-stack r))) - (t - (inst fxch real) - (inst fstd (ea-for-cdf-real-stack r)) - (inst fxch real)))) + (cond ((zerop (tn-offset real)) + (inst fstd (ea-for-cdf-real-stack r))) + (t + (inst fxch real) + (inst fstd (ea-for-cdf-real-stack r)) + (inst fxch real)))) (inst fxch imag) (inst fstd (ea-for-cdf-imag-stack r)) (inst fxch imag))))) @@ -4397,11 +4118,11 @@ (define-vop (make-complex-long-float) (:translate complex) (:args (real :scs (long-reg) :target r - :load-if (not (location= real r))) - (imag :scs (long-reg) :to :save)) + :load-if (not (location= real r))) + (imag :scs (long-reg) :to :save)) (:arg-types long-float long-float) (:results (r :scs (complex-long-reg) :from (:argument 0) - :load-if (not (sc-is r complex-long-stack)))) + :load-if (not (sc-is r complex-long-stack)))) (:result-types complex-long-float) (:note "inline complex long-float creation") (:policy :fast-safe) @@ -4409,31 +4130,31 @@ (sc-case r (complex-long-reg (let ((r-real (complex-double-reg-real-tn r))) - (unless (location= real r-real) - (cond ((zerop (tn-offset r-real)) - (copy-fp-reg-to-fr0 real)) - ((zerop (tn-offset real)) - (inst fstd r-real)) - (t - (inst fxch real) - (inst fstd r-real) - (inst fxch real))))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) (let ((r-imag (complex-double-reg-imag-tn r))) - (unless (location= imag r-imag) - (cond ((zerop (tn-offset imag)) - (inst fstd r-imag)) - (t - (inst fxch imag) - (inst fstd r-imag) - (inst fxch imag)))))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) (complex-long-stack (unless (location= real r) - (cond ((zerop (tn-offset real)) - (store-long-float (ea-for-clf-real-stack r))) - (t - (inst fxch real) - (store-long-float (ea-for-clf-real-stack r)) - (inst fxch real)))) + (cond ((zerop (tn-offset real)) + (store-long-float (ea-for-clf-real-stack r))) + (t + (inst fxch real) + (store-long-float (ea-for-clf-real-stack r)) + (inst fxch real)))) (inst fxch imag) (store-long-float (ea-for-clf-imag-stack r)) (inst fxch imag))))) @@ -4446,63 +4167,63 @@ (:policy :fast-safe) (:generator 3 (cond ((sc-is x complex-single-reg complex-double-reg - #!+long-float complex-long-reg) - (let ((value-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset (+ offset (tn-offset x))))) - (unless (location= value-tn r) - (cond ((zerop (tn-offset r)) - (copy-fp-reg-to-fr0 value-tn)) - ((zerop (tn-offset value-tn)) - (inst fstd r)) - (t - (inst fxch value-tn) - (inst fstd r) - (inst fxch value-tn)))))) - ((sc-is r single-reg) - (let ((ea (sc-case x - (complex-single-stack - (ecase offset - (0 (ea-for-csf-real-stack x)) - (1 (ea-for-csf-imag-stack x)))) - (descriptor-reg - (ecase offset - (0 (ea-for-csf-real-desc x)) - (1 (ea-for-csf-imag-desc x))))))) - (with-empty-tn@fp-top(r) - (inst fld ea)))) - ((sc-is r double-reg) - (let ((ea (sc-case x - (complex-double-stack - (ecase offset - (0 (ea-for-cdf-real-stack x)) - (1 (ea-for-cdf-imag-stack x)))) - (descriptor-reg - (ecase offset - (0 (ea-for-cdf-real-desc x)) - (1 (ea-for-cdf-imag-desc x))))))) - (with-empty-tn@fp-top(r) - (inst fldd ea)))) - #!+long-float - ((sc-is r long-reg) - (let ((ea (sc-case x - (complex-long-stack - (ecase offset - (0 (ea-for-clf-real-stack x)) - (1 (ea-for-clf-imag-stack x)))) - (descriptor-reg - (ecase offset - (0 (ea-for-clf-real-desc x)) - (1 (ea-for-clf-imag-desc x))))))) - (with-empty-tn@fp-top(r) - (inst fldl ea)))) - (t (error "COMPLEX-FLOAT-VALUE VOP failure"))))) + #!+long-float complex-long-reg) + (let ((value-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (+ offset (tn-offset x))))) + (unless (location= value-tn r) + (cond ((zerop (tn-offset r)) + (copy-fp-reg-to-fr0 value-tn)) + ((zerop (tn-offset value-tn)) + (inst fstd r)) + (t + (inst fxch value-tn) + (inst fstd r) + (inst fxch value-tn)))))) + ((sc-is r single-reg) + (let ((ea (sc-case x + (complex-single-stack + (ecase offset + (0 (ea-for-csf-real-stack x)) + (1 (ea-for-csf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-csf-real-desc x)) + (1 (ea-for-csf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fld ea)))) + ((sc-is r double-reg) + (let ((ea (sc-case x + (complex-double-stack + (ecase offset + (0 (ea-for-cdf-real-stack x)) + (1 (ea-for-cdf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-cdf-real-desc x)) + (1 (ea-for-cdf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fldd ea)))) + #!+long-float + ((sc-is r long-reg) + (let ((ea (sc-case x + (complex-long-stack + (ecase offset + (0 (ea-for-clf-real-stack x)) + (1 (ea-for-clf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-clf-real-desc x)) + (1 (ea-for-clf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fldl ea)))) + (t (error "COMPLEX-FLOAT-VALUE VOP failure"))))) (define-vop (realpart/complex-single-float complex-float-value) (:translate realpart) (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) - :target r)) + :target r)) (:arg-types complex-single-float) (:results (r :scs (single-reg))) (:result-types single-float) @@ -4512,7 +4233,7 @@ (define-vop (realpart/complex-double-float complex-float-value) (:translate realpart) (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) - :target r)) + :target r)) (:arg-types complex-double-float) (:results (r :scs (double-reg))) (:result-types double-float) @@ -4523,7 +4244,7 @@ (define-vop (realpart/complex-long-float complex-float-value) (:translate realpart) (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) - :target r)) + :target r)) (:arg-types complex-long-float) (:results (r :scs (long-reg))) (:result-types long-float) @@ -4533,7 +4254,7 @@ (define-vop (imagpart/complex-single-float complex-float-value) (:translate imagpart) (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) - :target r)) + :target r)) (:arg-types complex-single-float) (:results (r :scs (single-reg))) (:result-types single-float) @@ -4543,7 +4264,7 @@ (define-vop (imagpart/complex-double-float complex-float-value) (:translate imagpart) (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) - :target r)) + :target r)) (:arg-types complex-double-float) (:results (r :scs (double-reg))) (:result-types double-float) @@ -4554,7 +4275,7 @@ (define-vop (imagpart/complex-long-float complex-float-value) (:translate imagpart) (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) - :target r)) + :target r)) (:arg-types complex-long-float) (:results (r :scs (long-reg))) (:result-types long-float)