(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)))
(inst lddf y nfp offset)))
(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)))
(inst stdf x nfp offset)))
;;; The offset may be an integer or a TN in which case it will be
(inst ldqf reg base offset))
(t
(let ((reg0 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset reg)))
- (reg2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset reg)))))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset reg)))
+ (reg2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset reg)))))
(cond ((integerp offset)
- (inst lddf reg0 base offset)
- (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
- (t
- (inst lddf reg0 base offset)
- (inst add offset (* 2 n-word-bytes))
- (inst lddf reg2 base offset)
- (when restore-offset
- (inst sub offset (* 2 n-word-bytes)))))))))
+ (inst lddf reg0 base offset)
+ (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
+ (t
+ (inst lddf reg0 base offset)
+ (inst add offset (* 2 n-word-bytes))
+ (inst lddf reg2 base offset)
+ (when restore-offset
+ (inst sub offset (* 2 n-word-bytes)))))))))
#!+long-float
(define-move-fun (load-long 2) (vop x y)
((long-stack) (long-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(load-long-reg y nfp offset)))
;;; The offset may be an integer or a TN in which case it will be
(cond
((member :sparc-v9 *backend-subfeatures*)
(inst stqf reg base offset))
- (t
+ (t
(let ((reg0 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset reg)))
- (reg2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset reg)))))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset reg)))
+ (reg2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset reg)))))
(cond ((integerp offset)
- (inst stdf reg0 base offset)
- (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
- (t
- (inst stdf reg0 base offset)
- (inst add offset (* 2 n-word-bytes))
- (inst stdf reg2 base offset)
- (when restore-offset
- (inst sub offset (* 2 n-word-bytes)))))))))
+ (inst stdf reg0 base offset)
+ (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
+ (t
+ (inst stdf reg0 base offset)
+ (inst add offset (* 2 n-word-bytes))
+ (inst stdf reg2 base offset)
+ (when restore-offset
+ (inst sub offset (* 2 n-word-bytes)))))))))
#!+long-float
(define-move-fun (store-long 2) (vop x y)
((long-reg) (long-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(store-long-reg x nfp offset)))
\f
(t
(dotimes (i 2)
(let ((dst (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset dst))))
- (src (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset src)))))
- (inst fmovs dst src))))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset dst))))
+ (src (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset src)))))
+ (inst fmovs dst src))))))
;;; Exploit the V9 long-float move instruction. This is conditional
;;; on the :sparc-v9 feature.
(t
(dotimes (i 4)
(let ((dst (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset dst))))
- (src (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset src)))))
- (inst fmovs dst src))))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset dst))))
+ (src (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset src)))))
+ (inst fmovs dst src))))))
(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)
- ,@(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)))))
+ `(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)
+ ,@(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 :single)
(frob double-move double-reg :double)
#!+long-float
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:variant-vars format size type data)
(:generator 13
- (with-fixed-allocation (y ndescr type size))
- (ecase format
- (:single
- (inst stf x y (- (* data n-word-bytes) other-pointer-lowtag)))
- (:double
- (inst stdf x y (- (* data n-word-bytes) other-pointer-lowtag)))
- (:long
- (store-long-reg x y (- (* data n-word-bytes)
- other-pointer-lowtag))))))
+ (with-fixed-allocation (y ndescr type size)
+ (ecase format
+ (:single
+ (inst stf x y (- (* data n-word-bytes) other-pointer-lowtag)))
+ (:double
+ (inst stdf x y (- (* data n-word-bytes) other-pointer-lowtag)))
+ (:long
+ (store-long-reg 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 :single
single-float-size single-float-widetag single-float-value-slot)
(frob move-from-double double-reg :double
double-float-size double-float-widetag double-float-value-slot)
#!+long-float
- (frob move-from-long long-reg :long
+ (frob move-from-long long-reg :long
long-float-size long-float-widetag 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 ,(ecase format
- (:single 'ldf)
- (:double 'lddf))
- y x
- (- (* ,value n-word-bytes) other-pointer-lowtag))))
- (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
+ (inst ,(ecase format
+ (:single 'ldf)
+ (:double 'lddf))
+ y x
+ (- (* ,value n-word-bytes) other-pointer-lowtag))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg :single single-float-value-slot)
(frob move-to-double double-reg :double double-float-value-slot))
(:note "pointer to float coercion")
(:generator 2
(load-long-reg y x (- (* long-float-value-slot n-word-bytes)
- other-pointer-lowtag))))
+ other-pointer-lowtag))))
#!+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
(macrolet ((frob (name sc stack-sc format)
- `(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 ,(ecase format (:single 1) (:double 2))
- (sc-case y
- (,sc
- (unless (location= x y)
- ,@(ecase format
- (:single '((inst fmovs y x)))
- (:double '((move-double-reg y x))))))
- (,stack-sc
- (let ((offset (* (tn-offset y) n-word-bytes)))
- (inst ,(ecase format
- (:single 'stf)
- (:double 'stdf))
- x nfp offset))))))
- (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 ,(ecase format (:single 1) (:double 2))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ ,@(ecase format
+ (:single '((inst fmovs y x)))
+ (:double '((move-double-reg y x))))))
+ (,stack-sc
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (inst ,(ecase format
+ (:single 'stf)
+ (:double 'stdf))
+ x nfp offset))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack :single)
(frob move-double-float-arg double-reg double-stack :double))
#!+long-float
(define-vop (move-long-float-arg)
(:args (x :scs (long-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
+ (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)))
+ (move-long-reg y x)))
(long-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (store-long-reg x nfp offset))))))
+ (store-long-reg x nfp offset))))))
;;;
#!+long-float
(define-move-vop move-long-float-arg :move-arg
(defun complex-single-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
(defun complex-single-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
- :offset (1+ (tn-offset x))))
+ :offset (1+ (tn-offset x))))
(defun complex-double-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
(defun complex-double-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
- :offset (+ (tn-offset x) 2)))
+ :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)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
#!+long-float
(defun complex-long-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
- :offset (+ (tn-offset x) 4)))
+ :offset (+ (tn-offset x) 4)))
(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 ldf real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(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 stf real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(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)))
(inst lddf real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(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)))
(inst stdf real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn x)))
(define-move-fun (load-complex-long 5) (vop x y)
((complex-long-stack) (complex-long-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-long-reg-real-tn y)))
(load-long-reg real-tn nfp offset))
(let ((imag-tn (complex-long-reg-imag-tn y)))
(define-move-fun (store-complex-long 5) (vop x y)
((complex-long-reg) (complex-long-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-long-reg-real-tn x)))
(store-long-reg real-tn nfp offset))
(let ((imag-tn (complex-long-reg-imag-tn x)))
;;;
(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
;; 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 fmovs y-real x-real))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmovs y-real x-real))
(let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmovs y-imag x-imag)))))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmovs 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
;; 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)))
- (move-double-reg y-real x-real))
+ (y-real (complex-double-reg-real-tn y)))
+ (move-double-reg y-real x-real))
(let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (move-double-reg y-imag x-imag)))))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (move-double-reg y-imag x-imag)))))
;;;
(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))))
+ :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
;; 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))
+ (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)))))
+ (y-imag (complex-long-reg-imag-tn y)))
+ (move-long-reg y-imag x-imag)))))
;;;
#!+long-float
(define-move-vop complex-long-move :move
(:note "complex single float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-single-float-widetag
- complex-single-float-size))
- (let ((real-tn (complex-single-reg-real-tn x)))
- (inst stf real-tn y (- (* complex-single-float-real-slot
- n-word-bytes)
- other-pointer-lowtag)))
- (let ((imag-tn (complex-single-reg-imag-tn x)))
- (inst stf imag-tn y (- (* complex-single-float-imag-slot
- n-word-bytes)
- other-pointer-lowtag)))))
+ complex-single-float-size)
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst stf real-tn y (- (* complex-single-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst stf 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))
(:note "complex double float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-double-float-widetag
- complex-double-float-size))
- (let ((real-tn (complex-double-reg-real-tn x)))
- (inst stdf real-tn y (- (* complex-double-float-real-slot
- n-word-bytes)
- other-pointer-lowtag)))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- (inst stdf imag-tn y (- (* complex-double-float-imag-slot
- n-word-bytes)
- other-pointer-lowtag)))))
+ complex-double-float-size)
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stdf real-tn y (- (* complex-double-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stdf 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))
(:note "complex long float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-long-float-widetag
- complex-long-float-size))
- (let ((real-tn (complex-long-reg-real-tn x)))
- (store-long-reg real-tn y (- (* complex-long-float-real-slot
- n-word-bytes)
- other-pointer-lowtag)))
- (let ((imag-tn (complex-long-reg-imag-tn x)))
- (store-long-reg imag-tn y (- (* complex-long-float-imag-slot
- n-word-bytes)
- other-pointer-lowtag)))))
+ complex-long-float-size)
+ (let ((real-tn (complex-long-reg-real-tn x)))
+ (store-long-reg real-tn y (- (* complex-long-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-long-reg-imag-tn x)))
+ (store-long-reg imag-tn y (- (* complex-long-float-imag-slot
+ n-word-bytes)
+ other-pointer-lowtag))))))
;;;
#!+long-float
(define-move-vop move-from-complex-long :move
(:generator 2
(let ((real-tn (complex-single-reg-real-tn y)))
(inst ldf 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 ldf imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(:generator 2
(let ((real-tn (complex-double-reg-real-tn y)))
(inst lddf 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)))
(inst lddf imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
(:generator 2
(let ((real-tn (complex-long-reg-real-tn y)))
(load-long-reg real-tn x (- (* complex-long-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-long-reg-imag-tn y)))
(load-long-reg imag-tn x (- (* complex-long-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
#!+long-float
(define-move-vop move-to-complex-long :move
(descriptor-reg) (complex-long-reg))
;;;
(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 fmovs y-real x-real))
- (let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmovs y-imag x-imag))))
+ (let ((x-real (complex-single-reg-real-tn x))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmovs y-real x-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmovs 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 stf real-tn nfp offset))
- (let ((imag-tn (complex-single-reg-imag-tn x)))
- (inst stf imag-tn nfp (+ offset n-word-bytes))))))))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst stf real-tn nfp offset))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst stf 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)))
- (move-double-reg y-real x-real))
- (let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (move-double-reg y-imag x-imag))))
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (move-double-reg y-real x-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (move-double-reg y-imag x-imag))))
(complex-double-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-double-reg-real-tn x)))
- (inst stdf real-tn nfp offset))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stdf real-tn nfp offset))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stdf 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))
#!+long-float
(define-vop (move-complex-long-float-arg)
(:args (x :scs (complex-long-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
+ (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))))
+ (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) n-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 n-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 n-word-bytes)))))))))
#!+long-float
(define-move-vop move-complex-long-float-arg :move-arg
(complex-long-reg descriptor-reg) (complex-long-reg))
(:save-p :compute-only))
(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)
#!+long-float
(frob long-float-op long-reg long-float))
(macrolet ((frob (op sinst sname scost dinst dname dcost)
- `(progn
- (define-vop (,sname single-float-op)
- (:translate ,op)
- (:generator ,scost
- (inst ,sinst r x y)))
- (define-vop (,dname double-float-op)
- (:translate ,op)
- (:generator ,dcost
- (inst ,dinst r x y))))))
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:generator ,scost
+ (inst ,sinst r x y)))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:generator ,dcost
+ (inst ,dinst r x y))))))
(frob + fadds +/single-float 2 faddd +/double-float 2)
(frob - fsubs -/single-float 2 fsubd -/double-float 2)
(frob * fmuls */single-float 4 fmuld */double-float 5)
#!+long-float
(macrolet ((frob (op linst lname lcost)
- `(define-vop (,lname long-float-op)
- (:translate ,op)
- (:generator ,lcost
- (inst ,linst r x y)))))
+ `(define-vop (,lname long-float-op)
+ (:translate ,op)
+ (:generator ,lcost
+ (inst ,linst r x y)))))
(frob + faddq +/long-float 2)
(frob - fsubq -/long-float 2)
(frob * fmulq */long-float 6)
\f
(macrolet ((frob (name inst translate 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 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 y x)))))
(frob abs/single-float fabss abs single-reg single-float)
(frob %negate/single-float fnegs %negate single-reg single-float))
;; of the bits.
(inst fnegs dst src)
(let ((dst-odd (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset dst))))
- (src-odd (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset src)))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset dst))))
+ (src-odd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset src)))))
(inst fmovs dst-odd src-odd)))))
(defun abs-double-reg (dst src)
;; of the bits.
(inst fabss dst src)
(let ((dst-2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset dst))))
- (src-2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset src)))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset dst))))
+ (src-2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset src)))))
(inst fmovs dst-2 src-2)))))
(define-vop (abs/double-float)
(t
(inst fabss y x)
(dotimes (i 3)
- (let ((y-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset y))))
- (x-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset x)))))
- (inst fmovs y-odd x-odd)))))))
+ (let ((y-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset y))))
+ (x-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset x)))))
+ (inst fmovs y-odd x-odd)))))))
#!+long-float
(define-vop (%negate/long-float)
(t
(inst fnegs y x)
(dotimes (i 3)
- (let ((y-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset y))))
- (x-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset x)))))
- (inst fmovs y-odd x-odd)))))))
+ (let ((y-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset y))))
+ (x-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset x)))))
+ (inst fmovs y-odd x-odd)))))))
\f
;;;; Comparison:
(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)
#!+long-float
(frob long-float-compare long-reg long-float))
(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))
- #!+long-float
- (define-vop (,lname long-float-compare)
- (:translate ,translate)
- (:variant :long ,yep ,nope)))))
+ `(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))
+ #!+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))))
+ (= (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))))
\f
;;;; Conversion:
(macrolet ((frob (name translate inst to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (signed-reg) :target stack-temp
- :load-if (not (sc-is x signed-stack))))
- (: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)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (let ((stack-tn
- (sc-case x
- (signed-reg
- (inst st x
- (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes))
- stack-temp)
- (signed-stack
- x))))
- (inst ldf temp
- (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
- (note-this-location vop :internal-error)
- (inst ,inst y temp))))))
+ `(define-vop (,name)
+ (:args (x :scs (signed-reg) :target stack-temp
+ :load-if (not (sc-is x signed-stack))))
+ (: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)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (let ((stack-tn
+ (sc-case x
+ (signed-reg
+ (inst st x
+ (current-nfp-tn vop)
+ (* (tn-offset temp) n-word-bytes))
+ stack-temp)
+ (signed-stack
+ x))))
+ (inst ldf temp
+ (current-nfp-tn vop)
+ (* (tn-offset stack-tn) n-word-bytes))
+ (note-this-location vop :internal-error)
+ (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)
#!+long-float
(frob %long-float/signed %long-float fitoq long-reg long-float))
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
- `(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 2
- (note-this-location vop :internal-error)
- (inst ,inst y x)))))
+ `(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 2
+ (note-this-location vop :internal-error)
+ (inst ,inst y x)))))
(frob %single-float/double-float %single-float fdtos
double-reg double-float single-reg single-float)
#!+long-float
double-reg double-float long-reg long-float))
(macrolet ((frob (trans from-sc from-type inst)
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc) :target temp))
- (:temporary (:from (:argument 0) :sc single-reg) temp)
- (:temporary (:scs (signed-stack)) stack-temp)
- (:results (y :scs (signed-reg)
- :load-if (not (sc-is y signed-stack))))
- (:arg-types ,from-type)
- (:result-types signed-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- (inst ,inst temp x)
- (sc-case y
- (signed-stack
- (inst stf temp (current-nfp-tn vop)
- (* (tn-offset y) n-word-bytes)))
- (signed-reg
- (inst stf temp (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst ld y (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))))))))
- (frob %unary-truncate single-reg single-float fstoi)
- (frob %unary-truncate double-reg double-float fdtoi)
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc) :target temp))
+ (:temporary (:from (:argument 0) :sc single-reg) temp)
+ (:temporary (:scs (signed-stack)) stack-temp)
+ (:results (y :scs (signed-reg)
+ :load-if (not (sc-is y signed-stack))))
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (inst ,inst temp x)
+ (sc-case y
+ (signed-stack
+ (inst stf temp (current-nfp-tn vop)
+ (* (tn-offset y) n-word-bytes)))
+ (signed-reg
+ (inst stf temp (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ld y (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))))))))
+ (frob %unary-truncate/single-float single-reg single-float fstoi)
+ (frob %unary-truncate/double-float double-reg double-float fdtoi)
#!+long-float
- (frob %unary-truncate long-reg long-float fqtoi)
+ (frob %unary-truncate/long-float long-reg long-float fqtoi)
;; KLUDGE -- these two forms were protected by #-sun4.
;; (frob %unary-round single-reg single-float fstoir)
;; (frob %unary-round double-reg double-float fdtoir)
(deftransform %unary-round ((x) (float) (signed-byte 32))
'(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
- (extra (- x trunc))
- (absx (abs extra))
- (one-half (float 1/2 x)))
+ (extra (- x trunc))
+ (absx (abs extra))
+ (one-half (float 1/2 x)))
(if (if (oddp trunc)
- (>= absx one-half)
- (> absx one-half))
- (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
- trunc)))
+ (>= absx one-half)
+ (> absx one-half))
+ (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
+ trunc)))
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
- :load-if (not (sc-is bits signed-stack))))
+ :load-if (not (sc-is bits signed-stack))))
(:results (res :scs (single-reg)
- :load-if (not (sc-is res single-stack))))
+ :load-if (not (sc-is res single-stack))))
(:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
(:temporary (:scs (signed-stack)) stack-temp)
(:arg-types signed-num)
(sc-case bits
(signed-reg
(sc-case res
- (single-reg
- (inst st bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst ldf res (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
- (single-stack
- (inst st bits (current-nfp-tn vop)
- (* (tn-offset res) n-word-bytes)))))
+ (single-reg
+ (inst st bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ldf res (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst st bits (current-nfp-tn vop)
+ (* (tn-offset res) n-word-bytes)))))
(signed-stack
(sc-case res
- (single-reg
- (inst ldf res (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes)))
- (single-stack
- (unless (location= bits res)
- (inst ld temp (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes))
- (inst st temp (current-nfp-tn vop)
- (* (tn-offset res) n-word-bytes)))))))))
+ (single-reg
+ (inst ldf res (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes)))
+ (single-stack
+ (unless (location= bits res)
+ (inst ld temp (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes))
+ (inst st temp (current-nfp-tn vop)
+ (* (tn-offset res) n-word-bytes)))))))))
(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)
- :load-if (not (sc-is res double-stack))))
+ :load-if (not (sc-is res double-stack))))
(:temporary (:scs (double-stack)) temp)
(:arg-types signed-num unsigned-num)
(:result-types double-float)
(:vop-var vop)
(:generator 2
(let ((stack-tn (sc-case res
- (double-stack res)
- (double-reg temp))))
+ (double-stack res)
+ (double-reg temp))))
(inst st hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
+ (* (tn-offset stack-tn) n-word-bytes))
(inst st lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-tn)) n-word-bytes)))
+ (* (1+ (tn-offset stack-tn)) n-word-bytes)))
(when (sc-is res double-reg)
(inst lddf res (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes)))))
+ (* (tn-offset temp) n-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)))
+ (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))))
+ :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)
(:vop-var vop)
(:generator 2
(let ((stack-tn (sc-case res
- (long-stack res)
- (long-reg temp))))
+ (long-stack res)
+ (long-reg temp))))
(inst st hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
+ (* (tn-offset stack-tn) n-word-bytes))
(inst st lo1-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-tn)) n-word-bytes))
+ (* (1+ (tn-offset stack-tn)) n-word-bytes))
(inst st lo2-bits (current-nfp-tn vop)
- (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
+ (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
(inst st lo3-bits (current-nfp-tn vop)
- (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
+ (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
(when (sc-is res long-reg)
(load-long-reg res (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes)))))
+ (* (tn-offset temp) n-word-bytes)))))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
- :load-if (not (sc-is float single-stack))))
+ :load-if (not (sc-is float single-stack))))
(:results (bits :scs (signed-reg)
- :load-if (or (sc-is float descriptor-reg single-stack)
- (not (sc-is bits signed-stack)))))
+ :load-if (or (sc-is float descriptor-reg single-stack)
+ (not (sc-is bits signed-stack)))))
(:temporary (:scs (signed-stack)) stack-temp)
(:arg-types single-float)
(:result-types signed-num)
(sc-case bits
(signed-reg
(sc-case float
- (single-reg
- (inst stf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst ld bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
- (single-stack
- (inst ld bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
- (descriptor-reg
- (loadw bits float single-float-value-slot
- other-pointer-lowtag))))
+ (single-reg
+ (inst stf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ld bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst ld bits (current-nfp-tn vop)
+ (* (tn-offset float) n-word-bytes)))
+ (descriptor-reg
+ (loadw bits float single-float-value-slot
+ other-pointer-lowtag))))
(signed-stack
(sc-case float
- (single-reg
- (inst stf float (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes))))))))
+ (single-reg
+ (inst stf float (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes))))))))
(define-vop (double-float-high-bits)
(:args (float :scs (double-reg descriptor-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (hi-bits :scs (signed-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types double-float)
(sc-case float
(double-reg
(inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
+ (* (tn-offset stack-temp) n-word-bytes))
(inst ld hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ (* (tn-offset stack-temp) n-word-bytes)))
(double-stack
(inst ld hi-bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
+ (* (tn-offset float) n-word-bytes)))
(descriptor-reg
(loadw hi-bits float double-float-value-slot
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (lo-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types double-float)
(sc-case float
(double-reg
(inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
+ (* (tn-offset stack-temp) n-word-bytes))
(inst ld lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
(double-stack
(inst ld lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset float)) n-word-bytes)))
+ (* (1+ (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw lo-bits float (1+ double-float-value-slot)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-exp-bits)
(:args (float :scs (long-reg descriptor-reg)
- :load-if (not (sc-is float long-stack))))
+ :load-if (not (sc-is float long-stack))))
(:results (exp-bits :scs (signed-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset float))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset float))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld exp-bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ (* (tn-offset stack-temp) n-word-bytes)))
(long-stack
(inst ld exp-bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
+ (* (tn-offset float) n-word-bytes)))
(descriptor-reg
(loadw exp-bits float long-float-value-slot
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-high-bits)
(:args (float :scs (long-reg descriptor-reg)
- :load-if (not (sc-is float long-stack))))
+ :load-if (not (sc-is float long-stack))))
(:results (high-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset float))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset float))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld high-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
(long-stack
(inst ld high-bits (current-nfp-tn vop)
- (* (1+ (tn-offset float)) n-word-bytes)))
+ (* (1+ (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw high-bits float (1+ long-float-value-slot)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-mid-bits)
(:args (float :scs (long-reg descriptor-reg)
- :load-if (not (sc-is float long-stack))))
+ :load-if (not (sc-is float long-stack))))
(:results (mid-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset float)))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset float)))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld mid-bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ (* (tn-offset stack-temp) n-word-bytes)))
(long-stack
(inst ld mid-bits (current-nfp-tn vop)
- (* (+ 2 (tn-offset float)) n-word-bytes)))
+ (* (+ 2 (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw mid-bits float (+ 2 long-float-value-slot)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-low-bits)
(:args (float :scs (long-reg descriptor-reg)
- :load-if (not (sc-is float long-stack))))
+ :load-if (not (sc-is float long-stack))))
(:results (lo-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset float)))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset float)))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
(long-stack
(inst ld lo-bits (current-nfp-tn vop)
- (* (+ 3 (tn-offset float)) n-word-bytes)))
+ (* (+ 3 (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw lo-bits float (+ 3 long-float-value-slot)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
\f
;;;; Float mode hackery:
(:temporary (:sc double-stack) temp)
(:generator 3
(let* ((nfp (current-nfp-tn vop))
- (offset (* 4 (tn-offset temp))))
+ (offset (* 4 (tn-offset temp))))
(inst stxfsr nfp offset)
;; The desired FP mode data is in the least significant 32
;; bits, which is stored at the next higher word in memory.
(:vop-var vop)
(:generator 3
(let ((nfp (current-nfp-tn vop))
- (offset (* n-word-bytes (tn-offset temp))))
+ (offset (* n-word-bytes (tn-offset temp))))
(pseudo-atomic ()
;; Get the current FSR, so we can get the new %fcc's
(inst stxfsr nfp offset)
- (inst ldx my-fsr nfp offset)
- ;; Carefully merge in the new mode bits with the rest of the
- ;; FSR. This is only needed if we care about preserving the
- ;; high 32 bits of the FSR, which contain the additional
- ;; %fcc's on the sparc V9. If not, we don't need this, but we
- ;; do need to make sure that the unused bits are written as
- ;; zeroes, according the the V9 architecture manual.
- (inst sra new 0)
- (inst srlx my-fsr 32)
- (inst sllx my-fsr 32)
- (inst or my-fsr new)
- ;; Save it back and load it into the fsr register
- (inst stx my-fsr nfp offset)
- (inst ldxfsr nfp offset)
- (move res new)))))
+ (inst ldx my-fsr nfp offset)
+ ;; Carefully merge in the new mode bits with the rest of the
+ ;; FSR. This is only needed if we care about preserving the
+ ;; high 32 bits of the FSR, which contain the additional
+ ;; %fcc's on the sparc V9. If not, we don't need this, but we
+ ;; do need to make sure that the unused bits are written as
+ ;; zeroes, according the V9 architecture manual.
+ (inst sra new 0)
+ (inst srlx my-fsr 32)
+ (inst sllx my-fsr 32)
+ (inst or my-fsr new)
+ ;; Save it back and load it into the fsr register
+ (inst stx my-fsr nfp offset)
+ (inst ldxfsr nfp offset)
+ (move res new)))))
#+nil
(define-vop (set-floating-point-modes)
(:vop-var vop)
(:generator 3
(let ((nfp (current-nfp-tn vop))
- (offset (* n-word-bytes (tn-offset temp))))
+ (offset (* n-word-bytes (tn-offset temp))))
(inst stx new nfp offset)
(inst ldxfsr nfp offset)
(move res new))))
(:translate %sqrt)
(:policy :fast-safe)
(:guard (or (member :sparc-v7 *backend-subfeatures*)
- (member :sparc-v8 *backend-subfeatures*)
- (member :sparc-v9 *backend-subfeatures*)))
+ (member :sparc-v8 *backend-subfeatures*)
+ (member :sparc-v9 *backend-subfeatures*)))
(:arg-types double-float)
(:result-types double-float)
(:note "inline float arithmetic")
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :target r
- :load-if (not (location= real r)))
- (imag :scs (single-reg) :to :save))
+ :load-if (not (location= real r)))
+ (imag :scs (single-reg) :to :save))
(:arg-types single-float single-float)
(:results (r :scs (complex-single-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-single-stack))))
+ :load-if (not (sc-is r complex-single-stack))))
(:result-types complex-single-float)
(:note "inline complex single-float creation")
(:policy :fast-safe)
(sc-case r
(complex-single-reg
(let ((r-real (complex-single-reg-real-tn r)))
- (unless (location= real r-real)
- (inst fmovs r-real real)))
+ (unless (location= real r-real)
+ (inst fmovs r-real real)))
(let ((r-imag (complex-single-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst fmovs r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst fmovs r-imag imag))))
(complex-single-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (inst stf real nfp offset))
- (inst stf imag nfp (+ offset n-word-bytes)))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (inst stf real nfp offset))
+ (inst stf imag nfp (+ offset n-word-bytes)))))))
(define-vop (make-complex-double-float)
(:translate complex)
(:args (real :scs (double-reg) :target r
- :load-if (not (location= real r)))
- (imag :scs (double-reg) :to :save))
+ :load-if (not (location= real r)))
+ (imag :scs (double-reg) :to :save))
(:arg-types double-float double-float)
(:results (r :scs (complex-double-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-double-stack))))
+ :load-if (not (sc-is r complex-double-stack))))
(:result-types complex-double-float)
(:note "inline complex double-float creation")
(:policy :fast-safe)
(sc-case r
(complex-double-reg
(let ((r-real (complex-double-reg-real-tn r)))
- (unless (location= real r-real)
- (move-double-reg r-real real)))
+ (unless (location= real r-real)
+ (move-double-reg r-real real)))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (move-double-reg r-imag imag))))
+ (unless (location= imag r-imag)
+ (move-double-reg r-imag imag))))
(complex-double-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (inst stdf real nfp offset))
- (inst stdf imag nfp (+ offset (* 2 n-word-bytes))))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (inst stdf real nfp offset))
+ (inst stdf imag nfp (+ offset (* 2 n-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))
+ :load-if (not (location= real r)))
+ (imag :scs (long-reg) :to :save))
(:arg-types long-float long-float)
(:results (r :scs (complex-long-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-long-stack))))
+ :load-if (not (sc-is r complex-long-stack))))
(:result-types complex-long-float)
(:note "inline complex long-float creation")
(:policy :fast-safe)
(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)))
+ (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))))
+ (unless (location= imag r-imag)
+ (move-long-reg r-imag imag))))
(complex-long-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (store-long-reg real nfp offset))
- (store-long-reg imag nfp (+ offset (* 4 n-word-bytes))))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (store-long-reg real nfp offset))
+ (store-long-reg imag nfp (+ offset (* 4 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)
(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 fmovs r value-tn))))
+ (:real (complex-single-reg-real-tn x))
+ (:imag (complex-single-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmovs r value-tn))))
(complex-single-stack
(inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
- (tn-offset x))
- n-word-bytes))))))
+ (tn-offset x))
+ n-word-bytes))))))
(define-vop (realpart/complex-single-float complex-single-float-value)
(:translate realpart)
(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)
(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)
- (move-double-reg r value-tn))))
+ (:real (complex-double-reg-real-tn x))
+ (:imag (complex-double-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (move-double-reg r value-tn))))
(complex-double-stack
(inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
- (tn-offset x))
- n-word-bytes))))))
+ (tn-offset x))
+ n-word-bytes))))))
(define-vop (realpart/complex-double-float complex-double-float-value)
(:translate realpart)
#!+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))))
+ :load-if (not (sc-is x complex-long-stack))))
(:arg-types complex-long-float)
(:results (r :scs (long-reg)))
(:result-types long-float)
(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))))
+ (: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))
- n-word-bytes))))))
+ (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
+ n-word-bytes))))))
#!+long-float
(define-vop (realpart/complex-long-float complex-long-float-value)
(macrolet
((frob (float-type fneg cost)
(let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg)))
- (:arg-types ,c-type)
- (:results (r :scs (,complex-reg)))
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate %negate)
- (:generator ,cost
- (let ((xr (,real-tn x))
- (xi (,imag-tn x))
- (rr (,real-tn r))
- (ri (,imag-tn r)))
- (,@fneg rr xr)
- (,@fneg ri xi)))))))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg)))
+ (:arg-types ,c-type)
+ (:results (r :scs (,complex-reg)))
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate %negate)
+ (:generator ,cost
+ (let ((xr (,real-tn x))
+ (xi (,imag-tn x))
+ (rr (,real-tn r))
+ (ri (,imag-tn r)))
+ (,@fneg rr xr)
+ (,@fneg ri xi)))))))
(frob single (inst fnegs) 4)
(frob double (negate-double-reg) 4))
(macrolet
((frob (op inst float-type cost)
(let* ((vop-name (symbolicate (symbol-name op) "/COMPLEX-" float-type "-FLOAT"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate ,op)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,inst rr xr yr)
- (inst ,inst ri xi yi)))))))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate ,op)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,inst rr xr yr)
+ (inst ,inst ri xi yi)))))))
(frob + fadds single 4)
(frob + faddd double 4)
(frob - fsubs single 4)
(macrolet
((frob (size op fop fmov cost)
(let ((vop-name (symbolicate "COMPLEX-" size "-FLOAT-"
- op
- "-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (r-type (symbolicate size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,real-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float/float arithmetic")
- (:translate ,op)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fop rr xr y)
- (unless (location= ri xi)
- (,@fmov ri xi))))))))
-
+ op
+ "-" size "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (r-type (symbolicate size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,real-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float/float arithmetic")
+ (:translate ,op)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fop rr xr y)
+ (unless (location= ri xi)
+ (,@fmov ri xi))))))))
+
(frob single + fadds (inst fmovs) 2)
(frob single - fsubs (inst fmovs) 2)
(frob double + faddd (move-double-reg) 4)
(macrolet
((frob (size fop fmov cost)
(let ((vop-name
- (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (r-type (symbolicate size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (y :scs (,real-reg))
- (x :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float/float arithmetic")
- (:translate +)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fop rr xr y)
- (unless (location= ri xi)
- (,@fmov ri xi))))))))
+ (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (r-type (symbolicate size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (y :scs (,real-reg))
+ (x :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float/float arithmetic")
+ (:translate +)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fop rr xr y)
+ (unless (location= ri xi)
+ (,@fmov ri xi))))))))
(frob single fadds (inst fmovs) 1)
(frob double faddd (move-double-reg) 2))
(macrolet
((frob (size fop fneg cost)
(let ((vop-name (symbolicate size "-FLOAT---COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (r-type (symbolicate size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (single-float---complex-single-float)
- (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float/float arithmetic")
- (:translate -)
- (:generator ,cost
- (let ((yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fop rr x yr)
- (,@fneg ri yi))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (r-type (symbolicate size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (single-float---complex-single-float)
+ (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float/float arithmetic")
+ (:translate -)
+ (:generator ,cost
+ (let ((yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fop rr x yr)
+ (,@fneg ri yi))))
))
(frob single fsubs (inst fnegs) 2)
(macrolet
((frob (size fmul fadd fsub cost)
(let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float multiplication")
- (:translate *)
- (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- ;; All of the temps are needed in case the result TN happens to
- ;; be the same as one of the arg TN's
- (inst ,fmul prod-1 xr yr)
- (inst ,fmul prod-2 xi yi)
- (inst ,fmul prod-3 xr yi)
- (inst ,fmul prod-4 xi yr)
- (inst ,fsub rr prod-1 prod-2)
- (inst ,fadd ri prod-3 prod-4)))))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float multiplication")
+ (:translate *)
+ (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ ;; All of the temps are needed in case the result TN happens to
+ ;; be the same as one of the arg TN's
+ (inst ,fmul prod-1 xr yr)
+ (inst ,fmul prod-2 xi yi)
+ (inst ,fmul prod-3 xr yi)
+ (inst ,fmul prod-4 xi yr)
+ (inst ,fsub rr prod-1 prod-2)
+ (inst ,fadd ri prod-3 prod-4)))))))
(frob single fmuls fadds fsubs 6)
(frob double fmuld faddd fsubd 6))
(macrolet
((frob (size fmul fadd fsub cost)
(let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float multiplication")
- (:translate *)
- (:temporary (:scs (,real-reg)) p1 p2)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= r x)
- (inst ,fmul p1 xr yr)
- (inst ,fmul p2 xr yi)
- (inst ,fmul rr xi yi)
- (inst ,fsub rr p1 xr)
- (inst ,fmul p1 xi yr)
- (inst ,fadd ri p2 p1))
- ((location= r y)
- (inst ,fmul p1 yr xr)
- (inst ,fmul p2 yr xi)
- (inst ,fmul rr yi xi)
- (inst ,fsub rr p1 rr)
- (inst ,fmul p1 yi xr)
- (inst ,fadd ri p2 p1))
- (t
- (inst ,fmul rr yr xr)
- (inst ,fmul ri xi yi)
- (inst ,fsub rr rr ri)
- (inst ,fmul p1 xr yi)
- (inst ,fmul ri xi yr)
- (inst ,fadd ri ri p1)))))))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float multiplication")
+ (:translate *)
+ (:temporary (:scs (,real-reg)) p1 p2)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= r x)
+ (inst ,fmul p1 xr yr)
+ (inst ,fmul p2 xr yi)
+ (inst ,fmul rr xi yi)
+ (inst ,fsub rr p1 xr)
+ (inst ,fmul p1 xi yr)
+ (inst ,fadd ri p2 p1))
+ ((location= r y)
+ (inst ,fmul p1 yr xr)
+ (inst ,fmul p2 yr xi)
+ (inst ,fmul rr yi xi)
+ (inst ,fsub rr p1 rr)
+ (inst ,fmul p1 yi xr)
+ (inst ,fadd ri p2 p1))
+ (t
+ (inst ,fmul rr yr xr)
+ (inst ,fmul ri xi yi)
+ (inst ,fsub rr rr ri)
+ (inst ,fmul p1 xr yi)
+ (inst ,fmul ri xi yr)
+ (inst ,fadd ri ri p1)))))))))
(frob single fmuls fadds fsubs 6)
(frob double fmuld faddd fsubd 6))
(macrolet
((frob (float-type fmul mov cost)
(let* ((vop-name (symbolicate "COMPLEX-"
- float-type
- "-FLOAT-*-"
- float-type
- "-FLOAT"))
- (vop-name-r (symbolicate float-type
- "-FLOAT-*-COMPLEX-"
- float-type
- "-FLOAT"))
- (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
- (real-sc-type (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(progn
- ;; Complex * float
- (define-vop (,vop-name)
- (:args (x :scs (,complex-sc-type))
- (y :scs (,real-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate *)
- (:temporary (:scs (,real-sc-type)) temp)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= y rr)
- (inst ,fmul temp xr y) ; xr * y
- (inst ,fmul ri xi y) ; xi * yi
- (,@mov rr temp))
- (t
- (inst ,fmul rr xr y)
- (inst ,fmul ri xi y))))))
- ;; Float * complex
- (define-vop (,vop-name-r)
- (:args (y :scs (,real-sc-type))
- (x :scs (,complex-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate *)
- (:temporary (:scs (,real-sc-type)) temp)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= y rr)
- (inst ,fmul temp xr y) ; xr * y
- (inst ,fmul ri xi y) ; xi * yi
- (,@mov rr temp))
- (t
- (inst ,fmul rr xr y)
- (inst ,fmul ri xi y))))))))))
+ float-type
+ "-FLOAT-*-"
+ float-type
+ "-FLOAT"))
+ (vop-name-r (symbolicate float-type
+ "-FLOAT-*-COMPLEX-"
+ float-type
+ "-FLOAT"))
+ (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-sc-type (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(progn
+ ;; Complex * float
+ (define-vop (,vop-name)
+ (:args (x :scs (,complex-sc-type))
+ (y :scs (,real-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate *)
+ (:temporary (:scs (,real-sc-type)) temp)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= y rr)
+ (inst ,fmul temp xr y) ; xr * y
+ (inst ,fmul ri xi y) ; xi * yi
+ (,@mov rr temp))
+ (t
+ (inst ,fmul rr xr y)
+ (inst ,fmul ri xi y))))))
+ ;; Float * complex
+ (define-vop (,vop-name-r)
+ (:args (y :scs (,real-sc-type))
+ (x :scs (,complex-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate *)
+ (:temporary (:scs (,real-sc-type)) temp)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= y rr)
+ (inst ,fmul temp xr y) ; xr * y
+ (inst ,fmul ri xi y) ; xi * yi
+ (,@mov rr temp))
+ (t
+ (inst ,fmul rr xr y)
+ (inst ,fmul ri xi y))))))))))
(frob single fmuls (inst fmovs) 4)
(frob double fmuld (move-double-reg) 4))
;;
;; We do the similar thing when |yi| > |yr|. The result is
;;
-;;
+;;
;; (xr + i*xi) (xr + i*xi)
;; ----------- = -----------------
;; (yr + i*yi) yi*((yr/yi) + i)
(macrolet
((frob (float-type fcmp fadd fsub fmul fdiv fabs fmov cost)
(let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp-r)
- (:temporary (:sc ,real-reg) temp-i)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
-
- (inst ,fmul temp-r ratio xi)
- (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
- (inst ,fdiv temp-r temp-r den)
-
- (inst ,fmul temp-i ratio xr)
- (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
- (inst b done)
- (inst ,fdiv temp-i temp-i den)
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
-
- (inst ,fmul temp-r ratio xr)
- (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
- (inst ,fdiv temp-r temp-r den)
-
- (inst ,fmul temp-i ratio xi)
- (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
- (inst ,fdiv temp-i temp-i den)
-
- (emit-label done)
- (unless (location= temp-r rr)
- (,@fmov rr temp-r))
- (unless (location= temp-i ri)
- (,@fmov ri temp-i))
- ))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp-r)
+ (:temporary (:sc ,real-reg) temp-i)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+
+ (inst ,fmul temp-r ratio xi)
+ (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xr)
+ (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+ (inst b done)
+ (inst ,fdiv temp-i temp-i den)
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+
+ (inst ,fmul temp-r ratio xr)
+ (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xi)
+ (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+ (inst ,fdiv temp-i temp-i den)
+
+ (emit-label done)
+ (unless (location= temp-r rr)
+ (,@fmov rr temp-r))
+ (unless (location= temp-i ri)
+ (,@fmov ri temp-i))
+ ))))))
(frob single fcmps fadds fsubs fmuls fdivs (inst fabss) (inst fmovs) 15)
(frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) (move-double-reg) 15))
(macrolet
((frob (float-type fcmp fadd fsub fmul fdiv fabs cost)
(let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp-r)
- (:temporary (:sc ,real-reg) temp-i)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fmul temp-r ratio xi)
- (inst ,fmul temp-i ratio xr)
-
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
- (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
- (inst b done)
- (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
-
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fmul temp-r ratio xr)
- (inst ,fmul temp-i ratio xi)
-
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
- (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
-
- (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
-
- (emit-label done)
-
- (inst ,fdiv rr temp-r den)
- (inst ,fdiv ri temp-i den)
- ))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp-r)
+ (:temporary (:sc ,real-reg) temp-i)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fmul temp-r ratio xi)
+ (inst ,fmul temp-i ratio xr)
+
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+ (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+ (inst b done)
+ (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fmul temp-r ratio xr)
+ (inst ,fmul temp-i ratio xi)
+
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+ (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+
+ (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+
+ (emit-label done)
+
+ (inst ,fdiv rr temp-r den)
+ (inst ,fdiv ri temp-i den)
+ ))))))
(frob single fcmps fadds fsubs fmuls fdivs (inst fabss) 15)
(frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) 15))
(macrolet
((frob (float-type fdiv cost)
(let* ((vop-name (symbolicate "COMPLEX-" float-type "-FLOAT-/-" float-type "-FLOAT"))
- (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
- (real-sc-type (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate /)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fdiv rr xr y) ; xr * y
- (inst ,fdiv ri xi y) ; xi * yi
- ))))))
+ (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-sc-type (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate /)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fdiv rr xr y) ; xr * y
+ (inst ,fdiv ri xi y) ; xi * yi
+ ))))))
(frob single fdivs 2)
(frob double fdivd 2))
(macrolet
((frob (float-type fcmp fadd fmul fdiv fneg fabs cost)
(let ((vop-name (symbolicate float-type "-FLOAT-/-COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (r-type (symbolicate float-type "-FLOAT"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,real-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp)
- (:generator ,cost
- (let ((yr (,real-tn y))
- (yi (,imag-tn y))
- (rr (,real-tn r))
- (ri (,imag-tn r))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
-
- (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
- (inst ,fdiv rr x den) ; rr = x/den
- (inst b done)
- (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
-
- (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
- (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
- (inst ,fdiv temp x den) ; temp = x/den
- (emit-label done)
-
- (,@fneg ri temp)))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,real-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp)
+ (:generator ,cost
+ (let ((yr (,real-tn y))
+ (yi (,imag-tn y))
+ (rr (,real-tn r))
+ (ri (,imag-tn r))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+
+ (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
+ (inst ,fdiv rr x den) ; rr = x/den
+ (inst b done)
+ (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+
+ (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
+ (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
+ (inst ,fdiv temp x den) ; temp = x/den
+ (emit-label done)
+
+ (,@fneg ri temp)))))))
(frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10)
(frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10))
(macrolet
((frob (float-type fneg fmov cost)
(let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex conjugate")
- (:translate conjugate)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (,@fneg ri xi)
- (unless (location= rr xr)
- (,@fmov rr xr))))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex conjugate")
+ (:translate conjugate)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (,@fneg ri xi)
+ (unless (location= rr xr)
+ (,@fmov rr xr))))))))
(frob single (inst fnegs) (inst fmovs) 4)
(frob double (negate-double-reg) (move-double-reg) 4))
(macrolet
((frob (name name-r f-type c-type)
`(progn
- (defknown ,name (,f-type ,c-type) t)
- (defknown ,name-r (,c-type ,f-type) t)
- (defun ,name (x y)
- (declare (type ,f-type x)
- (type ,c-type y))
- (,name x y))
- (defun ,name-r (x y)
- (declare (type ,c-type x)
- (type ,f-type y))
- (,name-r x y))
- )))
+ (defknown ,name (,f-type ,c-type) t)
+ (defknown ,name-r (,c-type ,f-type) t)
+ (defun ,name (x y)
+ (declare (type ,f-type x)
+ (type ,c-type y))
+ (,name x y))
+ (defun ,name-r (x y)
+ (declare (type ,c-type x)
+ (type ,f-type y))
+ (,name-r x y))
+ )))
(frob %compare-complex-single-single %compare-single-complex-single
- single-float (complex single-float))
+ single-float (complex single-float))
(frob %compare-complex-double-double %compare-double-complex-double
- double-float (complex double-float)))
-
+ double-float (complex double-float)))
+
#+nil
(macrolet
((frob (trans-1 trans-2 float-type fcmp fsub)
(let ((vop-name
- (symbolicate "COMPLEX-" float-type "-FLOAT-"
- float-type "-FLOAT-COMPARE"))
- (vop-name-r
- (symbolicate float-type "-FLOAT-COMPLEX-"
- float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(progn
- ;; (= float complex)
- (define-vop (,vop-name)
- (:args (x :scs (,real-reg))
- (y :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:translate ,trans-1)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float/float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc ,real-reg) fp-zero)
- (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((yr (,real-part y))
- (yi (,imag-part y)))
- ;; Set fp-zero to zero
- (inst ,fsub fp-zero fp-zero fp-zero)
- (inst ,fcmp x yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp yi fp-zero)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop))))
- ;; (= complex float)
- (define-vop (,vop-name-r)
- (:args (y :scs (,complex-reg))
- (x :scs (,real-reg)))
- (:arg-types ,c-type ,r-type)
- (:translate ,trans-2)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float/float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc ,real-reg) fp-zero)
- (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((yr (,real-part y))
- (yi (,imag-part y)))
- ;; Set fp-zero to zero
- (inst ,fsub fp-zero fp-zero fp-zero)
- (inst ,fcmp x yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp yi fp-zero)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop))))))))
+ (symbolicate "COMPLEX-" float-type "-FLOAT-"
+ float-type "-FLOAT-COMPARE"))
+ (vop-name-r
+ (symbolicate float-type "-FLOAT-COMPLEX-"
+ float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(progn
+ ;; (= float complex)
+ (define-vop (,vop-name)
+ (:args (x :scs (,real-reg))
+ (y :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:translate ,trans-1)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Set fp-zero to zero
+ (inst ,fsub fp-zero fp-zero fp-zero)
+ (inst ,fcmp x yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp yi fp-zero)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop))))
+ ;; (= complex float)
+ (define-vop (,vop-name-r)
+ (:args (y :scs (,complex-reg))
+ (x :scs (,real-reg)))
+ (:arg-types ,c-type ,r-type)
+ (:translate ,trans-2)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Set fp-zero to zero
+ (inst ,fsub fp-zero fp-zero fp-zero)
+ (inst ,fcmp x yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp yi fp-zero)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop))))))))
(frob %compare-complex-single-single %compare-single-complex-single
- single fcmps fsubs)
+ single fcmps fsubs)
(frob %compare-complex-double-double %compare-double-complex-double
- double fcmpd fsubd))
+ double fcmpd fsubd))
;; Compare two complex numbers for equality
(macrolet
((frob (float-type fcmp)
(let ((vop-name
- (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:translate =)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y)))
- (inst ,fcmp xr yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp xi yi)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop)))))))
+ (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:translate =)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y)))
+ (inst ,fcmp xr yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp xi yi)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop)))))))
(frob single fcmps)
(frob double fcmpd))
(macrolet
((frob (float-type fcmp)
(let ((vop-name
- (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:translate =)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc descriptor-reg) true)
- (:guard (member :sparc-v9 *backend-subfeatures*))
- (:generator 5
- (note-this-location vop :internal-error)
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y)))
- ;; Assume comparison is true
- (load-symbol true t)
- (inst ,fcmp xr yr)
- (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
- (inst ,fcmp xi yi)
- (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
- (inst cmp true null-tn)
- (inst b (if not-p :eq :ne) target :pt)
- (inst nop)))))))
+ (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:translate =)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc descriptor-reg) true)
+ (:guard (member :sparc-v9 *backend-subfeatures*))
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Assume comparison is true
+ (load-symbol true t)
+ (inst ,fcmp xr yr)
+ (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+ (inst ,fcmp xi yi)
+ (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+ (inst cmp true null-tn)
+ (inst b (if not-p :eq :ne) target :pt)
+ (inst nop)))))))
(frob single fcmps)
(frob double fcmpd))
;; Vops to take advantage of the conditional move instruction
;; available on the Sparc V9
-
+
(defknown (%%max %%min) ((or (unsigned-byte #.n-word-bits)
- (signed-byte #.n-word-bits)
- single-float double-float)
- (or (unsigned-byte #.n-word-bits)
- (signed-byte #.n-word-bits)
- single-float double-float))
+ (signed-byte #.n-word-bits)
+ single-float double-float)
+ (or (unsigned-byte #.n-word-bits)
+ (signed-byte #.n-word-bits)
+ single-float double-float))
(or (unsigned-byte #.n-word-bits)
(signed-byte #.n-word-bits)
single-float double-float)
(movable foldable flushable))
-;; We need these definitions for byte-compiled code
+;; We need these definitions for byte-compiled code
;;
;; Well, we (SBCL) probably don't, having deleted the byte
;; compiler. Let's see what happens if we comment out these
#+nil
(defun %%min (x y)
(declare (type (or (unsigned-byte 32) (signed-byte 32)
- single-float double-float) x y))
+ single-float double-float) x y))
(if (<= x y)
x y))
#+nil
(defun %%max (x y)
(declare (type (or (unsigned-byte 32) (signed-byte 32)
- single-float double-float) x y))
+ single-float double-float) x y))
(if (>= x y)
x y))
-#+nil
+#+nil
(macrolet
((frob (name sc-type type compare cmov cost cc max min note)
(let ((vop-name (symbolicate name "-" type "=>" type))
- (trans-name (symbolicate "%%" name)))
- `(define-vop (,vop-name)
- (:args (x :scs (,sc-type))
- (y :scs (,sc-type)))
- (:results (r :scs (,sc-type)))
- (:arg-types ,type ,type)
- (:result-types ,type)
- (:policy :fast-safe)
- (:note ,note)
- (:translate ,trans-name)
- (:guard (member :sparc-v9 *backend-subfeatures*))
- (:generator ,cost
- (inst ,compare x y)
- (cond ((location= r x)
- ;; If x < y, need to move y to r, otherwise r already has
- ;; the max.
- (inst ,cmov ,min r y ,cc))
- ((location= r y)
- ;; If x > y, need to move x to r, otherwise r already has
- ;; the max.
- (inst ,cmov ,max r x ,cc))
- (t
- ;; It doesn't matter what R is, just copy the min to R.
- (inst ,cmov ,max r x ,cc)
- (inst ,cmov ,min r y ,cc))))))))
+ (trans-name (symbolicate "%%" name)))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,sc-type))
+ (y :scs (,sc-type)))
+ (:results (r :scs (,sc-type)))
+ (:arg-types ,type ,type)
+ (:result-types ,type)
+ (:policy :fast-safe)
+ (:note ,note)
+ (:translate ,trans-name)
+ (:guard (member :sparc-v9 *backend-subfeatures*))
+ (:generator ,cost
+ (inst ,compare x y)
+ (cond ((location= r x)
+ ;; If x < y, need to move y to r, otherwise r already has
+ ;; the max.
+ (inst ,cmov ,min r y ,cc))
+ ((location= r y)
+ ;; If x > y, need to move x to r, otherwise r already has
+ ;; the max.
+ (inst ,cmov ,max r x ,cc))
+ (t
+ ;; It doesn't matter what R is, just copy the min to R.
+ (inst ,cmov ,max r x ,cc)
+ (inst ,cmov ,min r y ,cc))))))))
(frob max single-reg single-float fcmps cfmovs 3
- :fcc0 :ge :l "inline float max")
+ :fcc0 :ge :l "inline float max")
(frob max double-reg double-float fcmpd cfmovd 3
- :fcc0 :ge :l "inline float max")
+ :fcc0 :ge :l "inline float max")
(frob min single-reg single-float fcmps cfmovs 3
- :fcc0 :l :ge "inline float min")
+ :fcc0 :l :ge "inline float min")
(frob min double-reg double-float fcmpd cfmovd 3
- :fcc0 :l :ge "inline float min")
+ :fcc0 :l :ge "inline float min")
;; Strictly speaking these aren't float ops, but it's convenient to
;; do them here.
;;
;; 32-bit integer operands, we add 2 more to account for the
;; untagging of fixnums, if necessary.
(frob max signed-reg signed-num cmp cmove 5
- :icc :ge :lt "inline (signed-byte 32) max")
+ :icc :ge :lt "inline (signed-byte 32) max")
(frob max unsigned-reg unsigned-num cmp cmove 5
- :icc :ge :lt "inline (unsigned-byte 32) max")
+ :icc :ge :lt "inline (unsigned-byte 32) max")
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(frob max any-reg tagged-num cmp cmove 3
- :icc :ge :lt "inline fixnum max")
+ :icc :ge :lt "inline fixnum max")
(frob min signed-reg signed-num cmp cmove 5
- :icc :lt :ge "inline (signed-byte 32) min")
+ :icc :lt :ge "inline (signed-byte 32) min")
(frob min unsigned-reg unsigned-num cmp cmove 5
- :icc :lt :ge "inline (unsigned-byte 32) min")
+ :icc :lt :ge "inline (unsigned-byte 32) min")
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(frob min any-reg tagged-num cmp cmove 3
- :icc :lt :ge "inline fixnum min"))
-
+ :icc :lt :ge "inline fixnum min"))
+
#+nil
(define-vop (max-boxed-double-float=>boxed-double-float)
(:args (x :scs (descriptor-reg))
- (y :scs (descriptor-reg)))
+ (y :scs (descriptor-reg)))
(:results (r :scs (descriptor-reg)))
(:arg-types double-float double-float)
(:result-types double-float)
(:vop-var vop)
(:generator 3
(let ((offset (- (* double-float-value-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(inst lddf xval x offset)
(inst lddf yval y offset)
(inst fcmpd xval yval)
(cond ((location= r x)
- ;; If x < y, need to move y to r, otherwise r already has
- ;; the max.
- (inst cmove :l r y :fcc0))
- ((location= r y)
- ;; If x > y, need to move x to r, otherwise r already has
- ;; the max.
- (inst cmove :ge r x :fcc0))
- (t
- ;; It doesn't matter what R is, just copy the min to R.
- (inst cmove :ge r x :fcc0)
- (inst cmove :l r y :fcc0))))))
-
+ ;; If x < y, need to move y to r, otherwise r already has
+ ;; the max.
+ (inst cmove :l r y :fcc0))
+ ((location= r y)
+ ;; If x > y, need to move x to r, otherwise r already has
+ ;; the max.
+ (inst cmove :ge r x :fcc0))
+ (t
+ ;; It doesn't matter what R is, just copy the min to R.
+ (inst cmove :ge r x :fcc0)
+ (inst cmove :l r y :fcc0))))))
+
) ; PROGN
#+nil
;;; The sparc-v9 architecture has conditional move instructions that
;;; can be used. This should be faster than using the obvious if
;;; expression since we don't have to do branches.
-
+
(define-source-transform min (&rest args)
(if (member :sparc-v9 *backend-subfeatures*)
(case (length args)
- ((0 2) (values nil t))
- (1 `(values ,(first args)))
- (t (sb!c::associate-arguments 'min (first args) (rest args))))
+ ((0 2) (values nil t))
+ (1 `(values ,(first args)))
+ (t (sb!c::associate-arguments 'min (first args) (rest args))))
(values nil t)))
(define-source-transform max (&rest args)
(if (member :sparc-v9 *backend-subfeatures*)
(case (length args)
- ((0 2) (values nil t))
- (1 `(values ,(first args)))
- (t (sb!c::associate-arguments 'max (first args) (rest args))))
+ ((0 2) (values nil t))
+ (1 `(values ,(first args)))
+ (t (sb!c::associate-arguments 'max (first args) (rest args))))
(values nil t)))
;; Derive the types of max and min
(multiple-value-bind (definitely-< definitely->=)
(ir1-transform-<-helper x y)
(cond (definitely-<
- (lvar-type y))
- (definitely->=
- (lvar-type x))
- (t
- (make-canonical-union-type (list (lvar-type x)
- (lvar-type y)))))))
+ (lvar-type y))
+ (definitely->=
+ (lvar-type x))
+ (t
+ (make-canonical-union-type (list (lvar-type x)
+ (lvar-type y)))))))
(defoptimizer (min derive-type) ((x y))
(multiple-value-bind (definitely-> definitely-<=)
(ir1-transform-<-helper y x)
(cond (definitely-<=
- (lvar-type x))
- (definitely->
- (lvar-type y))
- (t
- (make-canonical-union-type (list (lvar-type x)
- (lvar-type y)))))))
+ (lvar-type x))
+ (definitely->
+ (lvar-type y))
+ (t
+ (make-canonical-union-type (list (lvar-type x)
+ (lvar-type y)))))))
(deftransform max ((x y) (number number) *)
(let ((x-type (lvar-type x))
- (y-type (lvar-type y))
- (signed (specifier-type '(signed-byte #.n-word-bits)))
- (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
- (d-float (specifier-type 'double-float))
- (s-float (specifier-type 'single-float)))
+ (y-type (lvar-type y))
+ (signed (specifier-type '(signed-byte #.n-word-bits)))
+ (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
+ (d-float (specifier-type 'double-float))
+ (s-float (specifier-type 'single-float)))
;; Use %%max if both args are good types of the same type. As a
;; last resort, use the obvious comparison to select the desired
;; element.
(cond ((and (csubtypep x-type signed)
- (csubtypep y-type signed))
- `(%%max x y))
- ((and (csubtypep x-type unsigned)
- (csubtypep y-type unsigned))
- `(%%max x y))
- ((and (csubtypep x-type d-float)
- (csubtypep y-type d-float))
- `(%%max x y))
- ((and (csubtypep x-type s-float)
- (csubtypep y-type s-float))
- `(%%max x y))
- (t
- (let ((arg1 (gensym))
- (arg2 (gensym)))
- `(let ((,arg1 x)
- (,arg2 y))
- (if (>= ,arg1 ,arg2)
- ,arg1 ,arg2)))))))
+ (csubtypep y-type signed))
+ `(%%max x y))
+ ((and (csubtypep x-type unsigned)
+ (csubtypep y-type unsigned))
+ `(%%max x y))
+ ((and (csubtypep x-type d-float)
+ (csubtypep y-type d-float))
+ `(%%max x y))
+ ((and (csubtypep x-type s-float)
+ (csubtypep y-type s-float))
+ `(%%max x y))
+ (t
+ (let ((arg1 (gensym))
+ (arg2 (gensym)))
+ `(let ((,arg1 x)
+ (,arg2 y))
+ (if (>= ,arg1 ,arg2)
+ ,arg1 ,arg2)))))))
(deftransform min ((x y) (real real) *)
(let ((x-type (lvar-type x))
- (y-type (lvar-type y))
- (signed (specifier-type '(signed-byte #.n-word-bits)))
- (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
- (d-float (specifier-type 'double-float))
- (s-float (specifier-type 'single-float)))
+ (y-type (lvar-type y))
+ (signed (specifier-type '(signed-byte #.n-word-bits)))
+ (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
+ (d-float (specifier-type 'double-float))
+ (s-float (specifier-type 'single-float)))
(cond ((and (csubtypep x-type signed)
- (csubtypep y-type signed))
- `(%%min x y))
- ((and (csubtypep x-type unsigned)
- (csubtypep y-type unsigned))
- `(%%min x y))
- ((and (csubtypep x-type d-float)
- (csubtypep y-type d-float))
- `(%%min x y))
- ((and (csubtypep x-type s-float)
- (csubtypep y-type s-float))
- `(%%min x y))
- (t
- (let ((arg1 (gensym))
- (arg2 (gensym)))
- `(let ((,arg1 x)
- (,arg2 y))
- (if (<= ,arg1 ,arg2)
- ,arg1 ,arg2)))))))
+ (csubtypep y-type signed))
+ `(%%min x y))
+ ((and (csubtypep x-type unsigned)
+ (csubtypep y-type unsigned))
+ `(%%min x y))
+ ((and (csubtypep x-type d-float)
+ (csubtypep y-type d-float))
+ `(%%min x y))
+ ((and (csubtypep x-type s-float)
+ (csubtypep y-type s-float))
+ `(%%min x y))
+ (t
+ (let ((arg1 (gensym))
+ (arg2 (gensym)))
+ `(let ((,arg1 x)
+ (,arg2 y))
+ (if (<= ,arg1 ,arg2)
+ ,arg1 ,arg2)))))))
) ; PROGN
projects / sbcl.git / blobdiff