[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] 2 commits: Add ir1 transform for >=

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl


Commits:
cd340ff8 by Raymond Toy at 2023-03-16T10:10:00-07:00
Add ir1 transform for >=

Without this, the compiler can't statically determine if x >= y is
always T or NIL, like it can for x < y (and x > y).  We choose >=
because only `interval-<` and `interval->=` are implemented so >= is a
natural choice.

- - - - -
49d36d2d by Raymond Toy at 2023-03-16T10:12:24-07:00
Update cmucl.pot

- - - - -


2 changed files:

- src/compiler/srctran.lisp
- src/i18n/locale/cmucl.pot


Changes:

=====================================
src/compiler/srctran.lisp
=====================================
@@ -3537,8 +3537,59 @@
 (deftransform > ((x y) (real real) * :when :both)
   (ir1-transform-< y x x y '<))
 
+#+(and x86)
+(defun ir1-transform->=-helper (x y)
+  (flet ((maybe-convert (type)
+	   (numeric-type->interval
+	    (cond ((numeric-type-p type) type)
+		  ((member-type-p type) (convert-member-type type))
+		  (t (give-up))))))
+    (let ((xi (mapcar #'maybe-convert
+		      (prepare-arg-for-derive-type (continuation-type x))))
+	  (yi (mapcar #'maybe-convert
+		      (prepare-arg-for-derive-type (continuation-type y))))
+	  (definitely-true t)
+	  (definitely-false t))
+      (dolist (x-arg xi)
+	(dolist (y-arg yi)
+	  (setf definitely-true (and definitely-true
+				     (interval->= x-arg y-arg)))
+	  (setf definitely-false (and definitely-false
+				      (interval-< x-arg y-arg)))))
+      (values definitely-true definitely-false))))
 
-#+x86
+#+(and x86)
+(defun ir1-transform->= (x y first second inverse)
+    (if (same-leaf-ref-p x y)
+	't
+	(multiple-value-bind (definitely-true definitely-false)
+	    (ir1-transform->=-helper x y)
+	  (cond (definitely-true
+		    t)
+		(definitely-false
+		    nil)
+		((and (constant-continuation-p first)
+                      (not (constant-continuation-p second)))
+		 #+nil
+		 (format t "swapping ~A~%" inverse)
+		 `(,inverse y x))
+		(t
+		 (give-up))))))
+
+#+(and x86)
+(deftransform <= ((x y) (real real) * :when :both)
+  #+nli
+  (format t "transform <=~%")
+  (ir1-transform->= y x x y '>=))
+
+#+(and  x86)
+(deftransform >= ((x y) (real real) * :when :both)
+  #+nil
+  (format t "transform >=~%")
+  (ir1-transform->= x y x y '<=))
+
+
+#+(and nil x86)
 (progn
   ;; When x and y are integers, we want to transform <= to > and >= to
   ;; <.  But we don't want to do this for floats because it messes up


=====================================
src/i18n/locale/cmucl.pot
=====================================
@@ -21588,3 +21588,9 @@ msgid ""
 "Unicode replacement character."
 msgstr ""
 
+transform <=
+transform >=
+transform <=
+transform >=
+transform >=
+transform <=



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/29cd008228a0d93a40a3803d5820997e32a72112...49d36d2dd91786fc6df688c6161614f424bce82a

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/29cd008228a0d93a40a3803d5820997e32a72112...49d36d2dd91786fc6df688c6161614f424bce82a
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/20230316/4d60868c/attachment-0001.html>