X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=621a1cd01256b3c27cc09b48180718fc454f30c2;hb=40e3ba03d0e1b824e4d1ae75d74246b975b70964;hp=c0d2055e36175eb2c8acb76e3ee56c48d3a129c0;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index c0d2055..621a1cd 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -12,38 +12,39 @@ (in-package "SB!VM") (macrolet ((ea-for-xf-desc (tn slot) - `(make-ea - :dword :base ,tn - :disp (- (* ,slot sb!vm:word-bytes) sb!vm:other-pointer-type)))) + `(make-ea + :dword :base ,tn + :disp (- (* ,slot n-word-bytes) + other-pointer-lowtag)))) (defun ea-for-sf-desc (tn) - (ea-for-xf-desc tn sb!vm:single-float-value-slot)) + (ea-for-xf-desc tn single-float-value-slot)) (defun ea-for-df-desc (tn) - (ea-for-xf-desc tn sb!vm:double-float-value-slot)) + (ea-for-xf-desc tn double-float-value-slot)) #!+long-float (defun ea-for-lf-desc (tn) - (ea-for-xf-desc tn sb!vm:long-float-value-slot)) + (ea-for-xf-desc tn long-float-value-slot)) ;; complex floats (defun ea-for-csf-real-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-single-float-real-slot)) + (ea-for-xf-desc tn complex-single-float-real-slot)) (defun ea-for-csf-imag-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-single-float-imag-slot)) + (ea-for-xf-desc tn complex-single-float-imag-slot)) (defun ea-for-cdf-real-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-double-float-real-slot)) + (ea-for-xf-desc tn complex-double-float-real-slot)) (defun ea-for-cdf-imag-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-double-float-imag-slot)) + (ea-for-xf-desc tn complex-double-float-imag-slot)) #!+long-float (defun ea-for-clf-real-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-long-float-real-slot)) + (ea-for-xf-desc tn complex-long-float-real-slot)) #!+long-float (defun ea-for-clf-imag-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-long-float-imag-slot))) + (ea-for-xf-desc tn complex-long-float-imag-slot))) (macrolet ((ea-for-xf-stack (tn kind) - `(make-ea - :dword :base ebp-tn - :disp (- (* (+ (tn-offset ,tn) - (ecase ,kind (:single 1) (:double 2) (:long 3))) - sb!vm:word-bytes))))) + `(make-ea + :dword :base ebp-tn + :disp (- (* (+ (tn-offset ,tn) + (ecase ,kind (:single 1) (:double 2) (:long 3))) + n-word-bytes))))) (defun ea-for-sf-stack (tn) (ea-for-xf-stack tn :single)) (defun ea-for-df-stack (tn) @@ -52,17 +53,39 @@ (defun ea-for-lf-stack (tn) (ea-for-xf-stack tn :long))) -;;; Complex float stack EAs +;;; Telling the FPU to wait is required in order to make signals occur +;;; at the expected place, but naturally slows things down. +;;; +;;; NODE is the node whose compilation policy controls the decision +;;; whether to just blast through carelessly or carefully emit wait +;;; instructions and whatnot. +;;; +;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to +;;; #'NOTE-NEXT-INSTRUCTION. +;;; +;;; 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)) + +;;; 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)))) - sb!vm:word-bytes))))) + `(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))))) (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)) @@ -85,15 +108,15 @@ ;;; ;;; Using a Pop then load. (defun copy-fp-reg-to-fr0 (reg) - (assert (not (zerop (tn-offset reg)))) + (aver (not (zerop (tn-offset reg)))) (inst fstp fr0-tn) (inst fld (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :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) - (assert (not (zerop (tn-offset reg)))) + (aver (not (zerop (tn-offset reg)))) (inst fxch reg) (inst fst reg)) @@ -107,108 +130,112 @@ ;;;; move functions -;;; x is source, y is destination -(define-move-function (load-single 2) (vop x y) +;;; X is source, Y is destination. +(define-move-fun (load-single 2) (vop x y) ((single-stack) (single-reg)) (with-empty-tn@fp-top(y) (inst fld (ea-for-sf-stack x)))) -(define-move-function (store-single 2) (vop x y) +(define-move-fun (store-single 2) (vop x y) ((single-reg) (single-stack)) (cond ((zerop (tn-offset x)) - (inst fst (ea-for-sf-stack y))) - (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-function (load-double 2) (vop x y) + (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)) (with-empty-tn@fp-top(y) (inst fldd (ea-for-df-stack x)))) -(define-move-function (store-double 2) (vop x y) +(define-move-fun (store-double 2) (vop x y) ((double-reg) (double-stack)) (cond ((zerop (tn-offset x)) - (inst fstd (ea-for-df-stack y))) - (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-function (load-long 2) (vop x y) +(define-move-fun (load-long 2) (vop x y) ((long-stack) (long-reg)) (with-empty-tn@fp-top(y) (inst fldl (ea-for-lf-stack x)))) #!+long-float -(define-move-function (store-long 2) (vop x y) +(define-move-fun (store-long 2) (vop x y) ((long-reg) (long-stack)) (cond ((zerop (tn-offset x)) - (store-long-float (ea-for-lf-stack y))) - (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 reduce the size of the constant vector (CV). -;;; Intel claims they are stored in a more precise form on chip. -;;; Anyhow, might as well use the feature. It can be turned -;;; off by hacking the "immediate-constant-sc" in vm.lisp. -(define-move-function (load-fp-constant 2) (vop x y) + (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 +;;; reduce the size of the constant vector (CV). Intel claims they are +;;; stored in a more precise form on chip. Anyhow, might as well use +;;; the feature. It can be turned off by hacking the +;;; "immediate-constant-sc" in vm.lisp. +(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)))) (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)))))) - + (inst fldz)) + ((= value 1e0) + (inst fld1)) + ((= value (coerce pi *read-default-float-format*)) + (inst fldpi)) + ((= value (log 10e0 2e0)) + (inst fldl2t)) + ((= value (log 2.718281828459045235360287471352662e0 2e0)) + (inst fldl2e)) + ((= value (log 2e0 10e0)) + (inst fldlg2)) + ((= value (log 2e0 2.718281828459045235360287471352662e0)) + (inst fldln2)) + (t (warn "ignoring bogus i387 constant ~A" 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-function (load-complex-single 2) (vop x y) +;;; X is source, Y is destination. +(define-move-fun (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) (let ((real-tn (complex-single-reg-real-tn y))) (with-empty-tn@fp-top (real-tn) @@ -217,21 +244,21 @@ (with-empty-tn@fp-top (imag-tn) (inst fld (ea-for-csf-imag-stack x))))) -(define-move-function (store-complex-single 2) (vop x y) +(define-move-fun (store-complex-single 2) (vop x y) ((complex-single-reg) (complex-single-stack)) (let ((real-tn (complex-single-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) - (inst fst (ea-for-csf-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)) (inst fxch imag-tn))) -(define-move-function (load-complex-double 2) (vop x y) +(define-move-fun (load-complex-double 2) (vop x y) ((complex-double-stack) (complex-double-reg)) (let ((real-tn (complex-double-reg-real-tn y))) (with-empty-tn@fp-top(real-tn) @@ -240,22 +267,22 @@ (with-empty-tn@fp-top(imag-tn) (inst fldd (ea-for-cdf-imag-stack x))))) -(define-move-function (store-complex-double 2) (vop x y) +(define-move-fun (store-complex-double 2) (vop x y) ((complex-double-reg) (complex-double-stack)) (let ((real-tn (complex-double-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) - (inst 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)) (inst fxch imag-tn))) #!+long-float -(define-move-function (load-complex-long 2) (vop x y) +(define-move-fun (load-complex-long 2) (vop x y) ((complex-long-stack) (complex-long-reg)) (let ((real-tn (complex-long-reg-real-tn y))) (with-empty-tn@fp-top(real-tn) @@ -265,15 +292,15 @@ (inst fldl (ea-for-clf-imag-stack x))))) #!+long-float -(define-move-function (store-complex-long 2) (vop x y) +(define-move-fun (store-complex-long 2) (vop x y) ((complex-long-reg) (complex-long-stack)) (let ((real-tn (complex-long-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) - (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)) @@ -282,21 +309,21 @@ ;;;; move VOPs -;;; Float register to register moves. +;;; float register to register moves (define-vop (float-move) (:args (x)) (:results (y)) (: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)))) @@ -325,31 +352,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)) @@ -357,7 +384,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 @@ -372,10 +399,10 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:single-float-type - sb!vm:single-float-size node) + single-float-widetag + single-float-size node) (with-tn@fp-top(x) - (inst fst (ea-for-sf-desc y)))))) + (inst fst (ea-for-sf-desc y)))))) (define-move-vop move-from-single :move (single-reg) (descriptor-reg)) @@ -386,11 +413,11 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:double-float-type - sb!vm: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)) @@ -402,11 +429,11 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:long-float-type - sb!vm: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)) @@ -416,8 +443,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 @@ -430,16 +457,16 @@ (#.(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)) -;;; Move from a descriptor to a float register +;;; Move from a descriptor to a float register. (define-vop (move-to-single) (:args (x :scs (descriptor-reg))) (:results (y :scs (single-reg))) @@ -468,7 +495,6 @@ (inst fldl (ea-for-lf-desc x))))) #!+long-float (define-move-vop move-to-long :move (descriptor-reg) (long-reg)) - ;;; Move from complex float to a descriptor reg. allocating a new ;;; complex float object in the process. @@ -479,14 +505,15 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:complex-single-float-type - sb!vm:complex-single-float-size node) + complex-single-float-widetag + complex-single-float-size + node) (let ((real-tn (complex-single-reg-real-tn x))) - (with-tn@fp-top(real-tn) - (inst fst (ea-for-csf-real-desc y)))) + (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-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)) @@ -497,15 +524,15 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:complex-double-float-type - sb!vm: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)) @@ -517,184 +544,183 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:complex-long-float-type - sb!vm: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 +;;; 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. +;;;; the move argument vops ;;;; -;;;; Note these are also used to stuff fp numbers onto the c-call stack -;;;; so the order is different than the lisp-stack. +;;;; Note these are also used to stuff fp numbers onto the c-call +;;;; stack so the order is different than the lisp-stack. -;;; The general move-argument vop +;;; the general MOVE-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) 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))) - sb!vm: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-argument - (,sc descriptor-reg) (,sc))))) - (frob move-single-float-argument single-reg single-stack :single) - (frob move-double-float-argument double-reg double-stack :double) + `(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))))) + (frob move-single-float-arg single-reg single-stack :single) + (frob move-double-float-arg double-reg double-stack :double) #!+long-float - (frob move-long-float-argument long-reg long-stack :long)) + (frob move-long-float-arg long-reg long-stack :long)) -;;;; Complex float move-argument vop +;;;; 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-argument - (,sc descriptor-reg) (,sc))))) - (frob move-complex-single-float-argument - complex-single-reg complex-single-stack :single) - (frob move-complex-double-float-argument - complex-double-reg complex-double-stack :double) + `(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) + (frob move-complex-double-float-arg + complex-double-reg complex-double-stack :double) #!+long-float - (frob move-complex-long-float-argument - complex-long-reg complex-long-stack :long)) + (frob move-complex-long-float-arg + complex-long-reg complex-long-stack :long)) -(define-move-vop move-argument :move-argument +(define-move-vop move-arg :move-arg (single-reg double-reg #!+long-float long-reg complex-single-reg complex-double-reg #!+long-float complex-long-reg) (descriptor-reg)) @@ -702,7 +728,7 @@ ;;;; arithmetic VOPs -;;; dtc: The floating point arithmetic vops. +;;; dtc: the floating point arithmetic vops ;;; ;;; Note: Although these can accept x and y on the stack or pointed to ;;; from a descriptor register, they will work with register loading @@ -719,443 +745,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))) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst wait))) - ;; 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))) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst wait))) - ;; 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)) - (when (policy node (or (= debug 3) (> safety speed))) - (inst wait))) - (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))) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst wait))) - ;; 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))) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst wait))) - ;; 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)) - (when (policy node (or (= debug 3) (> safety speed))) - (inst wait))) - (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))) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst wait))) - ;; 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))) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst wait))) - ;; 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)) - (when (policy node (or (= debug 3) (> safety speed))) - (inst wait))) - (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) @@ -1197,35 +1208,34 @@ (inst fxch x) (inst fucom y) (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 (inst cmp ah-tn #x40) (inst jmp (if not-p :ne :e) target))) (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) @@ -1372,48 +1382,48 @@ (:note "inline float comparison") (:ignore temp) (:generator 3 - ;; Handle a few special cases + ;; Handle a few special cases. (cond ;; y is ST0. ((and (sc-is y single-reg) (zerop (tn-offset y))) (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)) - ;; General case when y is not in ST0. + ;; general case when y is not in ST0 (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 + (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))) (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) @@ -1423,41 +1433,41 @@ (:note "inline float comparison") (:ignore temp) (:generator 3 - ;; Handle a few special cases + ;; Handle a few special cases. (cond ;; y is ST0. ((and (sc-is y double-reg) (zerop (tn-offset y))) (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)) - ;; General case when y is not in ST0. + ;; general case when y is not in ST0 (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 + (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))) @@ -1465,7 +1475,7 @@ (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) @@ -1478,13 +1488,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. @@ -1492,7 +1502,7 @@ (inst fxch x) (inst fcomd y) (inst fxch x) - (inst fnstsw) ; status word to ax + (inst fnstsw) ; status word to ax (inst and ah-tn #x45))) (inst jmp (if not-p :ne :e) target))) @@ -1520,233 +1530,206 @@ (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 cmp ah-tn code)) (inst jmp (if not-p :ne :e) target))) (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 (frob %long-float/unsigned %long-float long-reg long-float)) -;;; These should be no-ops but the compiler might want to move -;;; some things around +;;; These should be no-ops but the compiler might want to move some +;;; things around. (macrolet ((frob (name translate from-sc from-type to-sc to-type) - `(define-vop (,name) - (:args (x :scs (,from-sc) :target y)) - (: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 @@ -1757,43 +1740,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 @@ -1805,11 +1788,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) @@ -1820,25 +1803,25 @@ (:generator 4 (sc-case res (single-stack - (sc-case bits - (signed-reg - (inst mov res bits)) - (signed-stack - (assert (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) @@ -1851,14 +1834,14 @@ (storew hi-bits ebp-tn (- offset)) (storew lo-bits ebp-tn (- (1+ offset))) (with-empty-tn@fp-top(res) - (inst fldd (make-ea :dword :base ebp-tn - :disp (- (* (1+ offset) word-bytes)))))))) + (inst fldd (make-ea :dword :base ebp-tn + :disp (- (* (1+ offset) n-word-bytes)))))))) #!+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) @@ -1872,12 +1855,12 @@ (storew hi-bits ebp-tn (- (1+ offset))) (storew lo-bits ebp-tn (- (+ offset 2))) (with-empty-tn@fp-top(res) - (inst fldl (make-ea :dword :base ebp-tn - :disp (- (* (+ offset 2) word-bytes)))))))) + (inst fldl (make-ea :dword :base ebp-tn + :disp (- (* (+ offset 2) n-word-bytes)))))))) (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) @@ -1889,25 +1872,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 sb!vm:single-float-value-slot - sb!vm:other-pointer-type)))) + (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) @@ -1918,21 +1901,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)) - 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 (- (* (+ 2 (tn-offset temp)) + n-word-bytes))))) + (inst fstd where))) + (loadw hi-bits ebp-tn (- (1+ (tn-offset temp))))) (double-stack - (loadw hi-bits ebp-tn (- (1+ (tn-offset float))))) + (loadw hi-bits ebp-tn (- (1+ (tn-offset float))))) (descriptor-reg - (loadw hi-bits float (1+ sb!vm:double-float-value-slot) - sb!vm:other-pointer-type))))) + (loadw hi-bits float (1+ double-float-value-slot) + other-pointer-lowtag))))) (define-vop (double-float-low-bits) (:args (float :scs (double-reg descriptor-reg) - :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) @@ -1943,22 +1926,22 @@ (: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)) - 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 (- (* (+ 2 (tn-offset temp)) + n-word-bytes))))) + (inst fstd where))) + (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp))))) (double-stack - (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float))))) + (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float))))) (descriptor-reg - (loadw lo-bits float sb!vm:double-float-value-slot - sb!vm:other-pointer-type))))) + (loadw lo-bits float double-float-value-slot + other-pointer-lowtag))))) #!+long-float (define-vop (long-float-exp-bits) (: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) @@ -1969,29 +1952,29 @@ (: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)) - word-bytes))))) - (store-long-float where))) - (inst movsx exp-bits - (make-ea :word :base ebp-tn - :disp (* (- (1+ (tn-offset temp))) word-bytes)))) + (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)))) (long-stack - (inst movsx exp-bits - (make-ea :word :base ebp-tn - :disp (* (- (1+ (tn-offset float))) word-bytes)))) + (inst movsx exp-bits + (make-ea :word :base ebp-tn + :disp (* (- (1+ (tn-offset float))) n-word-bytes)))) (descriptor-reg - (inst movsx exp-bits - (make-ea :word :base float - :disp (- (* (+ 2 sb!vm:long-float-value-slot) - word-bytes) - sb!vm:other-pointer-type))))))) + (inst movsx exp-bits + (make-ea :word :base float + :disp (- (* (+ 2 long-float-value-slot) + n-word-bytes) + other-pointer-lowtag))))))) #!+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) @@ -2002,22 +1985,22 @@ (: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)) - 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 (- (* (+ 3 (tn-offset temp)) + n-word-bytes))))) + (store-long-float where))) + (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2)))) (long-stack - (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2)))) + (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2)))) (descriptor-reg - (loadw hi-bits float (1+ sb!vm:long-float-value-slot) - sb!vm:other-pointer-type))))) + (loadw hi-bits float (1+ long-float-value-slot) + other-pointer-lowtag))))) #!+long-float (define-vop (long-float-low-bits) (: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) @@ -2028,17 +2011,17 @@ (: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)) - 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 (- (* (+ 3 (tn-offset temp)) + n-word-bytes))))) + (store-long-float where))) + (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3)))) (long-stack - (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3)))) + (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3)))) (descriptor-reg - (loadw lo-bits float sb!vm:long-float-value-slot - sb!vm:other-pointer-type))))) + (loadw lo-bits float long-float-value-slot + other-pointer-lowtag))))) ;;;; float mode hackery @@ -2047,9 +2030,9 @@ (defknown ((setf floating-point-modes)) (float-modes) float-modes) -(defconstant npx-env-size (* 7 sb!vm: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))) @@ -2057,18 +2040,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 - ;; Current status to high word + (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state. + ;; Move current status to high word. (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2))) - ;; Exception mask to low word + ;; Move exception mask to low word. (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset)) - (inst add esp-tn npx-env-size) ; Pop stack - (inst xor eax #x3f) ; Flip exception mask to trap enable bits + (inst add esp-tn npx-env-size) ; Pop stack. + (inst xor eax #x3f) ; Flip exception mask to trap enable bits. (move res eax))) (define-vop (set-floating-point-modes) @@ -2079,18 +2062,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 @@ -2102,32 +2085,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)) - (when (policy node (or (= debug 3) (> safety speed))) - (inst wait))) - (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. @@ -2141,98 +2123,9 @@ (:translate %tan-quick) (: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) - (: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) - (: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) - ;; 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 (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)) - -#+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) + :from :argument :to :result) fr1) (:results (y :scs (double-reg))) (:arg-types double-float) (:result-types double-float) @@ -2240,92 +2133,76 @@ (: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)) + (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 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 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) - 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. +;;; 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 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 (,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) + :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) @@ -2339,95 +2216,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) @@ -2439,18 +2264,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 @@ -2469,7 +2294,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: @@ -2479,11 +2304,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) @@ -2495,18 +2320,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) @@ -2515,7 +2340,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) @@ -2537,9 +2362,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) @@ -2550,35 +2375,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)) @@ -2588,9 +2413,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) @@ -2601,35 +2426,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)) @@ -2638,13 +2463,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) @@ -2658,83 +2483,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) @@ -2755,9 +2580,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))) @@ -2769,49 +2594,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)))) @@ -2819,11 +2644,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) @@ -2837,107 +2662,101 @@ (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) (:result-types double-float) (:policy :fast-safe) - ;; FIXME: PENTIUM isn't used on the *FEATURES* list of the CMU CL I based - ;; SBCL on, even when it is running on a Pentium. Find out what's going - ;; on here and see what the proper value should be. (Perhaps just use the - ;; apparently-conservative value of T always?) For more confusion, see also - ;; apparently-reversed-sense test for the FLOG1P-PENTIUM vop below. - (:guard #!+pentium nil #!-pentium t) (:note "inline log1p function") (:ignore temp) (:generator 5 @@ -2945,22 +2764,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) @@ -2969,8 +2788,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) @@ -2984,48 +2803,47 @@ (: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) (:policy :fast-safe) - ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above. - (:guard #!+pentium t #!-pentium nil) + (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*)) (:note "inline log1p with limited x range function") (:vop-var vop) (:save-p :compute-only) - (:generator 5 + (:generator 4 (note-this-location vop :internal-error) (sc-case x - (double-reg - (case (tn-offset 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) @@ -3036,9 +2854,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) @@ -3049,42 +2867,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) @@ -3108,14 +2926,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) @@ -3127,11 +2945,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) @@ -3145,83 +2963,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) @@ -3229,11 +3051,8 @@ (case (tn-offset r) ((0 1)) (t (inst fstd r))))) - -) ; progn #!-long-float - +) ; PROGN #!-LONG-FLOAT - #!+long-float (progn @@ -3243,34 +3062,33 @@ ;;; 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)) - (when (policy node (or (= debug 3) (> safety speed))) - (inst wait))) - (t - (inst fst y))))))) - - ;; Quick versions of fsin and fcos that require the argument to be + `(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. (frob fsin-quick %sin-quick fsin) (frob fcos-quick %cos-quick fcos) @@ -3282,98 +3100,9 @@ (:translate %tan-quick) (:args (x :scs (long-reg) :target fr0)) (: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) - (: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) - ;; 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) + :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) @@ -3381,92 +3110,76 @@ (: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)) + (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 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) @@ -3480,31 +3193,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. @@ -3513,11 +3226,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) @@ -3529,18 +3242,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 @@ -3559,7 +3272,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: @@ -3569,11 +3282,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) @@ -3585,18 +3298,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) @@ -3605,7 +3318,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) @@ -3627,9 +3340,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) @@ -3640,35 +3353,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)) @@ -3678,9 +3391,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) @@ -3691,35 +3404,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)) @@ -3728,13 +3441,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) @@ -3748,83 +3461,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) @@ -3845,9 +3558,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))) @@ -3859,49 +3572,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)))) @@ -3909,11 +3622,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) @@ -3927,96 +3640,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) @@ -4026,8 +3739,6 @@ ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around ;; an enormous PROGN above. Still, it would be probably be good to ;; add some code to warn about redefining VOPs. - ;; FIXME 2: See comments on DEFINE-VOP FLOG1P :GUARD above. - (:guard #!+pentium nil #!-pentium t) (:note "inline log1p function") (:ignore temp) (:generator 5 @@ -4035,22 +3746,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) @@ -4059,8 +3770,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) @@ -4074,45 +3785,44 @@ (: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) (:policy :fast-safe) - ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above. - (:guard #!+pentium t #!-pentium) + (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*)) (: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) @@ -4123,9 +3833,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) @@ -4136,42 +3846,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) @@ -4195,14 +3905,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) @@ -4214,11 +3924,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) @@ -4232,83 +3942,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) @@ -4317,19 +4027,18 @@ ((0 1)) (t (inst fstd r))))) -) ; progn #!+long-float - +) ; PROGN #!+LONG-FLOAT -;;;; Complex float VOPs +;;;; complex float VOPs (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) @@ -4337,31 +4046,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))))) @@ -4369,11 +4078,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) @@ -4381,31 +4090,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))))) @@ -4414,11 +4123,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) @@ -4426,31 +4135,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))))) @@ -4463,63 +4172,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) @@ -4529,7 +4238,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) @@ -4540,7 +4249,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) @@ -4550,7 +4259,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) @@ -4560,7 +4269,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) @@ -4571,18 +4280,16 @@ (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) (:note "complex float imagpart") (:variant 1)) - -;;; A hack dummy VOP to bias the representation selection of its -;;; argument towards a FP register which can help avoid consing at -;;; inappropriate locations. - +;;; hack dummy VOPs to bias the representation selection of their +;;; arguments towards a FP register, which can help avoid consing at +;;; inappropriate locations (defknown double-float-reg-bias (double-float) (values)) (define-vop (double-float-reg-bias) (:translate double-float-reg-bias) @@ -4592,7 +4299,6 @@ (:note "inline dummy FP register bias") (:ignore x) (:generator 0)) - (defknown single-float-reg-bias (single-float) (values)) (define-vop (single-float-reg-bias) (:translate single-float-reg-bias)