- (define-vop (,sname)
- (:translate ,op)
- (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
- :to :eval)
- (y :scs (single-reg single-stack #+nil descriptor-reg)
- :to :eval))
- (:temporary (:sc single-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (single-reg single-stack)))
- (:arg-types single-float single-float)
- (:result-types single-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,scost
- ;; Handle a few special cases
- (cond
- ;; x, y, and r are the same register.
- ((and (sc-is x single-reg) (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch r)
- (inst ,fop fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((and (sc-is x single-reg) (location= x r))
- (cond ((zerop (tn-offset r))
- (sc-case y
- (single-reg
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fop y))
- (single-stack
- ;; ST(0) = ST(0) op Mem
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y)))))
- (t
- ;; y to ST0
- (sc-case y
- (single-reg
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is y single-stack)
- (inst fld (ea-for-sf-stack y))
- (inst fld (ea-for-sf-desc y)))))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((and (sc-is y single-reg) (location= y r))
- (cond ((zerop (tn-offset r))
- (sc-case x
- (single-reg
- ;; ST(0) = ST(x) op ST(0)
- (inst ,fopr x))
- (single-stack
- ;; ST(0) = Mem op ST(0)
- (inst ,fopr (ea-for-sf-stack x)))
- (descriptor-reg
- (inst ,fopr (ea-for-sf-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (single-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x single-stack)
- (inst fld (ea-for-sf-stack x))
- (inst fld (ea-for-sf-desc x)))))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0
- ((and (sc-is x single-reg) (zerop (tn-offset x)))
- ;; ST0 = ST0 op y
- (sc-case y
- (single-reg
- (inst ,fop y))
- (single-stack
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y)))))
- ;; y is in ST0
- ((and (sc-is y single-reg) (zerop (tn-offset y)))
- ;; ST0 = x op ST0
- (sc-case x
- (single-reg
- (inst ,fopr x))
- (single-stack
- (inst ,fopr (ea-for-sf-stack x)))
- (descriptor-reg
- (inst ,fopr (ea-for-sf-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (single-reg
- (copy-fp-reg-to-fr0 x))
- (single-stack
- (inst fstp fr0)
- (inst fld (ea-for-sf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fld (ea-for-sf-desc x))))
- ;; ST0 = ST0 op y
- (sc-case y
- (single-reg
- (inst ,fop y))
- (single-stack
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y))))))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (sc-case r
- (single-reg
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))
- (single-stack
- (inst fst (ea-for-sf-stack r))))))))
-
- (define-vop (,dname)
- (:translate ,op)
- (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
- :to :eval)
- (y :scs (double-reg double-stack #+nil descriptor-reg)
- :to :eval))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (double-reg double-stack)))
- (:arg-types double-float double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,dcost
- ;; Handle a few special cases.
- (cond
- ;; x, y, and r are the same register.
- ((and (sc-is x double-reg) (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch x)
- (inst ,fopd fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((and (sc-is x double-reg) (location= x r))
- (cond ((zerop (tn-offset r))
- (sc-case y
- (double-reg
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fopd y))
- (double-stack
- ;; ST(0) = ST(0) op Mem
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y)))))
- (t
- ;; y to ST0
- (sc-case y
- (double-reg
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is y double-stack)
- (inst fldd (ea-for-df-stack y))
- (inst fldd (ea-for-df-desc y)))))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((and (sc-is y double-reg) (location= y r))
- (cond ((zerop (tn-offset r))
- (sc-case x
- (double-reg
- ;; ST(0) = ST(x) op ST(0)
- (inst ,foprd x))
- (double-stack
- ;; ST(0) = Mem op ST(0)
- (inst ,foprd (ea-for-df-stack x)))
- (descriptor-reg
- (inst ,foprd (ea-for-df-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0
- ((and (sc-is x double-reg) (zerop (tn-offset x)))
- ;; ST0 = ST0 op y
- (sc-case y
- (double-reg
- (inst ,fopd y))
- (double-stack
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y)))))
- ;; y is in ST0
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- ;; ST0 = x op ST0
- (sc-case x
- (double-reg
- (inst ,foprd x))
- (double-stack
- (inst ,foprd (ea-for-df-stack x)))
- (descriptor-reg
- (inst ,foprd (ea-for-df-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x))))
- ;; ST0 = ST0 op y
- (sc-case y
- (double-reg
- (inst ,fopd y))
- (double-stack
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y))))))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (sc-case r
- (double-reg
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))
- (double-stack
- (inst fstd (ea-for-df-stack r))))))))
-
- #!+long-float
- (define-vop (,lname)
- (:translate ,op)
- (:args (x :scs (long-reg) :to :eval)
- (y :scs (long-reg) :to :eval))
- (:temporary (:sc long-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (long-reg)))
- (:arg-types long-float long-float)
- (:result-types long-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,lcost
- ;; Handle a few special cases.
- (cond
- ;; x, y, and r are the same register.
- ((and (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch x)
- (inst ,fopd fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((location= x r)
- (cond ((zerop (tn-offset r))
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fopd y))
- (t
- ;; y to ST0
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((location= y r)
- (cond ((zerop (tn-offset r))
- ;; ST(0) = ST(x) op ST(0)
- (inst ,foprd x))
- (t
- ;; x to ST0
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0.
- ((zerop (tn-offset x))
- ;; ST0 = ST0 op y
- (inst ,fopd y))
- ;; y is in ST0
- ((zerop (tn-offset y))
- ;; ST0 = x op ST0
- (inst ,foprd x))
- (t
- ;; x to ST0
- (copy-fp-reg-to-fr0 x)
- ;; ST0 = ST0 op y
- (inst ,fopd y)))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))))))))
+ (define-vop (,sname)
+ (:translate ,op)
+ (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
+ :to :eval)
+ (y :scs (single-reg single-stack #+nil descriptor-reg)
+ :to :eval))
+ (:temporary (:sc single-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (single-reg single-stack)))
+ (:arg-types single-float single-float)
+ (:result-types single-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,scost
+ ;; Handle a few special cases
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (sc-is x single-reg) (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch r)
+ (inst ,fop fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((and (sc-is x single-reg) (location= x r))
+ (cond ((zerop (tn-offset r))
+ (sc-case y
+ (single-reg
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fop y))
+ (single-stack
+ ;; ST(0) = ST(0) op Mem
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y)))))
+ (t
+ ;; y to ST0
+ (sc-case y
+ (single-reg
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is y single-stack)
+ (inst fld (ea-for-sf-stack y))
+ (inst fld (ea-for-sf-desc y)))))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (maybe-fp-wait node vop))
+ ;; y and r are the same register.
+ ((and (sc-is y single-reg) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (sc-case x
+ (single-reg
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,fopr x))
+ (single-stack
+ ;; ST(0) = Mem op ST(0)
+ (inst ,fopr (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst ,fopr (ea-for-sf-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (maybe-fp-wait node vop))
+ ;; the default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0
+ ((and (sc-is x single-reg) (zerop (tn-offset x)))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (single-reg
+ (inst ,fop y))
+ (single-stack
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y)))))
+ ;; y is in ST0
+ ((and (sc-is y single-reg) (zerop (tn-offset y)))
+ ;; ST0 = x op ST0
+ (sc-case x
+ (single-reg
+ (inst ,fopr x))
+ (single-stack
+ (inst ,fopr (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst ,fopr (ea-for-sf-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (copy-fp-reg-to-fr0 x))
+ (single-stack
+ (inst fstp fr0)
+ (inst fld (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fld (ea-for-sf-desc x))))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (single-reg
+ (inst ,fop y))
+ (single-stack
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y))))))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result.
+ (sc-case r
+ (single-reg
+ (cond ((zerop (tn-offset r))
+ (maybe-fp-wait node))
+ (t
+ (inst fst r))))
+ (single-stack
+ (inst fst (ea-for-sf-stack r))))))))
+
+ (define-vop (,dname)
+ (:translate ,op)
+ (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
+ :to :eval)
+ (y :scs (double-reg double-stack #+nil descriptor-reg)
+ :to :eval))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (double-reg double-stack)))
+ (:arg-types double-float double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,dcost
+ ;; Handle a few special cases.
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (sc-is x double-reg) (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch x)
+ (inst ,fopd fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((and (sc-is x double-reg) (location= x r))
+ (cond ((zerop (tn-offset r))
+ (sc-case y
+ (double-reg
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fopd y))
+ (double-stack
+ ;; ST(0) = ST(0) op Mem
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y)))))
+ (t
+ ;; y to ST0
+ (sc-case y
+ (double-reg
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is y double-stack)
+ (inst fldd (ea-for-df-stack y))
+ (inst fldd (ea-for-df-desc y)))))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (maybe-fp-wait node vop))
+ ;; y and r are the same register.
+ ((and (sc-is y double-reg) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (sc-case x
+ (double-reg
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,foprd x))
+ (double-stack
+ ;; ST(0) = Mem op ST(0)
+ (inst ,foprd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst ,foprd (ea-for-df-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (maybe-fp-wait node vop))
+ ;; the default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0
+ ((and (sc-is x double-reg) (zerop (tn-offset x)))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (double-reg
+ (inst ,fopd y))
+ (double-stack
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y)))))
+ ;; y is in ST0
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ ;; ST0 = x op ST0
+ (sc-case x
+ (double-reg
+ (inst ,foprd x))
+ (double-stack
+ (inst ,foprd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst ,foprd (ea-for-df-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x))))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (double-reg
+ (inst ,fopd y))
+ (double-stack
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y))))))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result.
+ (sc-case r
+ (double-reg
+ (cond ((zerop (tn-offset r))
+ (maybe-fp-wait node))
+ (t
+ (inst fst r))))
+ (double-stack
+ (inst fstd (ea-for-df-stack r))))))))
+
+ #!+long-float
+ (define-vop (,lname)
+ (:translate ,op)
+ (:args (x :scs (long-reg) :to :eval)
+ (y :scs (long-reg) :to :eval))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,lcost
+ ;; Handle a few special cases.
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch x)
+ (inst ,fopd fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((location= x r)
+ (cond ((zerop (tn-offset r))
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fopd y))
+ (t
+ ;; y to ST0
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (maybe-fp-wait node vop))
+ ;; y and r are the same register.
+ ((location= y r)
+ (cond ((zerop (tn-offset r))
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,foprd x))
+ (t
+ ;; x to ST0
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (maybe-fp-wait node vop))
+ ;; the default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0.
+ ((zerop (tn-offset x))
+ ;; ST0 = ST0 op y
+ (inst ,fopd y))
+ ;; y is in ST0
+ ((zerop (tn-offset y))
+ ;; ST0 = x op ST0
+ (inst ,foprd x))
+ (t
+ ;; x to ST0
+ (copy-fp-reg-to-fr0 x)
+ ;; ST0 = ST0 op y
+ (inst ,fopd y)))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result.
+ (cond ((zerop (tn-offset r))
+ (maybe-fp-wait node))
+ (t
+ (inst fst r))))))))))