-;;; This file contains floating point support for the Alpha.
-
-(in-package "SB!VM")
+;;;; floating point support for the Alpha
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+(in-package "SB!VM")
\f
-;;;; Move functions:
+;;;; float move functions
(define-move-function (load-fp-zero 1) (vop x y)
((fp-single-zero) (single-reg)
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) word-bytes)))
(inst stt x offset nfp)))
-
-
\f
-;;;; Move VOPs:
+;;;; float move VOPs
(macrolet ((frob (vop sc)
`(progn
(:generator 13
(with-fixed-allocation (y ndescr type size)
(if double-p
- (inst stt x (- (* data word-bytes) other-pointer-type) y)
- (inst sts x (- (* data word-bytes) other-pointer-type) y)))))
+ (inst stt x (- (* data word-bytes) other-pointer-lowtag) y)
+ (inst sts x (- (* data word-bytes) other-pointer-lowtag) y)))))
(macrolet ((frob (name sc &rest args)
`(progn
(:generator 2
,@(if double-p
`((inst ldt y (- (* ,value word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
x))
`((inst lds y (- (* ,value word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
x)))))
(define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg nil single-float-value-slot)
(,sc descriptor-reg) (,sc)))))
(frob move-single-float-argument single-reg single-stack nil)
(frob move-double-float-argument double-reg double-stack t))
-
\f
-;;;; Complex float move functions
+;;;; complex float move functions
(defun complex-single-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg )
(inst stt imag-tn (+ offset (* 2 sb!vm:word-bytes)) nfp))))
;;;
-;;; Complex float register to register moves.
+;;; complex float register to register moves.
;;;
(define-vop (complex-single-move)
(:args (x :scs (complex-single-reg) :target y
(let ((real-tn (complex-single-reg-real-tn x)))
(inst sts real-tn (- (* sb!vm:complex-single-float-real-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(inst sts imag-tn (- (* sb!vm:complex-single-float-imag-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y)))))
;;;
(define-move-vop move-from-complex-single :move
(let ((real-tn (complex-double-reg-real-tn x)))
(inst stt real-tn (- (* sb!vm:complex-double-float-real-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y))
(let ((imag-tn (complex-double-reg-imag-tn x)))
(inst stt imag-tn (- (* sb!vm:complex-double-float-imag-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y)))))
;;;
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
;;;
-;;; Move from a descriptor to a complex float register
+;;; Move from a descriptor to a complex float register.
;;;
(define-vop (move-to-complex-single)
(:args (x :scs (descriptor-reg)))
(:generator 2
(let ((real-tn (complex-single-reg-real-tn y)))
(inst lds real-tn (- (* complex-single-float-real-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(inst lds imag-tn (- (* complex-single-float-imag-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))))
(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 ldt real-tn (- (* complex-double-float-real-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(inst ldt imag-tn (- (* complex-double-float-imag-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
;;;
-;;; Complex float move-argument vop
+;;; complex float move-argument vop
;;;
(define-vop (move-complex-single-float-argument)
(:args (x :scs (complex-single-reg) :target y)
(descriptor-reg))
\f
-;;;; Arithmetic VOPs:
+;;;; float arithmetic VOPs
(define-vop (float-op)
(:args (x) (y))
(:vop-var vop)
(:save-p :compute-only))
-;;; Need to insure that ops that can cause traps do not clobber an
-;;; argument register with invalid results. This so the software
-;;; trap handler can re-execute the instruction and produce correct
-;;; IEEE result. The :from :load hopefully does that.
+;;; We need to insure that ops that can cause traps do not clobber an
+;;; argument register with invalid results. This so the software trap
+;;; handler can re-execute the instruction and produce correct IEEE
+;;; result. The :from :load hopefully does that.
(macrolet ((frob (name sc ptype)
`(define-vop (,name float-op)
(:args (x :scs (,sc))
(frob %negate/double-float fneg %negate double-reg double-float))
\f
-;;;; Comparison:
+;;;; float comparison
(define-vop (float-compare)
(:args (x) (y))
(frob = nil =/single-float =/double-float t))
\f
-;;;; Conversion:
+;;;; float conversion
(macrolet
((frob (name translate inst ld-inst to-sc to-type &optional single)
(* (tn-offset float) sb!vm:word-bytes)
(current-nfp-tn vop)))
(descriptor-reg
- (loadw bits float sb!vm:single-float-value-slot sb!vm:other-pointer-type))))
+ (loadw bits float sb!vm:single-float-value-slot
+ sb!vm:other-pointer-lowtag))))
(signed-stack
(sc-case float
(single-reg
(current-nfp-tn vop)))
(descriptor-reg
(loadw hi-bits float (1+ sb!vm:double-float-value-slot)
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
(current-nfp-tn vop)))
(descriptor-reg
(loadw lo-bits float sb!vm:double-float-value-slot
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mskll lo-bits 4 lo-bits)))
\f
-;;;; Float mode hackery:
+;;;; float mode hackery
(sb!xc:deftype float-modes () '(unsigned-byte 32)) ;actually 24 -dan
(defknown floating-point-modes () float-modes (flushable))
(move res new))))
\f
-;;;; Complex float VOPs
+;;;; complex float VOPs
(define-vop (make-complex-single-float)
(:translate complex)
projects / sbcl.git / blobdiff