[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] 3 commits: First cut at using a common macro for both > and <.

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl


Commits:
225335b5 by Raymond Toy at 2023-03-10T11:42:37-08:00
First cut at using a common macro for both > and <.

This works, but I think it should be cleaned up a bit.

- - - - -
1ef34feb by Raymond Toy at 2023-03-10T12:05:04-08:00
Refactor comparison vops into one macro to handle them all.

Previously we had two macros: one for < and one for >.  They are
very similar so we combine them into one macro to handle both
operations.

- - - - -
552d91f3 by Raymond Toy at 2023-03-10T12:06:57-08:00
Remove unused swap-args-p arg to frob

We can determine whether we want to swap or not from the operation, so
we don't need this arg to frob anymore.

- - - - -


1 changed file:

- src/compiler/x86/float-sse2.lisp


Changes:

=====================================
src/compiler/x86/float-sse2.lisp
=====================================
@@ -944,8 +944,21 @@
   (frob single ucomiss)
   (frob double ucomisd))
 
+#+nil
 (macrolet
-    ((frob (op size inst)
+    ((gen-code (swap-args-p sc-type inst ea)
+       (if swap-args-p
+	   `(sc-case x
+	      (,sc-type
+	       (inst ,inst y x))
+	      (descriptor-reg
+	       (inst ,inst y (,ea x))))
+	   `(sc-case y
+	      (,sc-type
+	       (inst ,inst x y))
+	      (descriptor-reg
+	       (inst ,inst x (,ea y))))))
+     (frob (op size inst swap-args-p)
        (let ((ea (ecase size
 		   (single
 		    'ea-for-sf-desc)
@@ -958,11 +971,7 @@
 	    (:translate ,op)
 	    (:info target not-p)
 	    (:generator 3
-	      (sc-case y
-		(,sc-type
-		 (inst ,inst x y))
-		(descriptor-reg
-		 (inst ,inst x (,ea y))))
+	      (gen-code ,swap-args-p ,sc-type ,inst ,ea)
 	      ;; When a NaN occurs, comis sets ZF, PF, and CF = 1.  In
 	      ;; the normal case (not-p false), we want to jump to the
 	      ;; target when x > y.  This happens when CF = 0.  Hence,
@@ -974,11 +983,24 @@
 	      ;; these bits too, so we jump to the target for NaN or x
 	      ;; <= y, as desired.
 	      (inst jmp (if (not not-p) :a :be) target))))))
-  (frob > single comiss)
-  (frob > double comisd))
+  (frob > single comiss nil)
+  (frob > double comisd nil))
 
+#+nil
 (macrolet
-    ((frob (op size inst)
+    ((gen-code (swap-args-p sc-type inst ea)
+       (if swap-args-p
+	   `(sc-case x
+	      (,sc-type
+	       (inst ,inst y x))
+	      (descriptor-reg
+	       (inst ,inst y (,ea x))))
+	   `(sc-case y
+	      (,sc-type
+	       (inst ,inst x y))
+	      (descriptor-reg
+	       (inst ,inst x (,ea y))))))
+     (frob (op size inst swap-args-p)
        (let ((ea (ecase size
 		   (single
 		    'ea-for-sf-desc)
@@ -998,12 +1020,69 @@
 	      ;; args to reduce the number of jump instructions
 	      ;; needed.  Then the logic for the branches is the same
 	      ;; as for the case y > x above.
-	      (sc-case x
-		(,sc-type
-		 (inst ,inst y x))
-		(descriptor-reg
-		 (inst ,inst y (,ea x))))
+	      (gen-code ,swap-args-p ,sc-type ,inst ,ea)
+	      (inst jmp (if (not not-p) :a :be) target))))))
+  (frob < single comiss t)
+  (frob < double comisd t))
+
+(macrolet
+    ((gen-code (op sc-type inst ea)
+       ;; When the operation is >, the second arg (y) can be a
+       ;; register or a descriptor.  When the operation is <, the args
+       ;; are swapped and we want to allow x to be a register or
+       ;; descriptor.
+       (if (eq op '<)
+	   `(sc-case x
+	      (,sc-type
+	       (inst ,inst y x))
+	      (descriptor-reg
+	       (inst ,inst y (,ea x))))
+	   `(sc-case y
+	      (,sc-type
+	       (inst ,inst x y))
+	      (descriptor-reg
+	       (inst ,inst x (,ea y))))))
+     (frob (op size inst)
+       (let ((ea (ecase size
+		   (single
+		    'ea-for-sf-desc)
+		   (double
+		    'ea-for-df-desc)))
+	     (name (symbolicate op "/" size "-FLOAT"))
+	     (sc-type (symbolicate size "-REG"))
+	     (inherit (symbolicate size "-FLOAT-COMPARE")))
+	 `(define-vop (,name ,inherit)
+	    ;; When the operation is <, we want to rewrite x < y to y
+	    ;; > x.  In that case, we want to allow x to be in a
+	    ;; descriptor.  For >, y is allowed to be a descriptor.
+	    ,@(when (eq op '<)
+		`((:args (x :scs (,sc-type descriptor-reg))
+			 (y :scs (,sc-type)))))
+	    (:translate ,op)
+	    (:info target not-p)
+	    (:generator 3
+	      ;; Note: x < y is the same as y > x.  We reverse the
+	      ;; args to reduce the number of jump instructions
+	      ;; needed.
+	      (gen-code ,op ,sc-type ,inst ,ea)
+	      ;; Consider the case of x > y.
+	      ;;
+	      ;; When a NaN occurs, comis sets ZF, PF, and CF = 1.  In
+	      ;; the normal case (not-p false), we want to jump to the
+	      ;; target when x > y.  This happens when CF = 0.  Hence,
+	      ;; we won't jump to the target when there's a NaN, as
+	      ;; desired.
+	      ;;
+	      ;; For the not-p case, we want to jump to target when x
+	      ;; <= y.  This means CF = 1 or ZF = 1.  But NaN sets
+	      ;; these bits too, so we jump to the target for NaN or x
+	      ;; <= y, as desired.
+	      ;;
+	      ;; For the case of x < y, we can use the equivalent y >
+	      ;; x.  Thus if we swap the args, the same logic applies.
 	      (inst jmp (if (not not-p) :a :be) target))))))
+  (frob > single comiss)
+  (frob > double comisd)
   (frob < single comiss)
   (frob < double comisd))
 



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5ad9f2d825f2e986e04fa2da1fa8006edf4c164f...552d91f3cd7266a6fc54dcdf241847d5b5efa107

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5ad9f2d825f2e986e04fa2da1fa8006edf4c164f...552d91f3cd7266a6fc54dcdf241847d5b5efa107
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230310/66c1b0cf/attachment-0001.html>