diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp index 565786145c59167465804e544e7fefdc0fa92e3c..1e99e139f657f29f594adfb88c6ddde7bb992e28 100644 --- a/compiler/x86/array.lisp +++ b/compiler/x86/array.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.12 1998/03/03 17:35:25 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.13 1998/03/21 07:54:36 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -489,6 +489,121 @@ (inst fxch value))))))) +#+long-float +(define-vop (data-vector-ref/simple-array-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-long-float positive-fixnum) + (:temporary (:sc any-reg :from :eval :to :result) temp) + (:results (value :scs (long-reg))) + (:result-types long-float) + (:generator 7 + ;; temp = 3 * index + (inst lea temp (make-ea :dword :base index :index index :scale 2)) + (with-empty-tn@fp-top(value) + (inst fldl (make-ea :dword :base object :index temp :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))))) + +#+long-float +(define-vop (data-vector-ref-c/simple-array-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-long-float (:constant (signed-byte 30))) + (:results (value :scs (long-reg))) + (:result-types long-float) + (:generator 6 + (with-empty-tn@fp-top(value) + (inst fldl (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 12 index)) + vm:other-pointer-type)))))) + +#+long-float +(define-vop (data-vector-set/simple-array-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (long-reg) :target result)) + (:arg-types simple-array-long-float positive-fixnum long-float) + (:temporary (:sc any-reg :from (:argument 1) :to :result) temp) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:generator 20 + ;; temp = 3 * index + (inst lea temp (make-ea :dword :base index :index index :scale 2)) + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (store-long-float + (make-ea :dword :base object :index temp :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (store-long-float + (make-ea :dword :base object :index temp :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + +#+long-float +(define-vop (data-vector-set-c/simple-array-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (long-reg) :target result)) + (:info index) + (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:generator 19 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (store-long-float (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 12 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (store-long-float (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 12 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + ;;; Complex float variants. #+complex-float (progn @@ -784,6 +899,162 @@ (inst fxch value-imag)))) +#+long-float +(define-vop (data-vector-ref/simple-array-complex-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-long-float positive-fixnum) + (:temporary (:sc any-reg :from :eval :to :result) temp) + (:results (value :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 7 + ;; temp = 3 * index + (inst lea temp (make-ea :dword :base index :index index :scale 2)) + (let ((real-tn (complex-long-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldl (make-ea :dword :base object :index temp :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))))) + (let ((imag-tn (complex-long-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldl (make-ea :dword :base object :index temp :scale 2 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 12) + vm:other-pointer-type))))))) + +#+long-float +(define-vop (data-vector-ref-c/simple-array-complex-long-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))) + (:results (value :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 6 + (let ((real-tn (complex-long-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldl (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index)) + vm:other-pointer-type))))) + (let ((imag-tn (complex-long-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldl (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index) 12) + vm:other-pointer-type))))))) + +#+long-float +(define-vop (data-vector-set/simple-array-complex-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-long-reg) :target result)) + (:arg-types simple-array-complex-long-float positive-fixnum + complex-long-float) + (:temporary (:sc any-reg :from (:argument 1) :to :result) temp) + (:results (result :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 20 + ;; temp = 3 * index + (inst lea temp (make-ea :dword :base index :index index :scale 2)) + (let ((value-real (complex-long-reg-real-tn value)) + (result-real (complex-long-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (store-long-float + (make-ea :dword :base object :index temp :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (store-long-float + (make-ea :dword :base object :index temp :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-long-reg-imag-tn value)) + (result-imag (complex-long-reg-imag-tn result))) + (inst fxch value-imag) + (store-long-float + (make-ea :dword :base object :index temp :scale 2 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) 12) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + +#+long-float +(define-vop (data-vector-set-c/simple-array-complex-long-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-long-reg) :target result)) + (:info index) + (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)) + complex-long-float) + (:results (result :scs (complex-long-reg))) + (:result-types complex-long-float) + (:generator 19 + (let ((value-real (complex-long-reg-real-tn value)) + (result-real (complex-long-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0 + (store-long-float + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index)) + vm:other-pointer-type))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (store-long-float + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index)) + vm:other-pointer-type))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-long-reg-imag-tn value)) + (result-imag (complex-long-reg-imag-tn result))) + (inst fxch value-imag) + (store-long-float + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 24 index) 12) + vm:other-pointer-type))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + ) ; complex-float @@ -1201,6 +1472,25 @@ (:translate %raw-set-double) (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) double-float)) +;;; +#+long-float +(define-vop (raw-ref-long data-vector-ref/simple-array-long-float) + (:translate %raw-ref-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +#+long-float +(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float) + (:translate %raw-ref-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +#+long-float +(define-vop (raw-set-double data-vector-set/simple-array-long-float) + (:translate %raw-set-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float)) +#+long-float +(define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float) + (:translate %raw-set-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + long-float)) ;;;; Complex-float raw structure slot accessors. #+complex-float @@ -1244,6 +1534,30 @@ (:translate %raw-set-complex-double) (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) complex-double-float)) +;;; +#+long-float +(define-vop (raw-ref-complex-long + data-vector-ref/simple-array-complex-long-float) + (:translate %raw-ref-complex-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +#+long-float +(define-vop (raw-ref-complex-long-c + data-vector-ref-c/simple-array-complex-long-float) + (:translate %raw-ref-complex-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)))) +;;; +#+long-float +(define-vop (raw-set-complex-long + data-vector-set/simple-array-complex-long-float) + (:translate %raw-set-complex-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-long-float)) +#+long-float +(define-vop (raw-set-complex-long-c + data-vector-set-c/simple-array-complex-long-float) + (:translate %raw-set-complex-long) + (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30)) + complex-long-float)) ) ; end progn complex-float diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp index b5cc4419442315665c87e148ad51b04a116b5120..3d88124169419100f3503362ec78d258a602f985 100644 --- a/compiler/x86/c-call.lisp +++ b/compiler/x86/c-call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.7 1998/02/19 19:34:44 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.8 1998/03/21 07:54:37 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,7 +17,7 @@ ;;; Written by William Lott. ;;; ;;; Debugged by Paul F. Werkowski Spring/Summer 1995. -;;; Debugging and Enhancements by Douglas Crosher 1996,1997. +;;; Debugging and Enhancements by Douglas Crosher 1996,1997,1998. ;;; (in-package :x86) @@ -55,6 +55,13 @@ 'sap-stack stack-frame-size))) +#+long-float +(def-alien-type-method (long-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3)) + (my-make-wired-tn 'long-float 'long-stack stack-frame-size))) + (def-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state))) @@ -92,6 +99,13 @@ (my-make-wired-tn 'system-area-pointer 'sap-reg (result-reg-offset num-results)))) +#+long-float +(def-alien-type-method (long-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'long-float 'long-reg (* num-results 2)))) + (def-alien-type-method (double-float :result-tn) (type state) (declare (ignore type)) (let ((num-results (result-state-num-results state))) diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp index bec9ece286c0f5e3e05edca8a61eadcddda25ac5..2048a58b21b141782d8c199ea9ed3d56c464b864 100644 --- a/compiler/x86/float.lisp +++ b/compiler/x86/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.25 1998/03/11 17:33:58 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.26 1998/03/21 07:54:38 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,7 +17,7 @@ ;;; ;;; Debugged by Paul F. Werkowski Spring/Summer 1995. ;;; -;;; Rewrite, enhancements, complex-float support by +;;; Rewrite, enhancements, complex-float and long-float support by ;;; Douglas Crosher, 1996, 1997, 1998. ;;; @@ -32,6 +32,9 @@ (ea-for-xf-desc tn vm:single-float-value-slot)) (defun ea-for-df-desc (tn) (ea-for-xf-desc tn vm:double-float-value-slot)) + #+long-float + (defun ea-for-lf-desc (tn) + (ea-for-xf-desc tn vm:long-float-value-slot)) ;; Complex floats #+complex-float (defun ea-for-csf-real-desc (tn) @@ -44,7 +47,13 @@ (ea-for-xf-desc tn vm:complex-double-float-real-slot)) #+complex-float (defun ea-for-cdf-imag-desc (tn) - (ea-for-xf-desc tn vm:complex-double-float-imag-slot))) + (ea-for-xf-desc tn vm:complex-double-float-imag-slot)) + #+(and long-float complex-float) + (defun ea-for-clf-real-desc (tn) + (ea-for-xf-desc tn vm:complex-long-float-real-slot)) + #+(and long-float complex-float) + (defun ea-for-clf-imag-desc (tn) + (ea-for-xf-desc tn vm:complex-long-float-imag-slot))) (macrolet ((ea-for-xf-stack (tn kind) `(make-ea @@ -55,7 +64,10 @@ (defun ea-for-sf-stack (tn) (ea-for-xf-stack tn :single)) (defun ea-for-df-stack (tn) - (ea-for-xf-stack tn :double))) + (ea-for-xf-stack tn :double)) + #+long-float + (defun ea-for-lf-stack (tn) + (ea-for-xf-stack tn :long))) ;;; Complex float stack EAs #+complex-float @@ -77,7 +89,14 @@ (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn)) (ea-for-cxf-stack tn :double :real base)) (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn)) - (ea-for-cxf-stack tn :double :imag base))) + (ea-for-cxf-stack tn :double :imag base)) + ;; + #+long-float + (defun ea-for-clf-real-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :long :real base)) + #+long-float + (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :long :imag base))) ;;; Abstract out the copying of a FP register to the FP stack top, and ;;; provide two alternatives for its implementation. Note: it's not @@ -99,6 +118,14 @@ (inst fxch reg) (inst fst reg)) +;;; The x86 can't store a long-float to memory without popping the +;;; stack and marking a register as empty, so it is necessary to +;;; restore the register from memory. +#+long-float +(defun store-long-float (ea) + (inst fstpl ea) + (inst fldl ea)) + ;;;; Move functions: @@ -133,6 +160,23 @@ ;; 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) + ((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) + ((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). @@ -140,13 +184,23 @@ ;;; 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) - ((fp-constant) (single-reg double-reg)) + ((fp-constant) (single-reg double-reg #+long-float long-reg)) (let ((value (c::constant-value (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)))))) @@ -168,6 +222,15 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) :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 *backend*) + :offset (tn-offset x))) +#+long-float +(defun complex-long-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) + :offset (1+ (tn-offset x)))) + ;;; x is source, y is destination (define-move-function (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) @@ -214,6 +277,32 @@ (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) + ((complex-long-stack) (complex-long-reg)) + (let ((real-tn (complex-long-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldl (ea-for-clf-real-stack x)))) + (let ((imag-tn (complex-long-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldl (ea-for-clf-imag-stack x))))) + +#+long-float +(define-move-function (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)))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (inst fxch imag-tn) + (store-long-float (ea-for-clf-imag-stack y)) + (inst fxch imag-tn))) + ) ; complex-float @@ -247,6 +336,13 @@ (:results (y :scs (double-reg) :load-if (not (location= x y))))) (define-move-vop double-move :move (double-reg) (double-reg)) +#+long-float +(define-vop (long-move float-move) + (:args (x :scs (long-reg) :target y :load-if (not (location= x y)))) + (:results (y :scs (long-reg) :load-if (not (location= x y))))) +#+long-float +(define-move-vop long-move :move (long-reg) (long-reg)) + #+complex-float (progn ;;; @@ -289,6 +385,16 @@ (: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)) + +#+long-float +(define-vop (complex-long-move complex-float-move) + (:args (x :scs (complex-long-reg) + :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 + (complex-long-reg) (complex-long-reg)) + ) ; complex-float @@ -320,6 +426,20 @@ (define-move-vop move-from-double :move (double-reg) (descriptor-reg)) +#+long-float +(define-vop (move-from-long) + (:args (x :scs (long-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:long-float-type vm:long-float-size node) + (with-tn@fp-top(x) + (store-long-float (ea-for-lf-desc y)))))) +#+long-float +(define-move-vop move-from-long :move + (long-reg) (descriptor-reg)) + (define-vop (move-from-fp-constant) (:args (x :scs (fp-constant))) (:results (y :scs (descriptor-reg))) @@ -328,7 +448,23 @@ (0f0 (load-symbol-value y *fp-constant-0s0*)) (1f0 (load-symbol-value y *fp-constant-1s0*)) (0d0 (load-symbol-value y *fp-constant-0d0*)) - (1d0 (load-symbol-value y *fp-constant-1d0*))))) + (1d0 (load-symbol-value y *fp-constant-1d0*)) + #+long-float + (0l0 (load-symbol-value y *fp-constant-0l0*)) + #+long-float + (1l0 (load-symbol-value y *fp-constant-1l0*)) + #+long-float + (#.pi (load-symbol-value y *fp-constant-pi*)) + #+long-float + (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*)) + #+long-float + (#.(log 2.718281828459045235360287471352662L0 2l0) + (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*))))) (define-move-vop move-from-fp-constant :move (fp-constant) (descriptor-reg)) @@ -353,6 +489,17 @@ (inst fldd (ea-for-df-desc x))))) (define-move-vop move-to-double :move (descriptor-reg) (double-reg)) +#+long-float +(define-vop (move-to-long) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (long-reg))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + (inst fldl (ea-for-lf-desc x))))) +#+long-float +(define-move-vop move-to-long :move (descriptor-reg) (long-reg)) + #+complex-float (progn @@ -394,6 +541,25 @@ (define-move-vop move-from-complex-double :move (complex-double-reg) (descriptor-reg)) +#+long-float +(define-vop (move-from-complex-long) + (:args (x :scs (complex-long-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "complex float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm:complex-long-float-type + vm: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)))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (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 ;;; @@ -408,15 +574,21 @@ (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))))))) + (: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))))))))) + (: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)) + (frob move-to-complex-double complex-double-reg :double) + #+long-float + (frob move-to-complex-double complex-long-reg :long)) ) ; complex-float @@ -435,7 +607,7 @@ :load-if (not (sc-is y ,sc)))) (:results (y)) (:note "float argument move") - (:generator ,(case format (:single 2) (:double 3)) + (:generator ,(case format (:single 2) (:double 3) (:long 4)) (sc-case y (,sc (unless (location= x y) @@ -454,22 +626,29 @@ (with-tn@fp-top(x) ,@(ecase format (:single '((inst fst ea))) - (:double '((inst fstd 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))) + (:double 2) + (:long 3))) vm:word-bytes))))) (with-tn@fp-top(x) ,@(ecase format (:single '((inst fst ea))) - (:double '((inst fstd 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)) + (frob move-double-float-argument double-reg double-stack :double) + #+long-float + (frob move-long-float-argument long-reg long-stack :long)) ;;;; Complex float move-argument vop #+complex-float @@ -481,7 +660,7 @@ :load-if (not (sc-is y ,sc)))) (:results (y)) (:note "complex float argument move") - (:generator ,(ecase format (:single 2) (:double 3)) + (:generator ,(ecase format (:single 2) (:double 3) (:long 4)) (sc-case y (,sc (unless (location= x y) @@ -509,7 +688,11 @@ (ea-for-csf-real-stack y fp)))) (:double '((inst fstd - (ea-for-cdf-real-stack y fp)))))) + (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 @@ -518,7 +701,11 @@ (ea-for-csf-real-stack y fp)))) (:double '((inst fstd - (ea-for-cdf-real-stack y fp))))) + (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) @@ -526,18 +713,26 @@ (:single '((inst fst (ea-for-csf-imag-stack y fp)))) (:double - '((inst fstd (ea-for-cdf-imag-stack y fp))))) + '((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)) + complex-double-reg complex-double-stack :double) + #+long-float + (frob move-complex-long-float-argument + complex-long-reg complex-long-stack :long)) (define-move-vop move-argument :move-argument - (single-reg double-reg - #+complex-float complex-single-reg #+complex-float complex-double-reg) + (single-reg double-reg #+long-float long-reg + #+complex-float complex-single-reg #+complex-float complex-double-reg + #+(and complex-float long-float) complex-long-reg) (descriptor-reg)) @@ -575,7 +770,8 @@ (macrolet ((frob (op fop-sti fopr-sti fop fopr sname scost - fopd foprd dname dcost) + fopd foprd dname dcost + lname lcost) `(progn (define-vop (,sname) (:translate ,op) @@ -867,20 +1063,111 @@ (t (inst fst r)))) (double-stack - (inst fstd (ea-for-df-stack r))))))))))) + (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)))))))))) (frob + fadd-sti fadd-sti fadd fadd +/single-float 2 - faddd faddd +/double-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) + fsubd fsubrd -/double-float 2 + -/long-float 2) (frob * fmul-sti fmul-sti fmul fmul */single-float 3 - fmuld fmuld */double-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)) + fdivd fdivrd //double-float 12 + //long-float 12)) (macrolet ((frob (name inst translate sc type) @@ -909,8 +1196,12 @@ (frob abs/single-float fabs abs single-reg single-float) (frob abs/double-float fabs abs double-reg double-float) + #+long-float + (frob abs/long-float fabs abs long-reg long-float) (frob %negate/single-float fchs %negate single-reg single-float) - (frob %negate/double-float fchs %negate double-reg double-float)) + (frob %negate/double-float fchs %negate double-reg double-float) + #+long-float + (frob %negate/long-float fchs %negate long-reg long-float)) ;;;; Comparison: @@ -961,6 +1252,13 @@ (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))) + (:arg-types long-float long-float)) + (define-vop (<single-float) (:translate <) @@ -1064,6 +1362,42 @@ (inst cmp ah-tn #x01))) (inst jmp (if not-p :ne :e) target))) +#+long-float +(define-vop (<long-float) + (:translate <) + (:args (x :scs (long-reg)) + (y :scs (long-reg))) + (:arg-types long-float long-float) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + (cond + ;; x is in ST0; y is in any reg. + ((zerop (tn-offset x)) + (inst fcomd y) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) ; C3 C2 C0 + (inst cmp ah-tn #x01)) + ;; y is in ST0; x is in another reg. + ((zerop (tn-offset y)) + (inst fcomd x) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45)) + ;; x and y are the same register, not ST0 + ;; x and y are different registers, neither ST0. + (t + (inst fxch y) + (inst fcomd x) + (inst fxch y) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45))) ; C3 C2 C0 + (inst jmp (if not-p :ne :e) target))) + + (define-vop (>single-float) (:translate >) (:args (x :scs (single-reg single-stack descriptor-reg)) @@ -1166,6 +1500,41 @@ (inst and ah-tn #x45))) (inst jmp (if not-p :ne :e) target))) +#+long-float +(define-vop (>long-float) + (:translate >) + (:args (x :scs (long-reg)) + (y :scs (long-reg))) + (:arg-types long-float long-float) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + (cond + ;; y is in ST0; x is in any reg. + ((zerop (tn-offset y)) + (inst fcomd x) + (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 and ah-tn #x45)) + ;; y and x are the same register, not ST0 + ;; y and x are different registers, neither ST0. + (t + (inst fxch x) + (inst fcomd y) + (inst fxch x) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45))) + (inst jmp (if not-p :ne :e) target))) + ;;; Comparisons with 0 can use the FTST instruction. (define-vop (float-test) @@ -1212,6 +1581,15 @@ #+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 double-float (:constant (long-float -0l0 0l0))) + (:variant #x40)) (define-vop (<0/single-float float-test) (:translate <) @@ -1229,6 +1607,15 @@ #+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 >) @@ -1246,6 +1633,21 @@ #+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)))) ;;;; Conversion: @@ -1274,7 +1676,9 @@ (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)) + (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) @@ -1295,7 +1699,9 @@ (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)) + (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 @@ -1329,8 +1735,20 @@ (frob %single-float/double-float %single-float double-reg double-float single-reg single-float) + #+long-float + (frob %single-float/long-float %single-float long-reg + 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) + #+long-float + (frob %long-float/single-float %long-float single-reg single-float + long-reg long-float) + #+long-float + (frob %long-float/double-float %long-float double-reg double-float + long-reg long-float)) @@ -1373,8 +1791,12 @@ '((inst fldcw scw))))))))) (frob %unary-truncate single-reg single-float nil) (frob %unary-truncate double-reg double-float nil) + #+long-float + (frob %unary-truncate long-reg long-float nil) (frob %unary-round single-reg single-float t) - (frob %unary-round double-reg double-float t)) + (frob %unary-round double-reg double-float t) + #+long-float + (frob %unary-round long-reg long-float t)) (macrolet ((frob (trans from-sc from-type round-p) `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED")) @@ -1416,8 +1838,12 @@ '((inst fldcw scw))))))) (frob %unary-truncate single-reg single-float nil) (frob %unary-truncate double-reg double-float nil) + #+long-float + (frob %unary-truncate long-reg long-float nil) (frob %unary-round single-reg single-float t) - (frob %unary-round double-reg double-float t)) + (frob %unary-round double-reg double-float t) + #+long-float + (frob %unary-round long-reg long-float t)) (define-vop (make-single-float) @@ -1471,6 +1897,27 @@ (inst fldd (make-ea :dword :base ebp-tn :disp (- (* (1+ offset) 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))) + (:results (res :scs (long-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types signed-num unsigned-num unsigned-num) + (:result-types long-float) + (:translate make-long-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (let ((offset (1+ (tn-offset temp)))) + (storew exp-bits ebp-tn (- offset)) + (storew hi-bits ebp-tn (- (1+ offset))) + (storew lo-bits ebp-tn (- (+ offset 2))) + (with-empty-tn@fp-top(res) + (inst fldl (make-ea :dword :base ebp-tn + :disp (- (* (+ offset 2) word-bytes)))))))) + (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) :load-if (not (sc-is float single-stack)))) @@ -1550,6 +1997,90 @@ (loadw lo-bits float vm:double-float-value-slot vm:other-pointer-type))))) +#+long-float +(define-vop (long-float-exp-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (exp-bits :scs (signed-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types signed-num) + (:translate long-float-exp-bits) + (:policy :fast-safe) + (:vop-var vop) + (: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)))) + (long-stack + (inst movsx exp-bits + (make-ea :word :base ebp-tn + :disp (* (- (1+ (tn-offset float))) word-bytes)))) + (descriptor-reg + (inst movsx exp-bits + (make-ea :word :base float + :disp (- (* (+ 2 vm:long-float-value-slot) word-bytes) + vm:other-pointer-type))))))) + +#+long-float +(define-vop (long-float-high-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (hi-bits :scs (unsigned-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (: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)))) + (long-stack + (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2)))) + (descriptor-reg + (loadw hi-bits float (1+ vm:long-float-value-slot) + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-low-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (: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)))) + (long-stack + (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3)))) + (descriptor-reg + (loadw lo-bits float vm:long-float-value-slot + vm:other-pointer-type))))) + ;;;; Float mode hackery: @@ -1606,6 +2137,9 @@ +#-long-float +(progn + ;;; Lets use some of the 80387 special functions. ;;; ;;; These defs will not take effect unless code/irrat.lisp is modified @@ -2672,61 +3206,1087 @@ (case (tn-offset r) ((0 1)) (t (inst fstd r))))) + +) ; progn #-long-float + -;;;; Complex float VOPs -#+complex-float +#+long-float (progn -(define-vop (make-complex-single-float) - (:translate complex) - (:args (real :scs (single-reg) :target r) - (imag :scs (single-reg) :to :save)) - (:arg-types single-float single-float) - (:results (r :scs (complex-single-reg complex-single-stack) - :from (:argument 0))) - (:result-types complex-single-float) - (:note "inline complex single-float creation") - (:policy :fast-safe) - (:generator 5 - (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))))) - (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)))))) - (complex-single-stack - (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))) +;;; Lets use some of the 80387 special functions. +;;; +;;; These defs will not take effect unless code/irrat.lisp is modified +;;; 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 + ;; within range 2^63. + (frob fsin-quick %sin-quick fsin) + (frob fcos-quick %cos-quick fcos) + ;; + (frob fsqrt %sqrt fsqrt)) + +;;; Quick version of ftan that requires the argument to be within +;;; range 2^63. +(define-vop (ftan-quick) + (: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 *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; These versions of fsin, fcos, and ftan try to use argument +;;; reduction but to do this accurately requires greater precision and +;;; it is hopelessly inaccurate. +#+nil +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :eval :to :result) eax) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore eax) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fstp fr1) ; Load 2*PI + (inst fldpi) + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst ,op) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +#+nil +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :argument :to :result) eax) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore eax) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fldpi) ; Load 2*PI + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst fstp fr1) + (inst fptan) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if +;;; the argument is out of range 2^63 and would thus be hopelessly +;;; inaccurate. +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (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) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (: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) + (:ignore eax) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore eax) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :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 fldz) ; Load 0.0 + (inst fxch fr1) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (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. +(define-vop (fexp) + (:translate %exp) + (: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) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (: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 + ;; 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 fldz) + (inst jmp-short DONE) + NOINFNAN + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1) + ;; 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) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +(define-vop (flog) + (: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) + (: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 log function") + (:vop-var vop) + (:save-p :compute-only) + (: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 *backend*) + :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)) + (t (inst fstd y))))) + +(define-vop (flog10) + (: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) + (: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 log10 function") + (:vop-var vop) + (:save-p :compute-only) + (: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 *backend*) + :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)) + (t (inst fstd y))))) + +(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)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :load :to :result) fr2) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline pow function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (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)))) + ;; 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))))) + ;; 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)))) + (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)))) + (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))))) + ;; 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 *backend*) + :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 *backend*) + :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) + ;; Now fr0=y log2(x) + (inst fld fr0) + (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 r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fscalen) + (:translate %scalbn) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) + (y :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc long-reg :offset fr0-offset + :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))) + (:arg-types long-float signed-num) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline scalbn function") + (:generator 5 + ;; 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 *backend*) + :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 fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(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)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline scalb function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (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)))) + ;; 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))))) + ;; 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)))) + (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)))) + (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))))) + ;; 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 *backend*) + :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 *backend*) + :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)))) + +(define-vop (flog1p) + (:translate %log1p) + (:args (x :scs (long-reg) :to :result)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:guard (not (backend-featurep :pentium))) + (:note "inline log1p function") + (:ignore temp) + (:generator 5 + ;; x is in a FP reg, not fr0, fr1. + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 2))) + ;; Check the range + (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 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 *backend*) + :offset (- (tn-offset x) 1))) + (inst fldln2) + (inst fxch fr1) + (inst fyl2x) + (inst jmp DONE) + + WITHIN-RANGE + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (- (tn-offset x) 1))) + (inst fyl2xp1) + DONE + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +;;; The Pentium has a less restricted implementation of the fyl2xp1 +;;; instruction and a range check can be avoided. +(define-vop (flog1p-pentium) + (: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) + (: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) + (:guard (backend-featurep :pentium)) + (: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 *backend*) + :offset (- (tn-offset x) 2)))))) + ((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) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flogb) + (: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) + (: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 logb function") + (:vop-var vop) + (:save-p :compute-only) + (: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 *backend*) + :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)) + (1) + (t (inst fxch fr1) + (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) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline atan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and 1.0 in fr0 + (cond + ;; x in fr0 + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fstp fr1)) + ;; x in fr1 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + (inst fstp fr0)) + ;; x not in fr0 or fr1 + (t + ;; Load x then 1.0 + (inst fstp fr0) + (inst fstp fr0) + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :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) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(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)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 1) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline atan2 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and y in fr0 + (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)))) + ;; 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))))) + ;; 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)))) + (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)))) + (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))))) + ;; 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 *backend*) + :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 *backend*) + :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) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +) ; progn #+long-float + + +;;;; Complex float VOPs + +#+complex-float +(progn + +(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)) + (:arg-types single-float single-float) + (:results (r :scs (complex-single-reg) :from (:argument 0) + :load-if (not (sc-is r complex-single-stack)))) + (:result-types complex-single-float) + (:note "inline complex single-float creation") + (:policy :fast-safe) + (:generator 5 + (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))))) + (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)))))) + (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)))) (inst fxch imag) (inst fst (ea-for-csf-imag-stack r)) (inst fxch imag))))) (define-vop (make-complex-double-float) (:translate complex) - (:args (real :scs (double-reg) :target r) + (:args (real :scs (double-reg) :target r + :load-if (not (location= real r))) (imag :scs (double-reg) :to :save)) (:arg-types double-float double-float) - (:results (r :scs (complex-double-reg complex-double-stack) - :from (:argument 0))) + (:results (r :scs (complex-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-stack)))) (:result-types complex-double-float) (:note "inline complex double-float creation") (:policy :fast-safe) @@ -2752,12 +4312,13 @@ (inst fstd r-imag) (inst fxch imag)))))) (complex-double-stack - (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))) + (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)))) (inst fxch imag) (inst fstd (ea-for-cdf-imag-stack r)) (inst fxch imag))))) @@ -2765,11 +4326,12 @@ #+long-float (define-vop (make-complex-long-float) (:translate complex) - (:args (real :scs (long-reg) :target r) + (:args (real :scs (long-reg) :target r + :load-if (not (location= real r))) (imag :scs (long-reg) :to :save)) (:arg-types long-float long-float) - (:results (r :scs (complex-long-reg complex-long-stack) - :from (:argument 0))) + (:results (r :scs (complex-long-reg) :from (:argument 0) + :load-if (not (sc-is r complex-long-stack)))) (:result-types complex-long-float) (:note "inline complex long-float creation") (:policy :fast-safe) @@ -2795,12 +4357,13 @@ (inst fstd r-imag) (inst fxch imag)))))) (complex-long-stack - (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))) + (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)))) (inst fxch imag) (store-long-float (ea-for-clf-imag-stack r)) (inst fxch imag))))) @@ -2812,7 +4375,8 @@ (:variant-vars offset) (:policy :fast-safe) (:generator 3 - (cond ((sc-is x complex-single-reg complex-double-reg) + (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 *backend*) @@ -2850,6 +4414,19 @@ (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) @@ -2872,6 +4449,17 @@ (:note "complex float realpart") (:variant 0)) +#+long-float +(define-vop (realpart/complex-long-float complex-float-value) + (:translate realpart) + (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) + :target r)) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:note "complex float realpart") + (:variant 0)) + (define-vop (imagpart/complex-single-float complex-float-value) (:translate imagpart) (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) @@ -2892,6 +4480,17 @@ (:note "complex float imagpart") (:variant 1)) +#+long-float +(define-vop (imagpart/complex-long-float complex-float-value) + (:translate imagpart) + (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) + :target r)) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:note "complex float imagpart") + (:variant 1)) + ) ; complex-float diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp index dfc53a5da7575ef88385bf435abdf42f46812dec..0b86086117035958215fbed8682b85da990f370d 100644 --- a/compiler/x86/parms.lisp +++ b/compiler/x86/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.9 1997/11/18 16:55:53 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.10 1998/03/21 07:54:39 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -76,6 +76,11 @@ double-float-normal-exponent-max double-float-hidden-bit double-float-trapping-nan-bit double-float-digits + long-float-bias long-float-exponent-byte + long-float-significand-byte long-float-normal-exponent-min + long-float-normal-exponent-max long-float-hidden-bit + long-float-trapping-nan-bit long-float-digits + float-underflow-trap-bit float-overflow-trap-bit float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit)) @@ -121,12 +126,22 @@ (defconstant double-float-hidden-bit (ash 1 20)) (defconstant double-float-trapping-nan-bit (ash 1 19)) +(defconstant long-float-bias 16382) +(defconstant long-float-exponent-byte (byte 15 0)) +(defconstant long-float-significand-byte (byte 31 0)) +(defconstant long-float-normal-exponent-min 1) +(defconstant long-float-normal-exponent-max #x7FFE) +(defconstant long-float-hidden-bit (ash 1 31)) ; Actually not hidden +(defconstant long-float-trapping-nan-bit (ash 1 30)) + (defconstant single-float-digits (+ (byte-size single-float-significand-byte) 1)) (defconstant double-float-digits (+ (byte-size double-float-significand-byte) word-bits 1)) +(defconstant long-float-digits + (+ (byte-size long-float-significand-byte) word-bits 1)) ;;; pfw -- from i486 microprocessor programmers reference manual (defconstant float-invalid-trap-bit (ash 1 0)) @@ -258,6 +273,14 @@ *fp-constant-1d0* *fp-constant-0s0* *fp-constant-1s0* + ;; Following are all long-floats. + *fp-constant-0l0* + *fp-constant-1l0* + *fp-constant-pi* + *fp-constant-l2t* + *fp-constant-l2e* + *fp-constant-lg2* + *fp-constant-ln2* ;; Used by gencgc. *scavenge-read-only-space* @@ -296,4 +319,3 @@ ;;; cf the sparc PARMS.LISP (defparameter *assembly-unit-length* 8) - diff --git a/compiler/x86/sap.lisp b/compiler/x86/sap.lisp index 7b64352df20ae1cee09c20659ab9ec3e4c2d1b9e..5dfba7fe95628a38d7284f71af252907714cfe99 100644 --- a/compiler/x86/sap.lisp +++ b/compiler/x86/sap.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.7 1998/02/19 10:52:16 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.8 1998/03/21 07:54:40 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -16,7 +16,7 @@ ;;; Written by William Lott. ;;; ;;; Debugged by Paul F. Werkowski Spring/Summer 1995. -;;; Enhancements/debugging by Douglas T. Crosher 1996,1997. +;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998. ;;; (in-package :x86) @@ -467,6 +467,36 @@ (with-empty-tn@fp-top(result) (inst fldl (make-ea :dword :base sap :disp offset))))) +#+long-float +(define-vop (%set-sap-ref-long) + (:translate %set-sap-ref-long) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (long-reg))) + (:arg-types system-area-pointer signed-num long-float) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:generator 5 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0 + (store-long-float (make-ea :dword :base sap :index offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (store-long-float (make-ea :dword :base sap :index offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + ;;; Noise to convert normal lisp data objects into SAPs. diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp index 2458b653f8c4da89c2b2f1aeb3b178720554c6a2..62194f806648e23827a99b71dd56728517f9d757 100644 --- a/compiler/x86/type-vops.lisp +++ b/compiler/x86/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.10 1998/02/19 19:35:08 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.11 1998/03/21 07:54:40 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -355,7 +355,8 @@ (def-type-vops complexp check-complex complex object-not-complex-error complex-type #+complex-float complex-single-float-type - #+complex-float complex-double-float-type) + #+complex-float complex-double-float-type + #+(and complex-float long-float) complex-long-float-type) #+complex-float (def-type-vops complex-rational-p check-complex-rational nil @@ -364,7 +365,8 @@ #+complex-float (def-type-vops complex-float-p check-complex-float nil object-not-complex-float-error - complex-single-float-type complex-double-float-type) + complex-single-float-type complex-double-float-type + #+long-float complex-long-float-type) #+complex-float (def-type-vops complex-single-float-p check-complex-single-float @@ -376,12 +378,21 @@ complex-double-float object-not-complex-double-float-error complex-double-float-type) +#+(and complex-float long-float) +(def-type-vops complex-long-float-p check-complex-long-float + complex-long-float object-not-complex-long-float-error + complex-long-float-type) + (def-type-vops single-float-p check-single-float single-float object-not-single-float-error single-float-type) (def-type-vops double-float-p check-double-float double-float object-not-double-float-error double-float-type) +#+long-float +(def-type-vops long-float-p check-long-float long-float + object-not-long-float-error long-float-type) + (def-type-vops simple-string-p check-simple-string simple-string object-not-simple-string-error simple-string-type) @@ -457,6 +468,11 @@ simple-array-double-float object-not-simple-array-double-float-error simple-array-double-float-type) +#+long-float +(def-type-vops simple-array-long-float-p check-simple-array-long-float + simple-array-long-float object-not-simple-array-long-float-error + simple-array-long-float-type) + #+complex-float (def-type-vops simple-array-complex-single-float-p check-simple-array-complex-single-float @@ -471,6 +487,13 @@ object-not-simple-array-complex-double-float-error simple-array-complex-double-float-type) +#+(and complex-float long-float) +(def-type-vops simple-array-complex-long-float-p + check-simple-array-complex-long-float + simple-array-complex-long-float + object-not-simple-array-complex-long-float-error + simple-array-complex-long-float-type) + (def-type-vops base-char-p check-base-char base-char object-not-base-char-error base-char-type) @@ -519,8 +542,10 @@ #+signed-array simple-array-signed-byte-30-type #+signed-array simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type + #+long-float simple-array-long-float-type #+complex-float simple-array-complex-single-float-type #+complex-float simple-array-complex-double-float-type + #+(and complex-float long-float) simple-array-complex-long-float-type complex-string-type complex-bit-vector-type complex-vector-type) (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error @@ -533,8 +558,10 @@ #+signed-array simple-array-signed-byte-30-type #+signed-array simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type + #+long-float simple-array-long-float-type #+complex-float simple-array-complex-single-float-type - #+complex-float simple-array-complex-double-float-type) + #+complex-float simple-array-complex-double-float-type + #+(and complex-float long-float) simple-array-complex-long-float-type) (def-type-vops arrayp check-array nil object-not-array-error simple-array-type simple-string-type simple-bit-vector-type @@ -546,16 +573,19 @@ #+signed-array simple-array-signed-byte-30-type #+signed-array simple-array-signed-byte-32-type simple-array-single-float-type simple-array-double-float-type + #+long-float simple-array-long-float-type #+complex-float simple-array-complex-single-float-type #+complex-float simple-array-complex-double-float-type + #+(and complex-float long-float) simple-array-complex-long-float-type complex-string-type complex-bit-vector-type complex-vector-type complex-array-type) (def-type-vops numberp check-number nil object-not-number-error even-fixnum-type odd-fixnum-type bignum-type ratio-type - single-float-type double-float-type complex-type + single-float-type double-float-type #+long-float long-float-type complex-type #+complex-float complex-single-float-type - #+complex-float complex-double-float-type) + #+complex-float complex-double-float-type + #+(and complex-float long-float) complex-long-float-type) (def-type-vops rationalp check-rational nil object-not-rational-error even-fixnum-type odd-fixnum-type ratio-type bignum-type) @@ -564,11 +594,11 @@ even-fixnum-type odd-fixnum-type bignum-type) (def-type-vops floatp check-float nil object-not-float-error - single-float-type double-float-type) + single-float-type double-float-type #+long-float long-float-type) (def-type-vops realp check-real nil object-not-real-error even-fixnum-type odd-fixnum-type ratio-type bignum-type - single-float-type double-float-type) + single-float-type double-float-type #+long-float long-float-type) ;;;; Other integer ranges. diff --git a/compiler/x86/vm.lisp b/compiler/x86/vm.lisp index bc0db76f69e7a7f378a76c27e1d61c9168978062..05a1cc98cb62391c7904668c13f101a7eb94672b 100644 --- a/compiler/x86/vm.lisp +++ b/compiler/x86/vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.8 1998/02/21 18:24:45 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.9 1998/03/21 07:54:41 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -174,10 +174,14 @@ (sap-stack stack) ; System area pointers. (single-stack stack) ; single-floats (double-stack stack :element-size 2) ; double-floats. + #+long-float + (long-stack stack :element-size 3) ; long-floats. #+complex-float (complex-single-stack stack :element-size 2) ; complex-single-floats #+complex-float (complex-double-stack stack :element-size 4) ; complex-double-floats + #+(and complex-float long-float) + (complex-long-stack stack :element-size 6) ; complex-long-floats ;; **** Magic SCs. @@ -270,6 +274,14 @@ :save-p t :alternate-scs (double-stack)) + ;; Non-Descriptor long-floats. + #+long-float + (long-reg float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-constant) + :save-p t + :alternate-scs (long-stack)) + #+complex-float (complex-single-reg float-registers :locations (0 2 4 6) @@ -286,6 +298,14 @@ :save-p t :alternate-scs (complex-double-stack)) + #+(and complex-float long-float) + (complex-long-reg float-registers + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-long-stack)) + ;; A catch or unwind block. (catch-block stack :element-size vm:catch-block-size) ) @@ -356,6 +376,15 @@ (sc-number-or-lose 'fp-constant *backend*))) (double-float (when (or (eql value 0d0) (eql value 1d0)) + (sc-number-or-lose 'fp-constant *backend*))) + #+long-float + (long-float + (when (or (eql value 0l0) (eql value 1l0) + (eql value pi) + (eql value (log 10l0 2l0)) + (eql value (log 2.718281828459045235360287471352662L0 2l0)) + (eql value (log 2l0 10l0)) + (eql value (log 2l0 2.718281828459045235360287471352662L0))) (sc-number-or-lose 'fp-constant *backend*)))))