From eb65f3eb243c1eeed85541eb7828f69133176111 Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Sat, 21 Mar 1998 08:05:25 +0000 Subject: [PATCH] Long-float support for the sparc backend. --- compiler/sparc/arith.lisp | 26 +- compiler/sparc/array.lisp | 115 ++++- compiler/sparc/c-call.lisp | 20 +- compiler/sparc/float.lisp | 813 +++++++++++++++++++++++++++++----- compiler/sparc/insts.lisp | 121 +++-- compiler/sparc/parms.lisp | 19 +- compiler/sparc/sap.lisp | 79 ++-- compiler/sparc/type-vops.lisp | 49 +- compiler/sparc/vm.lisp | 45 +- 9 files changed, 1073 insertions(+), 214 deletions(-) diff --git a/compiler/sparc/arith.lisp b/compiler/sparc/arith.lisp index 65296ea4e..c738c9794 100644 --- a/compiler/sparc/arith.lisp +++ b/compiler/sparc/arith.lisp @@ -5,11 +5,11 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.10 1994/10/31 04:46:41 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.11 1998/03/21 08:05:20 dtc Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.10 1994/10/31 04:46:41 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.11 1998/03/21 08:05:20 dtc Exp $ ;;; ;;; This file contains the VM definition arithmetic VOPs for the MIPS. ;;; @@ -303,6 +303,28 @@ (emit-label done)))) +;;; Multiply and Divide. + +(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:translate *) + (:guard (backend-featurep :sparc-v8)) + (:generator 4 + (inst sra temp y 2) + (inst smul r x temp))) + +(define-vop (fast-*/signed=>signed fast-signed-binop) + (:translate *) + (:guard (backend-featurep :sparc-v8)) + (:generator 3 + (inst smul r x y))) + +(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop) + (:translate *) + (:guard (backend-featurep :sparc-v8)) + (:generator 3 + (inst umul r x y))) + ;;;; Binary conditional VOPs: diff --git a/compiler/sparc/array.lisp b/compiler/sparc/array.lisp index dc420ae1e..e6faaf4dc 100644 --- a/compiler/sparc/array.lisp +++ b/compiler/sparc/array.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.19 1998/03/10 21:42:22 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.20 1998/03/21 08:05:21 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -13,7 +13,7 @@ ;;; ;;; Written by William Lott ;;; Signed-array support by Douglas Crosher 1997. -;;; Complex-float support by Douglas Crosher 1998. +;;; Complex-float and long-float support by Douglas Crosher 1998. ;;; (in-package "SPARC") @@ -393,6 +393,43 @@ (unless (location= result value) (move-double-reg result 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)) + (index :scs (any-reg))) + (:arg-types simple-array-long-float positive-fixnum) + (:results (value :scs (long-reg))) + (:result-types long-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 7 + (inst sll offset index 2) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (load-long-reg value object offset nil))) + +#+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)) + (index :scs (any-reg)) + (value :scs (long-reg) :target result)) + (:arg-types simple-array-long-float positive-fixnum long-float) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 20 + (inst sll offset index 2) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (store-long-reg value object offset nil) + (unless (location= result value) + (move-long-reg result value)))) + ;;;; Misc. Array VOPs. @@ -552,6 +589,56 @@ (unless (location= result-imag value-imag) (move-double-reg result-imag 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) + (:results (value :scs (complex-long-reg))) + (:result-types complex-long-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-long-reg-real-tn value))) + (inst sll offset index 3) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (load-long-reg real-tn object offset nil)) + (let ((imag-tn (complex-long-reg-imag-tn value))) + (inst add offset (* 4 vm:word-bytes)) + (load-long-reg imag-tn object offset nil)))) + +#+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) + (:results (result :scs (complex-long-reg))) + (:result-types complex-long-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-long-reg-real-tn value)) + (result-real (complex-long-reg-real-tn result))) + (inst sll offset index 3) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (store-long-reg value-real object offset nil) + (unless (location= result-real value-real) + (move-long-reg result-real value-real))) + (let ((value-imag (complex-long-reg-imag-tn value)) + (result-imag (complex-long-reg-imag-tn result))) + (inst add offset (* 4 vm:word-bytes)) + (store-long-reg value-imag object offset nil) + (unless (location= result-imag value-imag) + (move-long-reg result-imag value-imag))))) + ) ; end progn complex-float @@ -573,6 +660,16 @@ (define-vop (raw-set-double data-vector-set/simple-array-double-float) (:translate %raw-set-double) (:arg-types simple-array-unsigned-byte-32 positive-fixnum 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-set-double data-vector-set/simple-array-long-float) + (:translate %raw-set-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float)) #+complex-float (progn @@ -597,6 +694,20 @@ (:translate %raw-set-complex-double) (:arg-types simple-array-unsigned-byte-32 positive-fixnum 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-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)) + ) ; end progn complex-float ;;; These vops are useful for accessing the bits of a vector irrespective of diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp index bb522e79c..2ba303ffb 100644 --- a/compiler/sparc/c-call.lisp +++ b/compiler/sparc/c-call.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.11 1994/10/31 04:46:41 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.12 1998/03/21 08:05:21 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -62,6 +62,11 @@ (declare (ignore type)) (my-make-wired-tn 'double-float 'double-reg 0)) +#+long-float +(def-alien-type-method (long-float :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'long-float 'long-reg 0)) + (def-alien-type-method (values :result-tn) (type) (mapcar #'(lambda (type) (invoke-alien-type-method :result-tn type)) @@ -87,7 +92,8 @@ (arg-types (alien-function-type-arg-types type)) (result-type (alien-function-type-result-type type))) (assert (= (length arg-types) (length args))) - (if (some #'alien-double-float-type-p arg-types) + (if (or (some #'alien-double-float-type-p arg-types) + #+long-float (some #'alien-long-float-type-p arg-types)) (collect ((new-args) (lambda-vars) (new-arg-types)) (dolist (type arg-types) (let ((arg (gensym))) @@ -97,6 +103,16 @@ (new-args `(double-float-low-bits ,arg)) (new-arg-types (parse-alien-type '(signed 32))) (new-arg-types (parse-alien-type '(unsigned 32)))) + #+long-float + ((alien-long-float-type-p type) + (new-args `(long-float-exp-bits ,arg)) + (new-args `(long-float-high-bits ,arg)) + (new-args `(long-float-mid-bits ,arg)) + (new-args `(long-float-low-bits ,arg)) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32))) + (new-arg-types (parse-alien-type '(unsigned 32))) + (new-arg-types (parse-alien-type '(unsigned 32)))) (t (new-args arg) (new-arg-types type))))) diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp index cebddb00a..38071b364 100644 --- a/compiler/sparc/float.lisp +++ b/compiler/sparc/float.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.22 1998/03/11 17:11:35 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.23 1998/03/21 08:05:22 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -13,7 +13,7 @@ ;;; ;;; Written by Rob MacLachlan ;;; Sparc conversion by William Lott. -;;; Complex-float support by Douglas Crosher 1998. +;;; Complex-float and long-float support by Douglas Crosher 1998. ;;; (in-package "SPARC") @@ -41,6 +41,63 @@ (offset (* (tn-offset y) vm:word-bytes))) (inst stdf x nfp offset))) +;;; The offset may be an integer or a TN in which case it will be +;;; temporarily modified but is restored if restore-offset is true. +;;; +(defun load-long-reg (reg base offset &optional (restore-offset t)) + (if (backend-featurep :sparc-v9) + (inst ldxf reg base offset) + (let ((reg0 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset reg))) + (reg2 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset reg))))) + (cond ((integerp offset) + (inst lddf reg0 base offset) + (inst lddf reg2 base (+ offset (* 2 vm:word-bytes)))) + (t + (inst lddf reg0 base offset) + (inst add offset (* 2 vm:word-bytes)) + (inst lddf reg2 base offset) + (when restore-offset + (inst sub offset (* 2 vm:word-bytes)))))))) + +#+long-float +(define-move-function (load-long 2) (vop x y) + ((long-stack) (long-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (load-long-reg y nfp offset))) + +;;; The offset may be an integer or a TN in which case it will be +;;; temporarily modified but is restored if restore-offset is true. +;;; +(defun store-long-reg (reg base offset &optional (restore-offset t)) + (if (backend-featurep :sparc-v9) + (inst stxf reg base offset) + (let ((reg0 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset reg))) + (reg2 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset reg))))) + (cond ((integerp offset) + (inst stdf reg0 base offset) + (inst stdf reg2 base (+ offset (* 2 vm:word-bytes)))) + (t + (inst stdf reg0 base offset) + (inst add offset (* 2 vm:word-bytes)) + (inst stdf reg2 base offset) + (when restore-offset + (inst sub offset (* 2 vm:word-bytes)))))))) + +#+long-float +(define-move-function (store-long 2) (vop x y) + ((long-reg) (long-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (store-long-reg x nfp offset))) ;;;; Move VOPs: @@ -49,13 +106,33 @@ ;;; on the :sparc-v9 feature. (defun move-double-reg (dst src) (cond ((backend-featurep :sparc-v9) - ;; May need to re-map of the register numbers? (inst fmovd dst src)) (t - (inst fmovs dst src) - (inst fmovs-odd dst src)))) - -(macrolet ((frob (vop sc double-p) + (dotimes (i 2) + (let ((dst (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset dst)))) + (src (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset src))))) + (inst fmovs dst src)))))) + +;;; Exploit the V9 long-float move instruction. This is conditional +;;; on the :sparc-v9 feature. +(defun move-long-reg (dst src) + (cond ((backend-featurep :sparc-v9) + (inst fmovx dst src)) + (t + (dotimes (i 4) + (let ((dst (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset dst)))) + (src (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset src))))) + (inst fmovs dst src)))))) + +(macrolet ((frob (vop sc format) `(progn (define-vop (,vop) (:args (x :scs (,sc) @@ -66,12 +143,15 @@ (:note "float move") (:generator 0 (unless (location= y x) - ,@(if double-p - `((move-double-reg y x)) - `((inst fmovs y x)))))) + ,@(ecase format + (:single `((inst fmovs y x))) + (:double `((move-double-reg y x))) + (:long `((move-long-reg y x))))))) (define-move-vop ,vop :move (,sc) (,sc))))) - (frob single-move single-reg nil) - (frob double-move double-reg t)) + (frob single-move single-reg :single) + (frob double-move double-reg :double) + #+long-float + (frob long-move long-reg :long)) (define-vop (move-from-float) @@ -79,12 +159,17 @@ (:results (y)) (:note "float to pointer coercion") (:temporary (:scs (non-descriptor-reg)) ndescr) - (:variant-vars double-p size type data) + (:variant-vars format size type data) (:generator 13 (with-fixed-allocation (y ndescr type size)) - (if double-p - (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type)) - (inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type))))) + (ecase format + (:single + (inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type))) + (:double + (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type))) + (:long + (store-long-reg x y (- (* data vm:word-bytes) + vm:other-pointer-type)))))) (macrolet ((frob (name sc &rest args) `(progn @@ -93,26 +178,42 @@ (:results (y :scs (descriptor-reg))) (:variant ,@args)) (define-move-vop ,name :move (,sc) (descriptor-reg))))) - (frob move-from-single single-reg - nil vm:single-float-size vm:single-float-type vm:single-float-value-slot) - (frob move-from-double double-reg - t vm:double-float-size vm:double-float-type vm:double-float-value-slot)) - -(macrolet ((frob (name sc double-p value) + (frob move-from-single single-reg :single + vm:single-float-size vm:single-float-type vm:single-float-value-slot) + (frob move-from-double double-reg :double + vm:double-float-size vm:double-float-type vm:double-float-value-slot) + #+long-float + (frob move-from-long long-reg :long + vm:long-float-size vm:long-float-type vm:long-float-value-slot)) + +(macrolet ((frob (name sc format value) `(progn (define-vop (,name) (:args (x :scs (descriptor-reg))) (:results (y :scs (,sc))) (:note "pointer to float coercion") (:generator 2 - (inst ,(if double-p 'lddf 'ldf) y x + (inst ,(ecase format + (:single 'ldf) + (:double 'lddf)) + y x (- (* ,value vm:word-bytes) vm:other-pointer-type)))) (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-single single-reg nil vm:single-float-value-slot) - (frob move-to-double double-reg t vm:double-float-value-slot)) + (frob move-to-single single-reg :single vm:single-float-value-slot) + (frob move-to-double double-reg :double vm:double-float-value-slot)) +#+long-float +(define-vop (move-to-long) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (long-reg))) + (:note "pointer to float coercion") + (:generator 2 + (load-long-reg y x (- (* vm:long-float-value-slot vm:word-bytes) + vm:other-pointer-type)))) +#+long-float +(define-move-vop move-to-long :move (descriptor-reg) (long-reg)) -(macrolet ((frob (name sc stack-sc double-p) +(macrolet ((frob (name sc stack-sc format) `(progn (define-vop (,name) (:args (x :scs (,sc) :target y) @@ -120,20 +221,42 @@ :load-if (not (sc-is y ,sc)))) (:results (y)) (:note "float argument move") - (:generator ,(if double-p 2 1) + (:generator ,(ecase format (:single 1) (:double 2)) (sc-case y (,sc (unless (location= x y) - ,@(if double-p - '((move-double-reg y x)) - '((inst fmovs y x))))) + ,@(ecase format + (:single '((inst fmovs y x))) + (:double '((move-double-reg y x)))))) (,stack-sc (let ((offset (* (tn-offset y) vm:word-bytes))) - (inst ,(if double-p 'stdf 'stf) x nfp offset)))))) + (inst ,(ecase format + (:single 'stf) + (:double 'stdf)) + x nfp offset)))))) (define-move-vop ,name :move-argument (,sc descriptor-reg) (,sc))))) - (frob move-single-float-argument single-reg single-stack nil) - (frob move-double-float-argument double-reg double-stack t)) + (frob move-single-float-argument single-reg single-stack :single) + (frob move-double-float-argument double-reg double-stack :double)) + +#+long-float +(define-vop (move-long-float-argument) + (:args (x :scs (long-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y long-reg)))) + (:results (y)) + (:note "float argument move") + (:generator 3 + (sc-case y + (long-reg + (unless (location= x y) + (move-long-reg y x))) + (long-stack + (let ((offset (* (tn-offset y) vm:word-bytes))) + (store-long-reg x nfp offset)))))) +;;; +#+long-float +(define-move-vop move-long-float-argument :move-argument + (long-reg descriptor-reg) (long-reg)) ;;;; Complex float move functions @@ -145,7 +268,7 @@ :offset (tn-offset x))) (defun complex-single-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*) - :offset (+ (tn-offset x) 2))) + :offset (1+ (tn-offset x)))) (defun complex-double-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) @@ -154,6 +277,15 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) :offset (+ (tn-offset x) 2))) +#+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 (+ (tn-offset x) 4))) + (define-move-function (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) @@ -192,6 +324,27 @@ (let ((imag-tn (complex-double-reg-imag-tn x))) (inst stdf imag-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +#+long-float +(define-move-function (load-complex-long 5) (vop x y) + ((complex-long-stack) (complex-long-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((real-tn (complex-long-reg-real-tn y))) + (load-long-reg real-tn nfp offset)) + (let ((imag-tn (complex-long-reg-imag-tn y))) + (load-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes)))))) + +#+long-float +(define-move-function (store-complex-long 5) (vop x y) + ((complex-long-reg) (complex-long-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((real-tn (complex-long-reg-real-tn x))) + (store-long-reg real-tn nfp offset)) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (store-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes)))))) + ;;; ;;; Complex float register to register moves. ;;; @@ -233,6 +386,27 @@ (define-move-vop complex-double-move :move (complex-double-reg) (complex-double-reg)) +#+long-float +(define-vop (complex-long-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)))) + (:note "complex long float move") + (:generator 0 + (unless (location= x y) + ;; 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-long-reg-real-tn x)) + (y-real (complex-long-reg-real-tn y))) + (move-long-reg y-real x-real)) + (let ((x-imag (complex-long-reg-imag-tn x)) + (y-imag (complex-long-reg-imag-tn y))) + (move-long-reg y-imag x-imag))))) +;;; +#+long-float +(define-move-vop complex-long-move :move + (complex-long-reg) (complex-long-reg)) + ;;; ;;; Move from a complex float to a descriptor register allocating a ;;; new complex float object in the process. @@ -277,6 +451,28 @@ (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))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note "complex long float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm:complex-long-float-type + vm:complex-long-float-size)) + (let ((real-tn (complex-long-reg-real-tn x))) + (store-long-reg real-tn y (- (* vm:complex-long-float-real-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (store-long-reg imag-tn y (- (* vm:complex-long-float-imag-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +#+long-float +(define-move-vop move-from-complex-long :move + (complex-long-reg) (descriptor-reg)) + ;;; ;;; Move from a descriptor to a complex float register ;;; @@ -308,6 +504,22 @@ (define-move-vop move-to-complex-double :move (descriptor-reg) (complex-double-reg)) +#+long-float +(define-vop (move-to-complex-long) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-long-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-long-reg-real-tn y))) + (load-long-reg real-tn x (- (* complex-long-float-real-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-long-reg-imag-tn y))) + (load-long-reg imag-tn x (- (* complex-long-float-imag-slot word-bytes) + other-pointer-type))))) +#+long-float +(define-move-vop move-to-complex-long :move + (descriptor-reg) (complex-long-reg)) + ;;; ;;; Complex float move-argument vop ;;; @@ -359,12 +571,39 @@ (define-move-vop move-complex-double-float-argument :move-argument (complex-double-reg descriptor-reg) (complex-double-reg)) +#+long-float +(define-vop (move-complex-long-float-argument) + (:args (x :scs (complex-long-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg)))) + (:results (y)) + (:note "complex long-float argument move") + (:generator 2 + (sc-case y + (complex-long-reg + (unless (location= x y) + (let ((x-real (complex-long-reg-real-tn x)) + (y-real (complex-long-reg-real-tn y))) + (move-long-reg y-real x-real)) + (let ((x-imag (complex-long-reg-imag-tn x)) + (y-imag (complex-long-reg-imag-tn y))) + (move-long-reg y-imag x-imag)))) + (complex-long-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-long-reg-real-tn x))) + (store-long-reg real-tn nfp offset)) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (store-long-reg imag-tn nfp (+ offset (* 4 word-bytes))))))))) +#+long-float +(define-move-vop move-complex-long-float-argument :move-argument + (complex-long-reg descriptor-reg) (complex-long-reg)) + ) ; progn complex-float (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)) @@ -386,7 +625,9 @@ (:arg-types ,ptype ,ptype) (:result-types ,ptype)))) (frob single-float-op single-reg single-float) - (frob double-float-op double-reg double-float)) + (frob double-float-op double-reg double-float) + #+long-float + (frob long-float-op long-reg long-float)) (macrolet ((frob (op sinst sname scost dinst dname dcost) `(progn @@ -403,7 +644,19 @@ (frob * fmuls */single-float 4 fmuld */double-float 5) (frob / fdivs //single-float 12 fdivd //double-float 19)) -(macrolet ((frob (name inst translate double-p sc type) +#+long-float +(macrolet ((frob (op linst lname lcost) + `(define-vop (,lname long-float-op) + (:translate ,op) + (:generator ,lcost + (inst ,linst r x y))))) + (frob + faddx +/long-float 2) + (frob - fsubx -/long-float 2) + (frob * fmulx */long-float 6) + (frob / fdivx //long-float 20)) + + +(macrolet ((frob (name inst translate sc type) `(define-vop (,name) (:args (x :scs (,sc))) (:results (y :scs (,sc))) @@ -416,13 +669,113 @@ (:save-p :compute-only) (:generator 1 (note-this-location vop :internal-error) - (inst ,inst y x) - ,@(when double-p - '((inst fmovs-odd y x))))))) - (frob abs/single-float fabss abs nil single-reg single-float) - (frob abs/double-float fabss abs t double-reg double-float) - (frob %negate/single-float fnegs %negate nil single-reg single-float) - (frob %negate/double-float fnegs %negate t double-reg double-float)) + (inst ,inst y x))))) + (frob abs/single-float fabss abs single-reg single-float) + (frob %negate/single-float fnegs %negate single-reg single-float)) + +(define-vop (abs/double-float) + (:args (x :scs (double-reg))) + (:results (y :scs (double-reg))) + (:translate abs) + (:policy :fast-safe) + (:arg-types double-float) + (:result-types double-float) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (cond ((backend-featurep :sparc-v9) + (inst fabsd y x)) + (t + (inst fabss y x) + (let ((y-odd (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset y)))) + (x-odd (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset x))))) + (inst fmovs y-odd x-odd)))))) + +(define-vop (%negate/double-float) + (:args (x :scs (double-reg))) + (:results (y :scs (double-reg))) + (:translate %negate) + (:policy :fast-safe) + (:arg-types double-float) + (:result-types double-float) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (cond ((backend-featurep :sparc-v9) + (inst fnegd y x)) + (t + (inst fnegs y x) + (let ((y-odd (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset y)))) + (x-odd (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset x))))) + (inst fmovs y-odd x-odd)))))) + +#+long-float +(define-vop (abs/long-float) + (:args (x :scs (long-reg))) + (:results (y :scs (long-reg))) + (:translate abs) + (:policy :fast-safe) + (:arg-types long-float) + (:result-types long-float) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (cond ((backend-featurep :sparc-v9) + (inst fabsx y x)) + (t + (inst fabss y x) + (dotimes (i 3) + (let ((y-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset y)))) + (x-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset x))))) + (inst fmovs y-odd x-odd))))))) + +#+long-float +(define-vop (%negate/long-float) + (:args (x :scs (long-reg))) + (:results (y :scs (long-reg))) + (:translate %negate) + (:policy :fast-safe) + (:arg-types long-float) + (:result-types long-float) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (cond ((backend-featurep :sparc-v9) + (inst fnegx y x)) + (t + (inst fnegs y x) + (dotimes (i 3) + (let ((y-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset y)))) + (x-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset x))))) + (inst fmovs y-odd x-odd))))))) ;;;; Comparison: @@ -440,7 +793,8 @@ (note-this-location vop :internal-error) (ecase format (:single (inst fcmps x y)) - (:double (inst fcmpd x y))) + (:double (inst fcmpd x y)) + (:long (inst fcmpx x y))) (inst nop) (inst fb (if not-p nope yep) target) (inst nop))) @@ -451,28 +805,42 @@ (y :scs (,sc))) (:arg-types ,ptype ,ptype)))) (frob single-float-compare single-reg single-float) - (frob double-float-compare double-reg double-float)) + (frob double-float-compare double-reg double-float) + #+long-float + (frob long-float-compare long-reg long-float)) -(macrolet ((frob (translate yep nope sname dname) +(macrolet ((frob (translate yep nope sname dname #+long-float lname) `(progn (define-vop (,sname single-float-compare) (:translate ,translate) (:variant :single ,yep ,nope)) (define-vop (,dname double-float-compare) (:translate ,translate) - (:variant :double ,yep ,nope))))) - (frob < :l :ge </single-float </double-float) - (frob > :g :le >/single-float >/double-float) - (frob = :eq :ne eql/single-float eql/double-float)) + (:variant :double ,yep ,nope)) + #+long-float + (define-vop (,lname long-float-compare) + (:translate ,translate) + (:variant :long ,yep ,nope))))) + (frob < :l :ge </single-float </double-float #+long-float </long-float) + (frob > :g :le >/single-float >/double-float #+long-float >/long-float) + (frob = :eq :ne eql/single-float eql/double-float #+long-float eql/long-float)) + +#+long-float +(deftransform eql ((x y) (long-float long-float)) + '(and (= (long-float-low-bits x) (long-float-low-bits y)) + (= (long-float-mid-bits x) (long-float-mid-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 inst to-sc to-type) `(define-vop (,name) - (:args (x :scs (signed-reg) :target temp + (:args (x :scs (signed-reg) :target stack-temp :load-if (not (sc-is x signed-stack)))) - (:temporary (:scs (single-stack)) temp) + (:temporary (:scs (single-stack) :from :argument) stack-temp) + (:temporary (:scs (single-reg) :to :result :target y) temp) (:results (y :scs (,to-sc))) (:arg-types signed-num) (:result-types ,to-type) @@ -488,16 +856,18 @@ (inst st x (current-nfp-tn vop) (* (tn-offset temp) vm:word-bytes)) - temp) + stack-temp) (signed-stack x)))) - (inst ldf y + (inst ldf temp (current-nfp-tn vop) (* (tn-offset stack-tn) vm:word-bytes)) (note-this-location vop :internal-error) - (inst ,inst y y)))))) + (inst ,inst y temp)))))) (frob %single-float/signed %single-float fitos single-reg single-float) - (frob %double-float/signed %double-float fitod double-reg double-float)) + (frob %double-float/signed %double-float fitod double-reg double-float) + #+long-float + (frob %long-float/signed %long-float fitox long-reg long-float)) (macrolet ((frob (name translate inst from-sc from-type to-sc to-type) `(define-vop (,name) @@ -515,8 +885,20 @@ (inst ,inst y x))))) (frob %single-float/double-float %single-float fdtos double-reg double-float single-reg single-float) + #+long-float + (frob %single-float/long-float %single-float fxtos + long-reg long-float single-reg single-float) (frob %double-float/single-float %double-float fstod - single-reg single-float double-reg double-float)) + single-reg single-float double-reg double-float) + #+long-float + (frob %double-float/long-float %double-float fxtod + long-reg long-float double-reg double-float) + #+long-float + (frob %long-float/single-float %long-float fstox + single-reg single-float long-reg long-float) + #+long-float + (frob %long-float/double-float %long-float fdtox + double-reg double-float long-reg long-float)) (macrolet ((frob (trans from-sc from-type inst) `(define-vop (,(symbolicate trans "/" from-type)) @@ -546,6 +928,8 @@ (* (tn-offset stack-temp) vm:word-bytes)))))))) (frob %unary-truncate single-reg single-float fstoi) (frob %unary-truncate double-reg double-float fdtoi) + #+long-float + (frob %unary-truncate long-reg long-float fxtoi) #-sun4 (frob %unary-round single-reg single-float fstoir) #-sun4 @@ -622,6 +1006,36 @@ (inst lddf res (current-nfp-tn vop) (* (tn-offset temp) vm:word-bytes))))) +#+long-float +(define-vop (make-long-float) + (:args (hi-bits :scs (signed-reg)) + (lo1-bits :scs (unsigned-reg)) + (lo2-bits :scs (unsigned-reg)) + (lo3-bits :scs (unsigned-reg))) + (:results (res :scs (long-reg) + :load-if (not (sc-is res long-stack)))) + (:temporary (:scs (long-stack)) temp) + (:arg-types signed-num unsigned-num unsigned-num unsigned-num) + (:result-types long-float) + (:translate make-long-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((stack-tn (sc-case res + (long-stack res) + (long-reg temp)))) + (inst st hi-bits (current-nfp-tn vop) + (* (tn-offset stack-tn) vm:word-bytes)) + (inst st lo1-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-tn)) vm:word-bytes)) + (inst st lo2-bits (current-nfp-tn vop) + (* (+ 2 (tn-offset stack-tn)) vm:word-bytes)) + (inst st lo3-bits (current-nfp-tn vop) + (* (+ 3 (tn-offset stack-tn)) vm:word-bytes))) + (when (sc-is res long-reg) + (load-long-reg res (current-nfp-tn vop) + (* (tn-offset temp) vm:word-bytes))))) + (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) :load-if (not (sc-is float single-stack)))) @@ -647,7 +1061,8 @@ (inst ld bits (current-nfp-tn vop) (* (tn-offset float) vm:word-bytes))) (descriptor-reg - (loadw bits float vm:single-float-value-slot vm:other-pointer-type)))) + (loadw bits float vm:single-float-value-slot + vm:other-pointer-type)))) (signed-stack (sc-case float (single-reg @@ -657,68 +1072,162 @@ (define-vop (double-float-high-bits) (:args (float :scs (double-reg descriptor-reg) :load-if (not (sc-is float double-stack)))) - (:results (hi-bits :scs (signed-reg) - :load-if (or (sc-is float descriptor-reg double-stack) - (not (sc-is hi-bits signed-stack))))) - (:temporary (:scs (signed-stack)) stack-temp) + (:results (hi-bits :scs (signed-reg))) + (:temporary (:scs (double-stack)) stack-temp) (:arg-types double-float) (:result-types signed-num) (:translate double-float-high-bits) (:policy :fast-safe) (:vop-var vop) (:generator 5 - (sc-case hi-bits - (signed-reg - (sc-case float - (double-reg - (inst stf float (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst ld hi-bits (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes))) - (double-stack - (inst ld hi-bits (current-nfp-tn vop) - (* (tn-offset float) vm:word-bytes))) - (descriptor-reg - (loadw hi-bits float vm:double-float-value-slot - vm:other-pointer-type)))) - (signed-stack - (sc-case float - (double-reg - (inst stf float (current-nfp-tn vop) - (* (tn-offset hi-bits) vm:word-bytes)))))))) + (sc-case float + (double-reg + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ld hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (double-stack + (inst ld hi-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw hi-bits float vm:double-float-value-slot + vm:other-pointer-type))))) (define-vop (double-float-low-bits) (:args (float :scs (double-reg descriptor-reg) :load-if (not (sc-is float double-stack)))) - (:results (lo-bits :scs (unsigned-reg) - :load-if (or (sc-is float descriptor-reg double-stack) - (not (sc-is lo-bits unsigned-stack))))) - (:temporary (:scs (unsigned-stack)) stack-temp) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) (:arg-types double-float) (:result-types unsigned-num) (:translate double-float-low-bits) (:policy :fast-safe) (:vop-var vop) (:generator 5 - (sc-case lo-bits - (unsigned-reg - (sc-case float - (double-reg - (inst stf-odd float (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst ld lo-bits (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes))) - (double-stack - (inst ld lo-bits (current-nfp-tn vop) - (* (1+ (tn-offset float)) vm:word-bytes))) - (descriptor-reg - (loadw lo-bits float (1+ vm:double-float-value-slot) - vm:other-pointer-type)))) - (unsigned-stack - (sc-case float - (double-reg - (inst stf-odd float (current-nfp-tn vop) - (* (tn-offset lo-bits) vm:word-bytes)))))))) + (sc-case float + (double-reg + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ld lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (double-stack + (inst ld lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw lo-bits float (1+ 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 (:scs (double-stack)) 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 + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset float)))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld exp-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (long-stack + (inst ld exp-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw exp-bits float vm:long-float-value-slot + 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 (high-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) 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 + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset float)))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld high-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (long-stack + (inst ld high-bits (current-nfp-tn vop) + (* (1+ (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw high-bits float (1+ vm:long-float-value-slot) + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-mid-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (mid-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-mid-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset float))))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld mid-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (long-stack + (inst ld mid-bits (current-nfp-tn vop) + (* (+ 2 (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw mid-bits float (+ 2 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 (:scs (double-stack)) 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 + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset float))))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (long-stack + (inst ld lo-bits (current-nfp-tn vop) + (* (+ 3 (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw lo-bits float (+ 3 vm:long-float-value-slot) + vm:other-pointer-type))))) ;;;; Float mode hackery: @@ -759,6 +1268,7 @@ ;;;; Special functions. +#-long-float (define-vop (fsqrt) (:args (x :scs (double-reg))) (:results (y :scs (double-reg))) @@ -774,6 +1284,21 @@ (note-this-location vop :internal-error) (inst fsqrtd y x))) +#+long-float +(define-vop (fsqrt) + (:args (x :scs (long-reg))) + (:results (y :scs (long-reg))) + (:translate %sqrt) + (:policy :fast-safe) + (:arg-types long-float) + (:result-types long-float) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst fsqrtx y x))) + ;;;; Complex float VOPs @@ -782,7 +1307,8 @@ (define-vop (make-complex-single-float) (:translate complex) - (:args (real :scs (single-reg) :target r) + (:args (real :scs (single-reg) :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) @@ -803,12 +1329,14 @@ (complex-single-stack (let ((nfp (current-nfp-tn vop)) (offset (* (tn-offset r) vm:word-bytes))) - (inst stf real nfp offset) + (unless (location= real r) + (inst stf real nfp offset)) (inst stf imag nfp (+ offset vm:word-bytes))))))) (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) :from (:argument 0) @@ -829,9 +1357,39 @@ (complex-double-stack (let ((nfp (current-nfp-tn vop)) (offset (* (tn-offset r) vm:word-bytes))) - (inst stdf real nfp offset) + (unless (location= real r) + (inst stdf real nfp offset)) (inst stdf imag nfp (+ offset (* 2 vm:word-bytes)))))))) +#+long-float +(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)) + (:arg-types long-float long-float) + (: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) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-long-reg + (let ((r-real (complex-long-reg-real-tn r))) + (unless (location= real r-real) + (move-long-reg r-real real))) + (let ((r-imag (complex-long-reg-imag-tn r))) + (unless (location= imag r-imag) + (move-long-reg r-imag imag)))) + (complex-long-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (unless (location= real r) + (store-long-reg real nfp offset)) + (store-long-reg imag nfp (+ offset (* 4 vm:word-bytes)))))))) + (define-vop (complex-single-float-value) (:args (x :scs (complex-single-reg) :target r :load-if (not (sc-is x complex-single-stack)))) @@ -896,4 +1454,39 @@ (:note "complex double float imagpart") (:variant :imag)) +#+long-float +(define-vop (complex-long-float-value) + (:args (x :scs (complex-long-reg) :target r + :load-if (not (sc-is x complex-long-stack)))) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case x + (complex-long-reg + (let ((value-tn (ecase slot + (:real (complex-long-reg-real-tn x)) + (:imag (complex-long-reg-imag-tn x))))) + (unless (location= value-tn r) + (move-long-reg r value-tn)))) + (complex-long-stack + (load-long-reg r (current-nfp-tn vop) + (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x)) + vm:word-bytes)))))) + +#+long-float +(define-vop (realpart/complex-long-float complex-long-float-value) + (:translate realpart) + (:note "complex long float realpart") + (:variant :real)) + +#+long-float +(define-vop (imagpart/complex-long-float complex-long-float-value) + (:translate imagpart) + (:note "complex long float imagpart") + (:variant :imag)) + ) ; progn complex-float diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp index af7f0b5fb..f977cb667 100644 --- a/compiler/sparc/insts.lisp +++ b/compiler/sparc/insts.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.17 1998/03/11 17:00:26 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.18 1998/03/21 08:05:23 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -36,13 +36,20 @@ (tn-offset tn) (error "~S isn't a register." tn))))) -(defun fp-reg-tn-encoding (tn &optional odd) +(defun fp-reg-tn-encoding (tn) (declare (type tn tn)) (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) (error "~S isn't a floating-point register." tn)) - (if odd - (1+ (tn-offset tn)) - (tn-offset tn))) + (let ((offset (tn-offset tn))) + (cond ((> offset 31) + ;; Use the sparc v9 double float register encoding. + (assert (backend-featurep :sparc-v9)) + ;; No single register encoding greater than reg 31. + (assert (zerop (mod offset 2))) + ;; Upper bit of the register number is encoded in the low bit. + (1+ (- offset 32))) + (t + (tn-offset tn))))) (disassem:set-disassem-params :instruction-alignment 32) @@ -59,7 +66,18 @@ (unless (zerop (tn-offset loc)) (tn-offset loc))) (float-registers - (+ (tn-offset loc) 32)) + (sc-case loc + (single-reg + (+ (tn-offset loc) 32)) + (double-reg + (let ((offset (tn-offset loc))) + (assert (zerop (mod offset 2))) + (values (+ offset 32) 2))) + #+long-float + (long-reg + (let ((offset (tn-offset loc))) + (assert (zerop (mod offset 4))) + (values (+ offset 32) 4))))) (control-registers 96) (immediate-constant @@ -108,7 +126,7 @@ dstate)))) ;;; The extended 6 bit floating point register encoding for the double -;;; and long instructions of the sparc V9. +;;; and long instructions of the sparc v9. (disassem:define-argument-type fp-ext-reg :printer #'(lambda (value stream dstate) (declare (stream stream) (fixnum value)) @@ -262,7 +280,7 @@ (opf :field (byte 9 5)) (rs2 :field (byte 5 0) :type 'fp-reg)) -;;; Double and long float instruction format of the sparc V9. +;;; Double and long float instruction format of the sparc v9. (disassem:define-instruction-format (format-binary-ext-fpop 32 :default-printer '(:name :tab rd ", " rs1 ", " rs2)) @@ -328,7 +346,7 @@ ;;;; Most of the format-3-instructions. (defun emit-format-3-inst (segment op op3 dst src1 src2 - &key load-store fixup dest-kind odd) + &key load-store fixup dest-kind) (unless src2 (cond ((and (typep src1 'tn) load-store) (setf src2 0)) @@ -339,13 +357,13 @@ (tn (emit-format-3-reg segment op (if dest-kind - (fp-reg-tn-encoding dst odd) + (fp-reg-tn-encoding dst) (reg-tn-encoding dst)) op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2))) (integer (emit-format-3-immed segment op (if dest-kind - (fp-reg-tn-encoding dst odd) + (fp-reg-tn-encoding dst) (reg-tn-encoding dst)) op3 (reg-tn-encoding src1) 1 src2)) (fixup @@ -354,7 +372,7 @@ (note-fixup segment :add src2) (emit-format-3-immed segment op (if dest-kind - (fp-reg-tn-encoding dst odd) + (fp-reg-tn-encoding dst) (reg-tn-encoding dst)) op3 (reg-tn-encoding src1) 1 0)))) @@ -393,13 +411,12 @@ ,(if (or fixup load-store) '(type (or tn (signed-byte 13) null fixup) src1 src2) '(type (or tn (signed-byte 13) null) src1 src2))) - ,@(unless (eq dest-kind 'odd-fp-reg) - `((:printer format-3-reg - ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) - ,printer) - (:printer format-3-immed - ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) - ,printer))) + (:printer format-3-reg + ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) + ,printer) + (:printer format-3-immed + ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) + ,printer) ,@(when flushable '((:attributes flushable))) (:dependencies @@ -437,8 +454,7 @@ (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2 :load-store ,load-store :fixup ,fixup - :dest-kind (not (eq ',dest-kind 'reg)) - :odd (eq ',dest-kind 'odd-fp-reg)))))) + :dest-kind (not (eq ',dest-kind 'reg))))))) ) ; eval-when (compile eval) @@ -449,15 +465,15 @@ (define-f3-inst ld #b11 #b000000 :load-store :load) (define-f3-inst ldd #b11 #b000011 :load-store :load) (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load) -(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load) (define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load) +(define-f3-inst ldxf #b11 #b100010 :dest-kind fp-reg :load-store :load) ; v9 (define-f3-inst stb #b11 #b000101 :load-store :store) (define-f3-inst sth #b11 #b000110 :load-store :store) (define-f3-inst st #b11 #b000100 :load-store :store) (define-f3-inst std #b11 #b000111 :load-store :store) (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store) -(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store) (define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store) +(define-f3-inst stxf #b11 #b100110 :dest-kind fp-reg :load-store :store) ; v9 (define-f3-inst ldstub #b11 #b001101 :load-store t) (define-f3-inst swap #b11 #b001111 :load-store t) (define-f3-inst add #b10 #b000000 :fixup t) @@ -491,6 +507,18 @@ (define-f3-inst save #b10 #b111100 :reads :psr :writes :psr) (define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr) +(define-f3-inst smul #b10 #b001011 :writes :y) ; v8 +(define-f3-inst smulcc #b10 #b011011 :writes (:psr :y)) ; v8 +(define-f3-inst umul #b10 #b001010 :writes :y) ; v8 +(define-f3-inst umulcc #b10 #b011010 :writes (:psr :y)) ; v8 +(define-f3-inst sdiv #b10 #b001111 :reads :y) ; v8 +(define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr) ; v8 +(define-f3-inst udiv #b10 #b001110 :reads :y) ; v8 +(define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr) ; v8 + +(define-f3-inst mulx #b10 #b001001) ; v9 for both signed and unsigned +(define-f3-inst sdivx #b10 #b101101) ; v9 +(define-f3-inst udivx #b10 #b001101) ; v9 ;;;; Random instructions. @@ -856,7 +884,7 @@ (define-unary-fp-inst fitos #b011000100 :reads :fsr) (define-unary-ext-fp-inst fitod #b011001000 :reads :fsr) -(define-unary-ext-fp-inst fitox #b011001100 :reads :fsr) +(define-unary-ext-fp-inst fitox #b011001100 :reads :fsr) ; v8 (define-unary-fp-inst fstoir #b011000001 :reads :fsr) (define-unary-ext-fp-inst fdtoir #b011000010 :reads :fsr) @@ -864,56 +892,53 @@ (define-unary-fp-inst fstoi #b011010001) (define-unary-ext-fp-inst fdtoi #b011010010) -(define-unary-ext-fp-inst fxtoi #b011010011) +(define-unary-ext-fp-inst fxtoi #b011010011) ; v8 (define-unary-fp-inst fstod #b011001001 :reads :fsr) -(define-unary-fp-inst fstox #b011001101 :reads :fsr) +(define-unary-fp-inst fstox #b011001101 :reads :fsr) ; v8 (define-unary-fp-inst fdtos #b011000110 :reads :fsr) -(define-unary-fp-inst fdtox #b011001110 :reads :fsr) -(define-unary-fp-inst fxtos #b011000111 :reads :fsr) -(define-unary-fp-inst fxtod #b011001011 :reads :fsr) +(define-unary-fp-inst fdtox #b011001110 :reads :fsr) ; v8 +(define-unary-fp-inst fxtos #b011000111 :reads :fsr) ; v8 +(define-unary-fp-inst fxtod #b011001011 :reads :fsr) ; v8 (define-unary-fp-inst fmovs #b000000001) -(define-instruction fmovs-odd (segment dst src1) - (:declare (type tn dst src1)) - (:dependencies (reads dst) (reads src1) (writes dst)) - (:delay 0) - (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst t) - #b110100 0 #b000000001 - (fp-reg-tn-encoding src1 t)))) -(define-unary-ext-fp-inst fmovd #b000000010) ; V9 -(define-unary-ext-fp-inst fmovq #b000000011) ; V9 +(define-unary-ext-fp-inst fmovd #b000000010) ; v9 +(define-unary-ext-fp-inst fmovx #b000000011) ; v9 (define-unary-fp-inst fnegs #b000000101) -(define-unary-fp-inst fabss #b000001001) +(define-unary-ext-fp-inst fnegd #b000000110) ; v9 +(define-unary-ext-fp-inst fnegx #b000000111) ; v9 -(define-unary-fp-inst fsqrts #b000101001 :reads :fsr) -(define-unary-ext-fp-inst fsqrtd #b000101010 :reads :fsr) -(define-unary-ext-fp-inst fsqrtx #b000101011 :reads :fsr) +(define-unary-fp-inst fabss #b000001001) +(define-unary-ext-fp-inst fabsd #b000001010) ; v9 +(define-unary-ext-fp-inst fabsx #b000001011) ; v9 +(define-unary-fp-inst fsqrts #b000101001 :reads :fsr) ; V7 +(define-unary-ext-fp-inst fsqrtd #b000101010 :reads :fsr) ; V7 +(define-unary-ext-fp-inst fsqrtx #b000101011 :reads :fsr) ; v8 (define-binary-fp-inst fadds #b001000001) (define-binary-ext-fp-inst faddd #b001000010) -(define-binary-ext-fp-inst faddx #b001000011) +(define-binary-ext-fp-inst faddx #b001000011) ; v8 (define-binary-fp-inst fsubs #b001000101) (define-binary-ext-fp-inst fsubd #b001000110) -(define-binary-ext-fp-inst fsubx #b001000111) +(define-binary-ext-fp-inst fsubx #b001000111) ; v8 (define-binary-fp-inst fmuls #b001001001) (define-binary-ext-fp-inst fmuld #b001001010) -(define-binary-ext-fp-inst fmulx #b001001011) +(define-binary-ext-fp-inst fmulx #b001001011) ; v8 (define-binary-fp-inst fdivs #b001001101) (define-binary-ext-fp-inst fdivd #b001001110) -(define-binary-ext-fp-inst fdivx #b001001111) +(define-binary-ext-fp-inst fdivx #b001001111) ; v8 ;;; Float comparison instructions. ;;; (define-cmp-fp-inst fcmps #b001010001) (define-cmp-ext-fp-inst fcmpd #b001010010) -(define-cmp-ext-fp-inst fcmpx #b001010011) +(define-cmp-ext-fp-inst fcmpx #b001010011) ; v8 (define-cmp-fp-inst fcmpes #b001010101) (define-cmp-ext-fp-inst fcmped #b001010110) -(define-cmp-ext-fp-inst fcmpex #b001010111) +(define-cmp-ext-fp-inst fcmpex #b001010111) ; v8 diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp index 597db72d3..e58d6915b 100644 --- a/compiler/sparc/parms.lisp +++ b/compiler/sparc/parms.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.26 1998/03/11 18:04:59 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.27 1998/03/21 08:05:24 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -63,6 +63,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)) @@ -102,12 +107,24 @@ (defconstant double-float-hidden-bit (ash 1 20)) (defconstant double-float-trapping-nan-bit (ash 1 19)) +;;; X These values are for the x86 80 bit format and are no doubt +;;; incorrect for the sparc. +(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)) +(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)) (defconstant float-inexact-trap-bit (ash 1 0)) (defconstant float-divide-by-zero-trap-bit (ash 1 1)) diff --git a/compiler/sparc/sap.lisp b/compiler/sparc/sap.lisp index 98d7bd4d0..18388e10d 100644 --- a/compiler/sparc/sap.lisp +++ b/compiler/sparc/sap.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.8 1997/04/26 20:05:05 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.9 1998/03/21 08:05:24 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -172,13 +172,15 @@ (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 - (inst ,(ecase size - (:byte (if signed 'ldsb 'ldub)) - (:short (if signed 'ldsh 'lduh)) - (:long 'ld) - (:single 'ldf) - (:double 'lddf)) - result sap offset))) + ,@(if (eql size :long-float) + '((load-long-reg result sap offset t)) + `((inst ,(ecase size + (:byte (if signed 'ldsb 'ldub)) + (:short (if signed 'ldsh 'lduh)) + (:long 'ld) + (:single 'ldf) + (:double 'lddf)) + result sap offset))))) (define-vop (,ref-name-c) (:translate ,ref-name) (:policy :fast-safe) @@ -188,13 +190,15 @@ (:results (result :scs (,sc))) (:result-types ,type) (:generator 4 - (inst ,(ecase size - (:byte (if signed 'ldsb 'ldub)) - (:short (if signed 'ldsh 'lduh)) - (:long 'ld) - (:single 'ldf) - (:double 'lddf)) - result sap offset))) + ,@(if (eql size :long-float) + '((load-long-reg result sap offset t)) + `((inst ,(ecase size + (:byte (if signed 'ldsb 'ldub)) + (:short (if signed 'ldsh 'lduh)) + (:long 'ld) + (:single 'ldf) + (:double 'lddf)) + result sap offset))))) (define-vop (,set-name) (:translate ,set-name) (:policy :fast-safe) @@ -205,20 +209,23 @@ (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 - (inst ,(ecase size - (:byte 'stb) - (:short 'sth) - (:long 'st) - (:single 'stf) - (:double 'stdf)) - value sap offset) + ,@(if (eql size :long-float) + '((store-long-reg value sap offset t)) + `((inst ,(ecase size + (:byte 'stb) + (:short 'sth) + (:long 'st) + (:single 'stf) + (:double 'stdf)) + value sap offset))) (unless (location= result value) ,@(case size (:single '((inst fmovs result value))) (:double - '((inst fmovs result value) - (inst fmovs-odd result value))) + '((move-double-reg result value))) + (:long-float + '((move-long-reg result value))) (t '((inst move result value))))))) (define-vop (,set-name-c) @@ -231,20 +238,23 @@ (:results (result :scs (,sc))) (:result-types ,type) (:generator 4 - (inst ,(ecase size - (:byte 'stb) - (:short 'sth) - (:long 'st) - (:single 'stf) - (:double 'stdf)) - value sap offset) + ,@(if (eql size :long-float) + '((store-long-reg value sap offset t)) + `((inst ,(ecase size + (:byte 'stb) + (:short 'sth) + (:long 'st) + (:single 'stf) + (:double 'stdf)) + value sap offset))) (unless (location= result value) ,@(case size (:single '((inst fmovs result value))) (:double - '((inst fmovs result value) - (inst fmovs-odd result value))) + '((move-double-reg result value))) + (:long-float + '((move-long-reg result value))) (t '((inst move result value)))))))))) @@ -268,6 +278,9 @@ single-reg single-float :single) (def-system-ref-and-set sap-ref-double %set-sap-ref-double double-reg double-float :double) +#+long-float +(def-system-ref-and-set sap-ref-long %set-sap-ref-long + long-reg long-float :long-float) diff --git a/compiler/sparc/type-vops.lisp b/compiler/sparc/type-vops.lisp index 0e27541ed..258d9ae00 100644 --- a/compiler/sparc/type-vops.lisp +++ b/compiler/sparc/type-vops.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.17 1998/01/21 05:10:18 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.18 1998/03/21 08:05:25 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -14,7 +14,7 @@ ;;; ;;; Written by William Lott. ;;; Signed-array support by Douglas Crosher 1997. -;;; Complex-float support by Douglas Crosher 1998. +;;; Complex-float and long-float support by Douglas Crosher 1998. ;;; (in-package "SPARC") @@ -113,7 +113,8 @@ (def-type-vops complexp check-complex complex object-not-complex-error vm:complex-type #+complex-float vm:complex-single-float-type - #+complex-float vm:complex-double-float-type) + #+complex-float vm:complex-double-float-type + #+(and complex-float long-float) vm:complex-long-float-type) #+complex-float (def-type-vops complex-rational-p check-complex-rational nil @@ -122,7 +123,8 @@ #+complex-float (def-type-vops complex-float-p check-complex-float nil object-not-complex-float-error - vm:complex-single-float-type vm:complex-double-float-type) + vm:complex-single-float-type vm:complex-double-float-type + #+long-float vm:complex-long-float-type) #+complex-float (def-type-vops complex-single-float-p check-complex-single-float @@ -134,12 +136,21 @@ complex-double-float object-not-complex-double-float-error vm: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 + vm:complex-long-float-type) + (def-type-vops single-float-p check-single-float single-float object-not-single-float-error vm:single-float-type) (def-type-vops double-float-p check-double-float double-float object-not-double-float-error vm:double-float-type) +#+long-float +(def-type-vops long-float-p check-long-float long-float + object-not-long-float-error vm:long-float-type) + (def-type-vops simple-string-p check-simple-string simple-string object-not-simple-string-error vm:simple-string-type) @@ -215,6 +226,11 @@ simple-array-double-float object-not-simple-array-double-float-error vm: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 + vm:simple-array-long-float-type) + #+complex-float (def-type-vops simple-array-complex-single-float-p check-simple-array-complex-single-float @@ -229,6 +245,13 @@ object-not-simple-array-complex-double-float-error vm: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 + vm:simple-array-complex-long-float-type) + (def-type-vops base-char-p check-base-char base-char object-not-base-char-error vm:base-char-type) @@ -279,8 +302,10 @@ #+signed-array simple-array-signed-byte-30-type #+signed-array simple-array-signed-byte-32-type vm:simple-array-single-float-type vm:simple-array-double-float-type + #+long-float vm:simple-array-long-float-type #+complex-float vm:simple-array-complex-single-float-type #+complex-float vm:simple-array-complex-double-float-type + #+(and complex-float long-float) vm:simple-array-complex-long-float-type vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type) (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error @@ -293,8 +318,10 @@ #+signed-array simple-array-signed-byte-30-type #+signed-array simple-array-signed-byte-32-type vm:simple-array-single-float-type vm:simple-array-double-float-type + #+long-float vm:simple-array-long-float-type #+complex-float vm:simple-array-complex-single-float-type - #+complex-float vm:simple-array-complex-double-float-type) + #+complex-float vm:simple-array-complex-double-float-type + #+(and complex-float long-float) vm:simple-array-complex-long-float-type) (def-type-vops arrayp check-array nil object-not-array-error vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type @@ -306,16 +333,20 @@ #+signed-array simple-array-signed-byte-30-type #+signed-array simple-array-signed-byte-32-type vm:simple-array-single-float-type vm:simple-array-double-float-type + #+long-float vm:simple-array-long-float-type #+complex-float vm:simple-array-complex-single-float-type #+complex-float vm:simple-array-complex-double-float-type + #+(and complex-float long-float) vm:simple-array-complex-long-float-type vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type vm:complex-array-type) (def-type-vops numberp check-number nil object-not-number-error vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type - vm:single-float-type vm:double-float-type vm:complex-type + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type + vm:complex-type #+complex-float vm:complex-single-float-type - #+complex-float vm:complex-double-float-type) + #+complex-float vm:complex-double-float-type + #+(and complex-float long-float) vm:complex-long-float-type) (def-type-vops rationalp check-rational nil object-not-rational-error vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) @@ -324,11 +355,11 @@ vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type) (def-type-vops floatp check-float nil object-not-float-error - vm:single-float-type vm:double-float-type) + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type) (def-type-vops realp check-real nil object-not-real-error vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type - vm:single-float-type vm:double-float-type) + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type) ;;;; Other integer ranges. diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp index cd232b981..56950890c 100644 --- a/compiler/sparc/vm.lisp +++ b/compiler/sparc/vm.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.11 1998/03/11 17:11:37 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.12 1998/03/21 08:05:25 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -148,12 +148,17 @@ (single-stack non-descriptor-stack) ; single-floats (double-stack non-descriptor-stack :element-size 2 :alignment 2) ; double floats. + #+long-float + (long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats. #+complex-float ;; complex-single-floats (complex-single-stack non-descriptor-stack :element-size 2) #+complex-float ;; complex-double-floats. (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) + #+(and complex-float long-float) + ;; complex-long-floats. + (complex-long-stack non-descriptor-stack :element-size 8 :alignment 4) ;; **** Things that can go in the integer registers. @@ -213,35 +218,61 @@ ;; Non-Descriptor single-floats. (single-reg float-registers - :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + :locations #.(loop for i from 0 to 31 collect i) + :reserve-locations (28 29 30 31) :constant-scs () :save-p t :alternate-scs (single-stack)) ;; Non-Descriptor double-floats. (double-reg float-registers - :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 61 + by 2 collect i) :element-size 2 :alignment 2 + :reserve-locations (28 30) :constant-scs () :save-p t :alternate-scs (double-stack)) + ;; Non-Descriptor double-floats. + #+long-float + (long-reg float-registers + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 61 + by 4 collect i) + :element-size 4 :alignment 4 + :reserve-locations (28) + :constant-scs () + :save-p t + :alternate-scs (long-stack)) + #+complex-float (complex-single-reg float-registers - :locations (0 4 8 12 16 20 24 28) - :element-size 4 + :locations #.(loop for i from 0 to 31 by 2 collect i) + :element-size 2 :alignment 2 + :reserve-locations (28 30) :constant-scs () :save-p t :alternate-scs (complex-single-stack)) #+complex-float (complex-double-reg float-registers - :locations (0 4 8 12 16 20 24 28) - :element-size 4 + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 61 + by 4 collect i) + :element-size 4 :alignment 4 + :reserve-locations (28) :constant-scs () :save-p t :alternate-scs (complex-double-stack)) + #+(and complex-float long-float) + (complex-long-reg float-registers + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 61 + by 8 collect i) + :element-size 8 :alignment 8 + :constant-scs () + :save-p t + :alternate-scs (complex-long-stack)) + ;; A catch or unwind block. (catch-block control-stack :element-size vm:catch-block-size)) -- GitLab