- (inst fldx index nfp res))))))
-
-
-(define-vop (single-float-bits)
- (:args (float :scs (single-reg)
- :load-if (not (sc-is float single-stack))))
- (:results (bits :scs (signed-reg)
- :load-if (or (not (sc-is bits signed-stack))
- (sc-is float single-stack))))
- (:arg-types single-float)
- (:result-types signed-num)
- (:translate single-float-bits)
- (:policy :fast-safe)
- (:vop-var vop)
- (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
- (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
- (:generator 2
- (let ((nfp (current-nfp-tn vop)))
- (sc-case float
- (single-reg
- (sc-case bits
- (signed-reg
- (let ((offset (* (tn-offset temp) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp)))
- (inst ldw offset nfp bits)))
- (signed-stack
- (let ((offset (* (tn-offset bits) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp)))))))
- (single-stack
- (sc-case bits
- (signed-reg
- (inst ldw (* (tn-offset float) n-word-bytes) nfp bits))))))))
-
-(define-vop (double-float-high-bits)
- (:args (float :scs (double-reg)
- :load-if (not (sc-is float double-stack))))
- (:results (hi-bits :scs (signed-reg)
- :load-if (or (not (sc-is hi-bits signed-stack))
- (sc-is float double-stack))))
- (:arg-types double-float)
- (:result-types signed-num)
- (:translate double-float-high-bits)
- (:policy :fast-safe)
- (:vop-var vop)
- (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
- (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
- (:generator 2
- (let ((nfp (current-nfp-tn vop)))
- (sc-case float
- (double-reg
- (sc-case hi-bits
- (signed-reg
- (let ((offset (* (tn-offset temp) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 0))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 0)))
- (inst ldw offset nfp hi-bits)))
- (signed-stack
- (let ((offset (* (tn-offset hi-bits) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 0))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 0)))))))
- (double-stack
- (sc-case hi-bits
- (signed-reg
- (let ((offset (* (tn-offset float) n-word-bytes)))
- (inst ldw offset nfp hi-bits)))))))))
-
-(define-vop (double-float-low-bits)
- (:args (float :scs (double-reg)
- :load-if (not (sc-is float double-stack))))
- (:results (lo-bits :scs (unsigned-reg)
- :load-if (or (not (sc-is lo-bits unsigned-stack))
- (sc-is float double-stack))))
- (:arg-types double-float)
- (:result-types unsigned-num)
- (:translate double-float-low-bits)
- (:policy :fast-safe)
- (:vop-var vop)
- (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
- (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
- (:generator 2
- (let ((nfp (current-nfp-tn vop)))
- (sc-case float
- (double-reg
- (sc-case lo-bits
- (unsigned-reg
- (let ((offset (* (tn-offset temp) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 1))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 1)))
- (inst ldw offset nfp lo-bits)))
- (unsigned-stack
- (let ((offset (* (tn-offset lo-bits) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 1))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 1)))))))
- (double-stack
- (sc-case lo-bits
- (unsigned-reg
- (let ((offset (* (1+ (tn-offset float)) n-word-bytes)))
- (inst ldw offset nfp lo-bits)))))))))
-
+ (inst fldx index nfp res))
+ (t
+ (error "make-single-float error, ldo offset too large"))))))
+
+(macrolet
+ ((float-bits (name reg rreg stack rstack atype anum side offset)
+ `(define-vop (,name)
+ (:args (float :scs (,reg)
+ :load-if (not (sc-is float ,stack))))
+ (:results (bits :scs (,rreg)
+ :load-if (or (not (sc-is bits ,rstack))
+ (sc-is float ,stack))))
+ (:arg-types ,atype)
+ (:result-types ,anum)
+ (:translate ,name)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
+ (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
+ (:generator 2
+ (let ((nfp (current-nfp-tn vop)))
+ (sc-case float
+ (,reg
+ (sc-case bits
+ (,rreg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ ,@(if side
+ `((inst fsts float offset nfp :side ,side))
+ `((inst fsts float offset nfp))))
+ ((and (< offset (ash 1 13))
+ (> offset 0))
+ (inst ldo offset zero-tn index)
+ ,@(if side
+ `((inst fstx float index nfp :side ,side))
+ `((inst fstx float index nfp))))
+ (t
+ (error ,(format nil "~s,~s: inst-LDO offset too large"
+ name rreg))))
+ (inst ldw offset nfp bits)))
+ (,rstack
+ (let ((offset (* (tn-offset bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ ,@(if side
+ `((inst fsts float offset nfp :side ,side))
+ `((inst fsts float offset nfp))))
+ ((and (< offset (ash 1 13))
+ (> offset 0))
+ (inst ldo offset zero-tn index)
+ ,@(if side
+ `((inst fstx float index nfp :side ,side))
+ `((inst fstx float index nfp))))
+ (t
+ (error ,(format nil "~s,~s: inst-LDO offset too large"
+ name rstack))))))))
+ (,stack
+ (sc-case bits
+ (,rreg
+ (inst ldw (* (+ (tn-offset float) ,offset) n-word-bytes)
+ nfp bits))))))))))
+ (float-bits single-float-bits single-reg signed-reg single-stack
+ signed-stack single-float signed-num nil 0)
+ (float-bits double-float-high-bits double-reg signed-reg
+ double-stack signed-stack double-float signed-num 0 0)
+ (float-bits double-float-low-bits double-reg unsigned-reg
+ double-stack unsigned-stack double-float unsigned-num 1 1))