Skip to content
Snippets Groups Projects
Commit 45026f2e authored by dtc's avatar dtc
Browse files

o Correct the previous patch which should also have defined the

  function ir1-transform-<-helper for use by the min/max optimizers
  and transforms; from Raymond Toy.
parent 54ac7bea
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.95 2000/04/02 18:46:03 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.96 2000/04/06 18:40:15 dtc Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -3311,8 +3311,35 @@ ...@@ -3311,8 +3311,35 @@
`(,inverse y x)) `(,inverse y x))
(t (t
(give-up)))))) (give-up))))))
;;; Ir1-transform-<-helper -- Internal
;;;
;;; Derive the result type of the comparision X < Y returning two values: the
;;; first true if X < Y, and the second true if X >= Y. Union types are
;;; handled by comparing all types of X with all types of Y. If all types of
;;; X are less than all types of Y, then X < Y. Similarly, if all types of X
;;; are >= all types of Y, then X >= Y.
;;;
#+propagate-float-type #+propagate-float-type
(defun ir1-transform-<-helper (x y)
(flet ((maybe-convert (type)
(numeric-type->interval (if (member-type-p type)
(convert-member-type type)
type))))
(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))))
;;; IR1-TRANSFORM-< -- Internal ;;; IR1-TRANSFORM-< -- Internal
;;; ;;;
;;; See if we can statically determine (< X Y) using type information. If ;;; See if we can statically determine (< X Y) using type information. If
...@@ -3320,39 +3347,21 @@ ...@@ -3320,39 +3347,21 @@
;;; Y's high, then X >= Y (so return NIL). If not, at least make sure any ;;; Y's high, then X >= Y (so return NIL). If not, at least make sure any
;;; constant arg is second. ;;; constant arg is second.
;;; ;;;
;;; Union types are handled by comparing all types of X with all types of Y. #+propagate-float-type
;;; If all types of X are less than all types of Y, then X < Y. Similarly, if
;;; all types of X are >= all types of Y, then X >= Y (so return NIL).
;;;
(defun ir1-transform-< (x y first second inverse) (defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y) (if (same-leaf-ref-p x y)
'nil 'nil
(let ((definitely-true t) (multiple-value-bind (definitely-true definitely-false)
(definitely-false t)) (ir1-transform-<-helper x y)
(flet ((maybe-convert (type)
(numeric-type->interval (if (member-type-p type)
(convert-member-type type)
type))))
(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)))))
(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)))))))
(cond (definitely-true (cond (definitely-true
t) t)
(definitely-false (definitely-false
nil) nil)
((and (constant-continuation-p first) ((and (constant-continuation-p first)
(not (constant-continuation-p second))) (not (constant-continuation-p second)))
`(,inverse y x)) `(,inverse y x))
(t (t
(give-up)))))) (give-up))))))
(deftransform < ((x y) #-propagate-float-type (integer integer) (deftransform < ((x y) #-propagate-float-type (integer integer)
#+propagate-float-type (real real) #+propagate-float-type (real real)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment