X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmips%2Ffloat.lisp;h=685c49d423349f080b8dba1acea058b8cb7a81d4;hb=eda83f00e869193cb69826be5fa1086b95d12ff7;hp=68655a187c4a4ed360c50e5973075c80cd793f75;hpb=63817d29028c8551cda23f432a3328acd7fdd62f;p=sbcl.git diff --git a/src/compiler/mips/float.lisp b/src/compiler/mips/float.lisp index 68655a1..685c49d 100644 --- a/src/compiler/mips/float.lisp +++ b/src/compiler/mips/float.lisp @@ -30,11 +30,11 @@ (:little-endian (inst lwc1 r base offset) (inst lwc1-odd r base (+ offset n-word-bytes))))) - + (define-move-fun (load-double 2) (vop x y) ((double-stack) (double-reg)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) n-word-bytes))) + (offset (* (tn-offset x) n-word-bytes))) (ld-double y nfp offset)) (inst nop)) @@ -50,23 +50,23 @@ (define-move-fun (store-double 2) (vop x y) ((double-reg) (double-stack)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) n-word-bytes))) + (offset (* (tn-offset y) n-word-bytes))) (str-double x nfp offset))) ;;;; Move VOPs: (macrolet ((frob (vop sc format) - `(progn - (define-vop (,vop) - (:args (x :scs (,sc) - :target y - :load-if (not (location= x y)))) - (:results (y :scs (,sc) - :load-if (not (location= x y)))) - (:note "float move") - (:generator 0 - (unless (location= y x) - (inst fmove ,format y x)))) - (define-move-vop ,vop :move (,sc) (,sc))))) + `(progn + (define-vop (,vop) + (:args (x :scs (,sc) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (,sc) + :load-if (not (location= x y)))) + (:note "float move") + (:generator 0 + (unless (location= y x) + (inst fmove ,format y x)))) + (define-move-vop ,vop :move (,sc) (,sc))))) (frob single-move single-reg :single) (frob double-move double-reg :double)) @@ -78,83 +78,83 @@ (:variant-vars double-p size type data) (:note "float to pointer coercion") (:generator 13 - (with-fixed-allocation (y pa-flag ndescr type size) + (with-fixed-allocation (y pa-flag ndescr type size nil) (if double-p - (str-double x y (- (* data n-word-bytes) other-pointer-lowtag)) - (inst swc1 x y (- (* data n-word-bytes) other-pointer-lowtag)))))) + (str-double x y (- (* data n-word-bytes) other-pointer-lowtag)) + (inst swc1 x y (- (* data n-word-bytes) other-pointer-lowtag)))))) (macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-float) - (:args (x :scs (,sc) :to :save)) - (:results (y :scs (descriptor-reg))) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) + `(progn + (define-vop (,name move-from-float) + (:args (x :scs (,sc) :to :save)) + (:results (y :scs (descriptor-reg))) + (:variant ,@args)) + (define-move-vop ,name :move (,sc) (descriptor-reg))))) (frob move-from-single single-reg nil single-float-size single-float-widetag single-float-value-slot) (frob move-from-double double-reg t double-float-size double-float-widetag double-float-value-slot)) (macrolet ((frob (name sc double-p value) - `(progn - (define-vop (,name) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (,sc))) - (:note "pointer to float coercion") - (:generator 2 - ,@(ecase *backend-byte-order* - (:big-endian - (cond - (double-p - `((inst lwc1 y x (- (* (1+ ,value) n-word-bytes) - other-pointer-lowtag)) - (inst lwc1-odd y x (- (* ,value n-word-bytes) - other-pointer-lowtag)))) - (t - `((inst lwc1 y x (- (* ,value n-word-bytes) - other-pointer-lowtag)))))) - (:little-endian - `((inst lwc1 y x (- (* ,value n-word-bytes) - other-pointer-lowtag)) - ,@(when double-p - `((inst lwc1-odd y x - (- (* (1+ ,value) n-word-bytes) - other-pointer-lowtag))))))) - (inst nop))) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to float coercion") + (:generator 2 + ,@(ecase *backend-byte-order* + (:big-endian + (cond + (double-p + `((inst lwc1 y x (- (* (1+ ,value) n-word-bytes) + other-pointer-lowtag)) + (inst lwc1-odd y x (- (* ,value n-word-bytes) + other-pointer-lowtag)))) + (t + `((inst lwc1 y x (- (* ,value n-word-bytes) + other-pointer-lowtag)))))) + (:little-endian + `((inst lwc1 y x (- (* ,value n-word-bytes) + other-pointer-lowtag)) + ,@(when double-p + `((inst lwc1-odd y x + (- (* (1+ ,value) n-word-bytes) + other-pointer-lowtag))))))) + (inst nop))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) (frob move-to-single single-reg nil single-float-value-slot) (frob move-to-double double-reg t double-float-value-slot)) (macrolet ((frob (name sc stack-sc format double-p) - `(progn - (define-vop (,name) - (:args (x :scs (,sc) :target y) - (nfp :scs (any-reg) - :load-if (not (sc-is y ,sc)))) - (:results (y)) - (:note "float argument move") - (:generator ,(if double-p 2 1) - (sc-case y - (,sc - (unless (location= x y) - (inst fmove ,format y x))) - (,stack-sc - (let ((offset (* (tn-offset y) n-word-bytes))) - ,@(ecase *backend-byte-order* - (:big-endian - (cond - (double-p - '((inst swc1 x nfp (+ offset n-word-bytes)) - (inst swc1-odd x nfp offset))) - (t - '((inst swc1 x nfp offset))))) - (:little-endian - `((inst swc1 x nfp offset) - ,@(when double-p - '((inst swc1-odd x nfp - (+ offset n-word-bytes)))))))))))) - (define-move-vop ,name :move-arg - (,sc descriptor-reg) (,sc))))) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (nfp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float argument move") + (:generator ,(if double-p 2 1) + (sc-case y + (,sc + (unless (location= x y) + (inst fmove ,format y x))) + (,stack-sc + (let ((offset (* (tn-offset y) n-word-bytes))) + ,@(ecase *backend-byte-order* + (:big-endian + (cond + (double-p + '((inst swc1 x nfp (+ offset n-word-bytes)) + (inst swc1-odd x nfp offset))) + (t + '((inst swc1 x nfp offset))))) + (:little-endian + `((inst swc1 x nfp offset) + ,@(when double-p + '((inst swc1-odd x nfp + (+ offset n-word-bytes)))))))))))) + (define-move-vop ,name :move-arg + (,sc descriptor-reg) (,sc))))) (frob move-single-float-arg single-reg single-stack :single nil) (frob move-double-float-arg double-reg double-stack :double t)) @@ -162,22 +162,22 @@ (defun complex-single-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) - :offset (tn-offset x))) + :offset (tn-offset x))) (defun complex-single-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) - :offset (+ (tn-offset x) 2))) + :offset (+ (tn-offset x) 2))) (defun complex-double-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) - :offset (tn-offset x))) + :offset (tn-offset x))) (defun complex-double-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) - :offset (+ (tn-offset x) 2))) + :offset (+ (tn-offset x) 2))) (define-move-fun (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) n-word-bytes))) + (offset (* (tn-offset x) n-word-bytes))) (let ((real-tn (complex-single-reg-real-tn y))) (inst lwc1 real-tn nfp offset)) (let ((imag-tn (complex-single-reg-imag-tn y))) @@ -187,7 +187,7 @@ (define-move-fun (store-complex-single 2) (vop x y) ((complex-single-reg) (complex-single-stack)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) n-word-bytes))) + (offset (* (tn-offset y) n-word-bytes))) (let ((real-tn (complex-single-reg-real-tn x))) (inst swc1 real-tn nfp offset)) (let ((imag-tn (complex-single-reg-imag-tn x))) @@ -196,7 +196,7 @@ (define-move-fun (load-complex-double 4) (vop x y) ((complex-double-stack) (complex-double-reg)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) n-word-bytes))) + (offset (* (tn-offset x) n-word-bytes))) (let ((real-tn (complex-double-reg-real-tn y))) (ld-double real-tn nfp offset)) (let ((imag-tn (complex-double-reg-imag-tn y))) @@ -206,7 +206,7 @@ (define-move-fun (store-complex-double 4) (vop x y) ((complex-double-reg) (complex-double-stack)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) n-word-bytes))) + (offset (* (tn-offset y) n-word-bytes))) (let ((real-tn (complex-double-reg-real-tn x))) (str-double real-tn nfp offset)) (let ((imag-tn (complex-double-reg-imag-tn x))) @@ -215,7 +215,7 @@ ;;; Complex float register to register moves. (define-vop (complex-single-move) (:args (x :scs (complex-single-reg) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) (:note "complex single float move") (:generator 0 @@ -223,17 +223,17 @@ ;; 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-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst fmove :single y-real x-real)) + (y-real (complex-single-reg-real-tn y))) + (inst fmove :single y-real x-real)) (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst fmove :single y-imag x-imag))))) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmove :single y-imag x-imag))))) (define-move-vop complex-single-move :move (complex-single-reg) (complex-single-reg)) (define-vop (complex-double-move) (:args (x :scs (complex-double-reg) - :target y :load-if (not (location= x y)))) + :target y :load-if (not (location= x y)))) (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) (:note "complex double float move") (:generator 0 @@ -241,11 +241,11 @@ ;; Note the complex-float-regs are aligned to every second ;; float register so there is not need to worry about overlap. (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst fmove :double y-real x-real)) + (y-real (complex-double-reg-real-tn y))) + (inst fmove :double y-real x-real)) (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fmove :double y-imag x-imag))))) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmove :double y-imag x-imag))))) (define-move-vop complex-double-move :move (complex-double-reg) (complex-double-reg)) @@ -259,15 +259,15 @@ (:note "complex single float to pointer coercion") (:generator 13 (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag - complex-single-float-size) + complex-single-float-size nil) (let ((real-tn (complex-single-reg-real-tn x))) - (inst swc1 real-tn y (- (* complex-single-float-real-slot - n-word-bytes) - other-pointer-lowtag))) + (inst swc1 real-tn y (- (* complex-single-float-real-slot + n-word-bytes) + other-pointer-lowtag))) (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst swc1 imag-tn y (- (* complex-single-float-imag-slot - n-word-bytes) - other-pointer-lowtag)))))) + (inst swc1 imag-tn y (- (* complex-single-float-imag-slot + n-word-bytes) + other-pointer-lowtag)))))) (define-move-vop move-from-complex-single :move (complex-single-reg) (descriptor-reg)) @@ -279,15 +279,15 @@ (:note "complex double float to pointer coercion") (:generator 13 (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag - complex-double-float-size) + complex-double-float-size nil) (let ((real-tn (complex-double-reg-real-tn x))) - (str-double real-tn y (- (* complex-double-float-real-slot - n-word-bytes) - other-pointer-lowtag))) + (str-double real-tn y (- (* complex-double-float-real-slot + n-word-bytes) + other-pointer-lowtag))) (let ((imag-tn (complex-double-reg-imag-tn x))) - (str-double imag-tn y (- (* complex-double-float-imag-slot - n-word-bytes) - other-pointer-lowtag)))))) + (str-double imag-tn y (- (* complex-double-float-imag-slot + n-word-bytes) + other-pointer-lowtag)))))) (define-move-vop move-from-complex-double :move (complex-double-reg) (descriptor-reg)) @@ -299,10 +299,10 @@ (:generator 2 (let ((real-tn (complex-single-reg-real-tn y))) (inst lwc1 real-tn x (- (* complex-single-float-real-slot n-word-bytes) - other-pointer-lowtag))) + other-pointer-lowtag))) (let ((imag-tn (complex-single-reg-imag-tn y))) (inst lwc1 imag-tn x (- (* complex-single-float-imag-slot n-word-bytes) - other-pointer-lowtag))) + other-pointer-lowtag))) (inst nop))) (define-move-vop move-to-complex-single :move (descriptor-reg) (complex-single-reg)) @@ -314,10 +314,10 @@ (:generator 2 (let ((real-tn (complex-double-reg-real-tn y))) (ld-double real-tn x (- (* complex-double-float-real-slot n-word-bytes) - other-pointer-lowtag))) + other-pointer-lowtag))) (let ((imag-tn (complex-double-reg-imag-tn y))) (ld-double imag-tn x (- (* complex-double-float-imag-slot n-word-bytes) - other-pointer-lowtag))) + other-pointer-lowtag))) (inst nop))) (define-move-vop move-to-complex-double :move (descriptor-reg) (complex-double-reg)) @@ -325,49 +325,49 @@ ;;; complex float MOVE-ARG VOP (define-vop (move-complex-single-float-arg) (:args (x :scs (complex-single-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) (:results (y)) (:note "complex single-float argument move") (:generator 1 (sc-case y (complex-single-reg (unless (location= x y) - (let ((x-real (complex-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst fmove :single y-real x-real)) - (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst fmove :single y-imag x-imag)))) + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmove :single y-real x-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmove :single y-imag x-imag)))) (complex-single-stack (let ((offset (* (tn-offset y) n-word-bytes))) - (let ((real-tn (complex-single-reg-real-tn x))) - (inst swc1 real-tn nfp offset)) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst swc1 imag-tn nfp (+ offset n-word-bytes)))))))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst swc1 real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst swc1 imag-tn nfp (+ offset n-word-bytes)))))))) (define-move-vop move-complex-single-float-arg :move-arg (complex-single-reg descriptor-reg) (complex-single-reg)) (define-vop (move-complex-double-float-arg) (:args (x :scs (complex-double-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) (:results (y)) (:note "complex double-float argument move") (:generator 2 (sc-case y (complex-double-reg (unless (location= x y) - (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst fmove :double y-real x-real)) - (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fmove :double y-imag x-imag)))) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst fmove :double y-real x-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmove :double y-imag x-imag)))) (complex-double-stack (let ((offset (* (tn-offset y) n-word-bytes))) - (let ((real-tn (complex-double-reg-real-tn x))) - (str-double real-tn nfp offset)) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (str-double imag-tn nfp (+ offset (* 2 n-word-bytes))))))))) + (let ((real-tn (complex-double-reg-real-tn x))) + (str-double real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (str-double imag-tn nfp (+ offset (* 2 n-word-bytes))))))))) (define-move-vop move-complex-double-float-arg :move-arg (complex-double-reg descriptor-reg) (complex-double-reg)) @@ -451,44 +451,44 @@ (inst float-op operation format r x y))) (macrolet ((frob (name sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:results (r :scs (,sc))) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) + `(define-vop (,name float-op) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:results (r :scs (,sc))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype)))) (frob single-float-op single-reg single-float) (frob double-float-op double-reg double-float)) (macrolet ((frob (op sname scost dname dcost) - `(progn - (define-vop (,sname single-float-op) - (:translate ,op) - (:variant :single ',op) - (:variant-cost ,scost)) - (define-vop (,dname double-float-op) - (:translate ,op) - (:variant :double ',op) - (:variant-cost ,dcost))))) + `(progn + (define-vop (,sname single-float-op) + (:translate ,op) + (:variant :single ',op) + (:variant-cost ,scost)) + (define-vop (,dname double-float-op) + (:translate ,op) + (:variant :double ',op) + (:variant-cost ,dcost))))) (frob + +/single-float 2 +/double-float 2) (frob - -/single-float 2 -/double-float 2) (frob * */single-float 4 */double-float 5) (frob / //single-float 12 //double-float 19)) (macrolet ((frob (name inst translate format sc type) - `(define-vop (,name) - (:args (x :scs (,sc))) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (note-this-location vop :internal-error) - (inst ,inst ,format y x))))) + `(define-vop (,name) + (:args (x :scs (,sc))) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst ,inst ,format y x))))) (frob abs/single-float fabs abs :single single-reg single-float) (frob abs/double-float fabs abs :double double-reg double-float) (frob %negate/single-float fneg %negate :single single-reg single-float) @@ -511,26 +511,26 @@ (inst fcmp operation format x y) (inst nop) (if (if complement (not not-p) not-p) - (inst bc1f target) - (inst bc1t target)) + (inst bc1f target) + (inst bc1t target)) (inst nop))) (macrolet ((frob (name sc ptype) - `(define-vop (,name float-compare) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,ptype ,ptype)))) + `(define-vop (,name float-compare) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,ptype ,ptype)))) (frob single-float-compare single-reg single-float) (frob double-float-compare double-reg double-float)) (macrolet ((frob (translate op complement sname dname) - `(progn - (define-vop (,sname single-float-compare) - (:translate ,translate) - (:variant :single ,op ,complement)) - (define-vop (,dname double-float-compare) - (:translate ,translate) - (:variant :double ,op ,complement))))) + `(progn + (define-vop (,sname single-float-compare) + (:translate ,translate) + (:variant :single ,op ,complement)) + (define-vop (,dname double-float-compare) + (:translate ,translate) + (:variant :double ,op ,complement))))) (frob < :lt nil :ngt t >/single-float >/double-float) (frob = :seq nil =/single-float =/double-float)) @@ -539,27 +539,27 @@ ;;;; Conversion: (macrolet ((frob (name translate - from-sc from-type from-format - to-sc to-type to-format) - (let ((word-p (eq from-format :word))) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (,to-sc))) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator ,(if word-p 3 2) - ,@(if word-p - `((inst mtc1 y x) - (inst nop) - (note-this-location vop :internal-error) - (inst fcvt ,to-format :word y y)) - `((note-this-location vop :internal-error) - (inst fcvt ,to-format ,from-format y x)))))))) + from-sc from-type from-format + to-sc to-type to-format) + (let ((word-p (eq from-format :word))) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator ,(if word-p 3 2) + ,@(if word-p + `((inst mtc1 y x) + (inst nop) + (note-this-location vop :internal-error) + (inst fcvt ,to-format :word y y)) + `((note-this-location vop :internal-error) + (inst fcvt ,to-format ,from-format y x)))))))) (frob %single-float/signed %single-float signed-reg signed-num :word single-reg single-float :single) @@ -575,22 +575,22 @@ (macrolet ((frob (name from-sc from-type from-format) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (signed-reg))) - (:temporary (:from (:argument 0) :sc ,from-sc) temp) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate %unary-round) - (:policy :fast-safe) - (:note "inline float round") - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (note-this-location vop :internal-error) - (inst fcvt :word ,from-format temp x) - (inst mfc1 y temp) - (inst nop))))) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (signed-reg))) + (:temporary (:from (:argument 0) :sc ,from-sc) temp) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate %unary-round) + (:policy :fast-safe) + (:note "inline float round") + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (note-this-location vop :internal-error) + (inst fcvt :word ,from-format temp x) + (inst mfc1 y temp) + (inst nop))))) (frob %unary-round/single-float single-reg single-float :single) (frob %unary-round/double-float double-reg double-float :double)) @@ -599,38 +599,38 @@ ;;; the desired round-to-zero behavior. ;;; (macrolet ((frob (name from-sc from-type from-format) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (signed-reg))) - (:temporary (:from (:argument 0) :sc ,from-sc) temp) - (:temporary (:sc non-descriptor-reg) status-save new-status) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) - pa-flag) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate %unary-truncate) - (:policy :fast-safe) - (:note "inline float truncate") - (:vop-var vop) - (:save-p :compute-only) - (:generator 16 - (pseudo-atomic (pa-flag) - (inst cfc1 status-save 31) - (inst li new-status (lognot 3)) - (inst and new-status status-save) - (inst or new-status float-round-to-zero) - (inst ctc1 new-status 31) - - ;; These instructions seem to be necessary to ensure that - ;; the new modes affect the fcvt instruction. - (inst nop) - (inst cfc1 new-status 31) - - (note-this-location vop :internal-error) - (inst fcvt :word ,from-format temp x) - (inst mfc1 y temp) - (inst nop) - (inst ctc1 status-save 31)))))) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (signed-reg))) + (:temporary (:from (:argument 0) :sc ,from-sc) temp) + (:temporary (:sc non-descriptor-reg) status-save new-status) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) + pa-flag) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,name) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 16 + (pseudo-atomic (pa-flag) + (inst cfc1 status-save 31) + (inst li new-status (lognot 3)) + (inst and new-status status-save) + (inst or new-status float-round-to-zero) + (inst ctc1 new-status 31) + + ;; These instructions seem to be necessary to ensure that + ;; the new modes affect the fcvt instruction. + (inst nop) + (inst cfc1 new-status 31) + + (note-this-location vop :internal-error) + (inst fcvt :word ,from-format temp x) + (inst mfc1 y temp) + (inst nop) + (inst ctc1 status-save 31)))))) (frob %unary-truncate/single-float single-reg single-float :single) (frob %unary-truncate/double-float double-reg double-float :double)) @@ -648,7 +648,7 @@ (define-vop (make-double-float) (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) + (lo-bits :scs (unsigned-reg))) (:results (res :scs (double-reg))) (:arg-types signed-num unsigned-num) (:result-types double-float) @@ -693,43 +693,15 @@ (inst nop))) -;;;; Float mode hackery: - -(sb!xc:deftype float-modes () '(unsigned-byte 24)) -(defknown floating-point-modes () float-modes (flushable)) -(defknown ((setf floating-point-modes)) (float-modes) - float-modes) - -(define-vop (floating-point-modes) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate floating-point-modes) - (:policy :fast-safe) - (:generator 3 - (inst cfc1 res 31) - (inst nop))) - -(define-vop (set-floating-point-modes) - (:args (new :scs (unsigned-reg) :target res)) - (:results (res :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:result-types unsigned-num) - (:translate (setf floating-point-modes)) - (:policy :fast-safe) - (:generator 3 - (inst ctc1 res 31) - (move res new))) - - ;;;; Complex float VOPs (define-vop (make-complex-single-float) (:translate complex) (:args (real :scs (single-reg) :target r) - (imag :scs (single-reg) :to :save)) + (imag :scs (single-reg) :to :save)) (:arg-types single-float single-float) (:results (r :scs (complex-single-reg) :from (:argument 0) - :load-if (not (sc-is r complex-single-stack)))) + :load-if (not (sc-is r complex-single-stack)))) (:result-types complex-single-float) (:note "inline complex single-float creation") (:policy :fast-safe) @@ -738,24 +710,24 @@ (sc-case r (complex-single-reg (let ((r-real (complex-single-reg-real-tn r))) - (unless (location= real r-real) - (inst fmove :single r-real real))) + (unless (location= real r-real) + (inst fmove :single r-real real))) (let ((r-imag (complex-single-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst fmove :single r-imag imag)))) + (unless (location= imag r-imag) + (inst fmove :single r-imag imag)))) (complex-single-stack (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset r) n-word-bytes))) - (inst swc1 real nfp offset) - (inst swc1 imag nfp (+ offset n-word-bytes))))))) + (offset (* (tn-offset r) n-word-bytes))) + (inst swc1 real nfp offset) + (inst swc1 imag nfp (+ offset n-word-bytes))))))) (define-vop (make-complex-double-float) (:translate complex) (:args (real :scs (double-reg) :target r) - (imag :scs (double-reg) :to :save)) + (imag :scs (double-reg) :to :save)) (:arg-types double-float double-float) (:results (r :scs (complex-double-reg) :from (:argument 0) - :load-if (not (sc-is r complex-double-stack)))) + :load-if (not (sc-is r complex-double-stack)))) (:result-types complex-double-float) (:note "inline complex double-float creation") (:policy :fast-safe) @@ -764,21 +736,21 @@ (sc-case r (complex-double-reg (let ((r-real (complex-double-reg-real-tn r))) - (unless (location= real r-real) - (inst fmove :double r-real real))) + (unless (location= real r-real) + (inst fmove :double r-real real))) (let ((r-imag (complex-double-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst fmove :double r-imag imag)))) + (unless (location= imag r-imag) + (inst fmove :double r-imag imag)))) (complex-double-stack (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset r) n-word-bytes))) - (str-double real nfp offset) - (str-double imag nfp (+ offset (* 2 n-word-bytes)))))))) + (offset (* (tn-offset r) n-word-bytes))) + (str-double real nfp offset) + (str-double imag nfp (+ offset (* 2 n-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)))) + :load-if (not (sc-is x complex-single-stack)))) (:arg-types complex-single-float) (:results (r :scs (single-reg))) (:result-types single-float) @@ -789,14 +761,14 @@ (sc-case x (complex-single-reg (let ((value-tn (ecase slot - (:real (complex-single-reg-real-tn x)) - (:imag (complex-single-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst fmove :single r value-tn)))) + (:real (complex-single-reg-real-tn x)) + (:imag (complex-single-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmove :single r value-tn)))) (complex-single-stack (inst lwc1 r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1)) - (tn-offset x)) - n-word-bytes)) + (tn-offset x)) + n-word-bytes)) (inst nop))))) (define-vop (realpart/complex-single-float complex-single-float-value) @@ -811,7 +783,7 @@ (define-vop (complex-double-float-value) (:args (x :scs (complex-double-reg) :target r - :load-if (not (sc-is x complex-double-stack)))) + :load-if (not (sc-is x complex-double-stack)))) (:arg-types complex-double-float) (:results (r :scs (double-reg))) (:result-types double-float) @@ -822,14 +794,14 @@ (sc-case x (complex-double-reg (let ((value-tn (ecase slot - (:real (complex-double-reg-real-tn x)) - (:imag (complex-double-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst fmove :double r value-tn)))) + (:real (complex-double-reg-real-tn x)) + (:imag (complex-double-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmove :double r value-tn)))) (complex-double-stack (ld-double r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2)) - (tn-offset x)) - n-word-bytes)) + (tn-offset x)) + n-word-bytes)) (inst nop))))) (define-vop (realpart/complex-double-float complex-double-float-value)