Skip to content
Snippets Groups Projects
srctran.lisp 90.3 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.51 1997/06/05 00:33:16 dtc Exp $")
ram's avatar
ram committed
;;;
wlott's avatar
wlott committed
;;; **********************************************************************
;;;
;;;    This file contains macro-like source transformations which convert
;;; uses of certain functions into the canonical form desired within the
;;; compiler.  ### and other IR1 transforms and stuff.  Some code adapted from
;;; CLC, written by Wholey and Fahlman.
;;;
;;; Written by Rob MacLachlan
;;;
;;; Propagate-float-type extension by Raymond Toy.
;;;
(in-package "C")
wlott's avatar
wlott committed

;;; Source transform for Not, Null  --  Internal
;;;
;;;    Convert into an IF so that IF optimizations will eliminate redundant
;;; negations.
;;;
(def-source-transform not (x) `(if ,x nil t))
(def-source-transform null (x) `(if ,x nil t))

;;; Source transform for Endp  --  Internal
;;;
;;;    Endp is just NULL with a List assertion.
;;;
(def-source-transform endp (x) `(null (the list ,x)))

;;; We turn Identity into Prog1 so that it is obvious that it just returns the
;;; first value of its argument.  Ditto for Values with one arg.
(def-source-transform identity (x) `(prog1 ,x))
(def-source-transform values (x) `(prog1 ,x))

;;; CONSTANTLY source transform  --  Internal
;;;
;;;    Bind the values and make a closure that returns them.
;;;
(def-source-transform constantly (value &rest values)
  (let ((temps (loop repeat (1+ (length values))
		     collect (gensym)))
	(dum (gensym)))
    `(let ,(loop for temp in temps and
	         value in (list* value values)
	         collect `(,temp ,value))
       #'(lambda (&rest ,dum)
	   (declare (ignore ,dum))
	   (values ,@temps)))))


;;; COMPLEMENT IR1 transform  --  Internal
;;;
;;;    If the function has a known number of arguments, then return a lambda
;;; with the appropriate fixed number of args.  If the destination is a
;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure
;;; things out.
;;;
(deftransform complement ((fun) * * :node node :when :both)
  "open code"
  (multiple-value-bind (min max)
		       (function-type-nargs (continuation-type fun))
    (cond
     ((and min (eql min max))
      (let ((dums (loop repeat min collect (gensym))))
	`#'(lambda ,dums (not (funcall fun ,@dums)))))
     ((let* ((cont (node-cont node))
	     (dest (continuation-dest cont)))
	(and (combination-p dest)
	     (eq (combination-fun dest) cont)))
      '#'(lambda (&rest args)
	   (not (apply fun args))))
     (t
      (give-up "Function doesn't have fixed argument count.")))))
wlott's avatar
wlott committed

;;;; List hackery:

;;;
;;; Translate CxxR into car/cdr combos.

(defun source-transform-cxr (form)
  (if (or (byte-compiling) (/= (length form) 2))
      (values nil t)
      (let ((name (symbol-name (car form))))
	(do ((i (- (length name) 2) (1- i))
	     (res (cadr form)
		  `(,(ecase (char name i)
		       (#\A 'car)
		       (#\D 'cdr))
		    ,res)))
	    ((zerop i) res)))))

(do ((i 2 (1+ i))
     (b '(1 0) (cons i b)))
    ((= i 5))
  (dotimes (j (ash 1 i))
    (setf (info function source-transform
		(intern (format nil "C~{~:[A~;D~]~}R"
				(mapcar #'(lambda (x) (logbitp x j)) b))))
	  #'source-transform-cxr)))
wlott's avatar
wlott committed

;;;
;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is
;;; right for them is right for us.  Fifth..Tenth turn into Nth, which can be
;;; expanded into a car/cdr later on if policy favors it.
(def-source-transform first (x) `(car ,x))
(def-source-transform rest (x) `(cdr ,x))
(def-source-transform second (x) `(cadr ,x))
(def-source-transform third (x) `(caddr ,x))
(def-source-transform fourth (x) `(cadddr ,x))
(def-source-transform fifth (x) `(nth 4 ,x))
(def-source-transform sixth (x) `(nth 5 ,x))
(def-source-transform seventh (x) `(nth 6 ,x))
(def-source-transform eighth (x) `(nth 7 ,x))
(def-source-transform ninth (x) `(nth 8 ,x))
(def-source-transform tenth (x) `(nth 9 ,x))


;;;
;;; Translate RPLACx to LET and SETF.
(def-source-transform rplaca (x y)
  (once-only ((n-x x))
    `(progn
       (setf (car ,n-x) ,y)
       ,n-x)))
;;;
(def-source-transform rplacd (x y)
  (once-only ((n-x x))
    `(progn
       (setf (cdr ,n-x) ,y)
       ,n-x)))


(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
  
(defvar *default-nthcdr-open-code-limit* 6)
(defvar *extreme-nthcdr-open-code-limit* 20)

(deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
  "convert NTHCDR to CAxxR"
wlott's avatar
wlott committed
  (unless (constant-continuation-p n) (give-up))
  (let ((n (continuation-value n)))
    (when (> n
	     (if (policy node (= speed 3) (= space 0))
		 *extreme-nthcdr-open-code-limit*
		 *default-nthcdr-open-code-limit*))
      (give-up))

    (labels ((frob (n)
	       (if (zerop n)
		   'l
		   `(cdr ,(frob (1- n))))))
      (frob n))))


;;;; ARITHMETIC and NUMEROLOGY.

(def-source-transform plusp (x) `(> ,x 0))
(def-source-transform minusp (x) `(< ,x 0))
(def-source-transform zerop (x) `(= ,x 0))

(def-source-transform 1+ (x) `(+ ,x 1))
(def-source-transform 1- (x) `(- ,x 1))

(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
(def-source-transform evenp (x) `(zerop (logand ,x 1)))

;;; Note that all the integer division functions are available for inline
;;; expansion.

(macrolet ((frob (fun)
	     `(def-source-transform ,fun (x &optional (y nil y-p))
		(declare (ignore y))
		(if y-p
		    (values nil t)
		    `(,',fun ,x 1)))))
  (frob truncate)
  (frob round)
  #+propagate-float-type
  (frob floor)
  #+propagate-float-type
  (frob ceiling))
wlott's avatar
wlott committed

(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
(def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
(def-source-transform logbitp (index integer)
  `(not (zerop (logand (ash 1 ,index) ,integer))))
(def-source-transform byte (size position) `(cons ,size ,position))
(def-source-transform byte-size (spec) `(car ,spec))
(def-source-transform byte-position (spec) `(cdr ,spec))
(def-source-transform ldb-test (bytespec integer)
  `(not (zerop (mask-field ,bytespec ,integer))))
wlott's avatar
wlott committed


;;; With the ratio and complex accessors, we pick off the "identity" case, and
;;; use a primitive to handle the cell access case.
;;;
(def-source-transform numerator (num)
  (once-only ((n-num `(the rational ,num)))
    `(if (ratiop ,n-num)
	 ,n-num)))
;;;
(def-source-transform denominator (num)
  (once-only ((n-num `(the rational ,num)))
    `(if (ratiop ,n-num)
	 1)))
;;;
(def-source-transform realpart (num)
  (once-only ((n-num num))
    `(if (complexp ,n-num)
	 ,n-num)))
;;;
(def-source-transform imagpart (num)
  (once-only ((n-num num))
    `(cond ((complexp ,n-num)
	   ((floatp ,n-num)
	    (float 0 ,n-num))
	   (t
	    0))))

;;;; Interval arithmetic for computing bounds
;;;; (toy@rtp.ericsson.se)
;;;;
;;;; This is a set of routines for operating on intervals.  It
;;;; implements a simple interval arithmetic package.  Although CMUCL
;;;; has an interval type in numeric-type, we choose to use our own
;;;; for two reasons:
;;;;
;;;;   1.  This package is simpler than numeric-type
;;;;
;;;;   2.  It makes debugging much easier because you can just strip
;;;;   out these routines and test them independently of CMUCL.  (A
;;;;   big win!)
;;;;
;;;; One disadvantage is a probable increase in consing because we
;;;; have to create these new interval structures even though
;;;; numeric-type has everything we want to know.  Reason 2 wins for
;;;; now.


#+propagate-float-type
(progn

(defun elfun-float-format (format)
  (if format
      (if (eq format 'double-float)
	  'double-float
	  'single-float)))

  
;;; The basic interval type.  It can handle open and closed intervals.
;;; A bound is open if it is a list containing a number, just like
;;; Lisp says.  NIL means unbounded.
(defstruct (interval
	     (:constructor %make-interval))
(defun make-interval (&key low high)
  (labels ((normalize-bound (val)
	     (cond ((and (floatp val)
			 (float-infinity-p val))
		    ;; Handle infinities
		    nil)
		   ((or (numberp val)
			(eq val nil))
		    ;; Handle any closed bounds
		    val)
		   ((listp val)
		    ;; We have an open bound.  Normalize the numeric
		    ;; bound.  If the normalized bound is still a number
		    ;; (not nil), keep the bound open.  Otherwise, the
		    ;; bound is really unbounded, so drop the openness.
		    (let ((new-val (normalize-bound (first val))))
		      (when new-val
			;; Bound exists, so keep it open still
			(list new-val))))
		   (t
		    (error "Unknown bound type in make-interval!")))))
    (%make-interval :low (normalize-bound low)
		    :high (normalize-bound high))))

(defmacro without-over/under-flow-traps (&body body)
  "Executes BODY with traps on overflow, underflow, and divide-by-zero
turned off"
  (let ((modes (gensym)))
    `(let ((,modes (ext:get-floating-point-modes)))
      (unwind-protect
	   (progn
	     (ext:set-floating-point-modes :traps '(:invalid))
	     ,@body)
	(apply #'ext:set-floating-point-modes ,modes)))))

(proclaim '(inline bound-value set-bound bound-func))

;;; Extract the numeric value of a bound.  Return NIL, if X is NIL.
(defun bound-value (x)
  (if (consp x) (car x) x))

;;; Given a number X, create a form suitable as a bound for an
;;; interval.  Make the bound open if OPEN-P is T.  NIL remains NIL.
(defun set-bound (x open-p)
  (if (and x open-p) (list x) x))

;;; Apply the function F to a bound X.  If X is an open bound, then
;;; the result will be open.  IF X is NIL, the result is NIL.
(defun bound-func (f x)
  (and x
       (without-over/under-flow-traps
        (set-bound (funcall f (bound-value x)) (consp x)))))

;;; Apply a binary operator OP to two bounds X and Y.  The result is
;;; NIL if either is NIL.  Otherwise bound is computed and the result
;;; is open if either X or Y is open.
(defmacro bound-binop (op x y)
  `(and ,x ,y
        (without-over/under-flow-traps
	 (set-bound (,op (bound-value ,x)
			 (bound-value ,y))
	            (or (consp ,x) (consp ,y))))))

;;; NUMERIC-TYPE->INTERVAL
;;;
;;; Convert a numeric-type object to an interval object.

(defun numeric-type->interval (x)
  (declare (type numeric-type x))
  (make-interval :low (numeric-type-low x)
		 :high (numeric-type-high x)))

(defun copy-interval-limit (limit)
  (if (numberp limit)
      limit
      (copy-list limit)))

(defun copy-interval (x)
  (declare (type interval x))
  (make-interval :low (copy-interval-limit (interval-low x))
		 :high (copy-interval-limit (interval-high x))))

;;; INTERVAL-SPLIT
;;;
;;; Given a point P contained in the interval X, split X into two
;;; interval at the point P.  If JOIN-LOWER it T, then the left
;;; interval contains P.  Otherwise, the right interval contains P.
;;; You can specify both to be T.

(defun interval-split (p x &optional close-lower close-upper)
  (declare (type number p)
	   (type interval x))
  (list (make-interval :low (copy-interval-limit (interval-low x))
		       :high (if close-lower p (list p)))
	(make-interval :low (if close-upper (list p) p)
		       :high (copy-interval-limit (interval-high x)))))

(defun interval-closure (x)
  (declare (type interval x))
  (make-interval :low (bound-value (interval-low x))
		 :high (bound-value (interval-high x))))

;;; INTERVAL-RANGE-INFO
;;;
;;; For an interval X, if X >= 0, return '+.  If X <= 0, return
;;; '-. Otherwise return NIL.

(defun interval-range-info (x)
  (declare (type interval x))
  (let ((lo (interval-low x))
	(hi (interval-high x)))
  (cond ((and lo (>= (bound-value lo) 0))
	 '+)
	((and hi (<= (bound-value hi) 0))
	 '-)
	(t
	 nil))))

;;; INTERVAL-BOUNDED-P
;;;
;;; Test to see if the interval X is bounded.  HOW determines the
;;; test, and should be either ABOVE, BELOW, or BOTH.

(defun interval-bounded-p (x how)
  (declare (type interval x))
  (ecase how
    ('above
     (interval-high x))
    ('below
     (interval-low x))
    ('both
     (and (interval-low x) (interval-high x)))))

;;; INTERVAL-CONTAINS-P
;;;
;;; See if the interval X contains the number P, taking into account
;;; that the interval might not be closed.

(defun interval-contains-p (p x)
  (declare (type number p)
	   (type interval x))
  ;; Does the interval X contain the number P?  This would be a lot
  ;; easier if all intervals were closed!
  (let ((lo (interval-low x))
	(hi (interval-high x)))
    (cond ((and lo hi)
	   ;; The interval is bounded
	   (if (<= (bound-value lo) p (bound-value hi))
	       ;; P is definitely in the closure of the interval.
	       ;; We just need to check the end points now.
	       (cond ((= p (bound-value lo))
		      (numberp lo))
		     ((= p (bound-value hi))
		      (numberp hi))
		     (t t))
	       nil))
	  (hi
	   ;; Interval with upper bound
	   (if (< p (bound-value hi))
	       t
	       (and (numberp hi) (= p hi))))
	  (lo
	   ;; Interval with lower bound
	   (if (> p (bound-value lo))
	       t
	       (and (numberp lo) (= p lo))))
	  (t
	   ;; Interval with no bounds
	   t))))

;;; INTERVAL-INTERSECT-P
;;;
;;; Determine if two intervals X and Y intersect.  Return T if so.  If
;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were
;;; closed.  Otherwise the intervals are treated as they are.
;;;
;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
;;; because no element in X is in Y.  However, if CLOSED-INTERVALS-P
;;; is T, then they do intersect because we use the closure of X = [0,
;;; 1] and Y = [1, 2] to determine intersection.

(defun interval-intersect-p (x y &optional closed-intervals-p)
  (declare (type interval x y))
  (let ((x-lo (interval-low x))
	(x-hi (interval-high x))
	(y-lo (interval-low y))
	(y-hi (interval-high y)))
    (labels ((test-number (p int)
	       ;; Test if P is in the interval.
	       (when (interval-contains-p (bound-value p)
					  (interval-closure int))
		 (let ((lo (interval-low int))
		       (hi (interval-high int)))
		   ;; Check for endpoints
		   (cond ((or (null lo) (null hi))
			  t)
			 ((= (bound-value p) (bound-value lo))
			  (or closed-intervals-p
			      (not (and (consp p) (numberp lo)))))
			 ((= (bound-value p) (bound-value hi))
			  (or closed-intervals-p
			      (not (and (numberp p) (consp hi)))))
			 (t t)))))
	     (test-lower-bound (p int)
	       ;; P is a lower bound of an interval.
	       (if p
		   (test-number p int)
		   (not (interval-bounded-p int 'below))))
	     (test-upper-bound (p int)
	       ;; P is an upper bound of an interval
	       (if p
		   (test-number p int)
		   (not (interval-bounded-p int 'above))))
	     )
      (or (test-lower-bound x-lo y)
	  (test-upper-bound x-hi y)
	  (test-lower-bound y-lo x)
	  (test-upper-bound y-hi x)))))

;;; Are the two intervals adjacent?  That is, is there a number
;;; between the two intervals that is not an element of either
;;; interval?  If so, they are not adjacent.  For example [0, 1) and
;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
;;; between both intervals.
(defun interval-adjacent-p (x y)
  (declare (type interval x y))
  (flet ((adjacent (lo hi)
	   ;; Check to see if lo and hi are adjacent.  If either is
	   ;; nil, they can't be adjacent.
	   (when (and lo hi (= (bound-value lo) (bound-value hi)))
	     ;; The bounds are equal.  They are adjacent if one of
	     ;; them is closed (a number).  If both are open (consp),
	     ;; then there is a number that lies between them.
	     (or (numberp lo) (numberp hi)))))
    (or (adjacent (interval-low y) (interval-high x))
	(adjacent (interval-low x) (interval-high y)))))

;;; INTERVAL-MERGE-PAIR
;;;
;;; If intervals X and Y intersect, return a new interval that is the
;;; union of the two.  If they do not intersect, return NIL.

(defun interval-merge-pair (x y)
  (declare (type interval x y))
  ;; If x and y intersect or are adjacent, create the union.
  ;; Otherwise return nil
  (when (or (interval-intersect-p x y)
	     (interval-adjacent-p x y))
    (flet ((select-bound (x1 x2 min-op max-op)
	     (let ((x1-val (bound-value x1))
		   (x2-val (bound-value x2)))
	       (cond ((and x1 x2)
		      ;; Both bounds are finite.  Select the right one.
		      (cond ((funcall min-op x1-val x2-val)
			     ;; x1 definitely better
			     x1)
			    ((funcall max-op x1-val x2-val)
			     ;; x2 definitely better
			     x2)
			    (t
			     ;; Bounds are equal.  Select either
			     ;; value and make it open only if
			     ;; both were open.
			     (set-bound x1-val (and (consp x1) (consp x2))))))
		     (t
		      ;; At least one bound is not finite.  The
		      ;; non-finite bound always wins.
		      nil)))))
      (let* ((x-lo (copy-interval-limit (interval-low x)))
	     (x-hi (copy-interval-limit (interval-high x)))
	     (y-lo (copy-interval-limit (interval-low y)))
	     (y-hi (copy-interval-limit (interval-high y))))
	(make-interval :low (select-bound x-lo y-lo #'< #'>)
		       :high (select-bound x-hi y-hi #'> #'<))))))

;;; Basic arithmetic operations on intervals

;;; INTERVAL-NEG
;;;
;;; The negative of an interval

(defun interval-neg (x)
  (declare (type interval x))
  (make-interval :low (bound-func #'- (interval-high x))
		 :high (bound-func #'- (interval-low x))))
		       
;;; INTERVAL-ADD
;;;
;;; Add two intervals

(defun interval-add (x y)
  (declare (type interval x y))
  (make-interval :low (bound-binop + (interval-low x) (interval-low y))
		 :high (bound-binop + (interval-high x) (interval-high y))))

;;; INTERVAL-SUB
;;;
;;; Subtract two intervals

(defun interval-sub (x y)
  (declare (type interval x y))
  (make-interval :low (bound-binop - (interval-low x) (interval-high y))
		 :high (bound-binop - (interval-high x) (interval-low y))))

;;; INTERVAL-MUL
;;;
;;; Multiply two intervals
(defun interval-mul (x y)
  (declare (type interval x y))
  (flet ((bound-mul (x y)
	   (cond ((or (null x) (null y))
		  ;; Multiply by infinity is infinity
		  nil)
		 ((or (and (numberp x) (zerop x))
		      (and (numberp y) (zerop y)))
		  ;; Multiply by closed zero is special.  The result is
		  ;; always a closed bound
		  0)
		 ((or (and (floatp x) (float-infinity-p x))
		      (and (floatp y) (float-infinity-p y)))
		  ;; Infinity times anything is infinity
		  nil)
		 (t
		  ;; General multiply.  The result is open if either is open.
		  (bound-binop * x y)))))
    (let ((x-range (interval-range-info x))
	  (y-range (interval-range-info y)))
      (cond ((null x-range)
	     ;; Split x into two and multiply each separately
	     (destructuring-bind (x- x+)
		 (interval-split 0 x t t)
	       (interval-merge-pair (interval-mul x- y)
				    (interval-mul x+ y))))
	    ((null y-range)
	     ;; Split y into two and multiply each separately
	     (destructuring-bind (y- y+)
		 (interval-split 0 y t t)
	       (interval-merge-pair (interval-mul x y-)
				    (interval-mul x y+))))
	    ((eq x-range '-)
	     (interval-neg (interval-mul (interval-neg x) y)))
	    ((eq y-range '-)
	     (interval-neg (interval-mul x (interval-neg y))))
	    ((and (eq x-range '+) (eq y-range '+))
	     ;; If we are here, X and Y are both positive
	     (make-interval :low (bound-mul (interval-low x) (interval-low y))
			    :high (bound-mul (interval-high x) (interval-high y))))
	    (t
	     (error "This shouldn't happen!"))))))

;;; INTERVAL-DIV
;;;
;;; Divide two intervals.


(defun interval-div (top bot)
  (declare (type interval top bot))
  (flet ((bound-div (x y)
	 ;; Compute x/y
	 (cond ((null y)
		;; Divide by infinity means result is 0
		0)
	       ((zerop (bound-value y))
		;; Divide by zero means result is infinity
		nil)
	       ((and (numberp x) (zerop x))
		;; Zero divided by anything is zero.
		x)
	       (t
		(bound-binop / x y)))))
	       
    (let ((top-range (interval-range-info top))
	  (bot-range (interval-range-info bot)))
      (cond ((null bot-range)
	     ;; The denominator contains zero, so anything goes!
	     (make-interval :low nil :high nil))
	    ((eq bot-range '-)
	     ;; Denominator is negative so flip the sign, compute the
	     ;; result, and flip it back.
	     (interval-neg (interval-div top (interval-neg bot))))
	    ((null top-range)
	     ;; Split top into two positive and negative parts, and
	     ;; divide each separately
	     (destructuring-bind (top- top+)
		 (interval-split 0 top t t)
	       (interval-merge-pair (interval-div top- bot)
				    (interval-div top+ bot))))
	    ((eq top-range '-)
	     ;; Top is negative so flip the sign, divide, and flip the
	     ;; sign of the result.
	     (interval-neg (interval-div (interval-neg top) bot)))
	    ((and (eq top-range '+) (eq bot-range '+))
	     ;; The easy case
	     (make-interval :low (bound-div (interval-low top) (interval-high bot))
			    :high (bound-div (interval-high top) (interval-low bot))))
	    
	    (t
	     (error "This shouldn't happen!"))))))


;;; INTERVAL-FUNC
;;;
;;; Apply the function F to the interval X.  If X = [a, b], then the
;;; result is [f(a), f(b)].  It is up to the user to make sure the
;;; result makes sense.  It will if F is monotonic increasing (or
;;; non-decreasing).

(defun interval-func (f x)
  (declare (type interval x))
  (let ((lo (bound-func f (interval-low x)))
	(hi (bound-func f (interval-high x))))
    (make-interval :low lo :high hi)))

;;; INTERVAL-<
;;;
;;; Return T if X < Y.  That is every number in the interval X is
;;; always less than any number in the interval Y.

(defun interval-< (x y)
  (declare (type interval x y))
  ;; X < Y only if X is bounded above, Y is bounded below, and they
  ;; don't overlap.
  (when (and (interval-bounded-p x 'above)
	     (interval-bounded-p y 'below))
    ;; Intervals are bounded in the appropriate way.  Make sure that don't overlap.
    (let ((left (interval-high x))
	  (right (interval-low y))) 
      (cond ((> (bound-value left)
		(bound-value right))
	     ;; Definitely overlap so result is NIL
	     nil)
	    ((< (bound-value left)
		(bound-value right))
	     ;; Definitely don't touch, so result is T
	     t)
	    (t
	     ;; Limits are equal.  Check for open or closed bounds.
	     ;; Don't overlap if one or the other are open.
	     (or (consp left) (consp right)))))))

;;; INTERVAL-ABS
;;;
;;; Return an interval that is the absolute value of X.  Thus, if X =
;;; [-1 10], the result is [0, 10].

(defun interval-abs (x)
  (declare (type interval x))
  (case (interval-range-info x)
    ('+
    ('-
     (interval-neg x))
    (t
     (destructuring-bind (x- x+)
	 (interval-split 0 x t t)
       (interval-merge-pair (interval-neg x-) x+)))))

;;; INTERVAL-SQR
;;;
;;; Compute the square of an interval.

(defun interval-sqr (x)
  (declare (type interval x))
  (interval-func #'(lambda (x) (* x x))
		 (interval-abs x)))
) ; end progn


wlott's avatar
wlott committed

;;;; Numeric Derive-Type methods:

;;; Derive-Integer-Type  --  Internal
;;;
;;;    Utility for defining derive-type methods of integer operations.  If the
;;; types of both X and Y are integer types, then we compute a new integer type
;;; with bounds determined Fun when applied to X and Y.  Otherwise, we use
;;; Numeric-Contagion.
;;;
(defun derive-integer-type (x y fun)
  (declare (type continuation x y) (type function fun))
  (let ((x (continuation-type x))
	(y (continuation-type y)))
    (if (and (numeric-type-p x) (numeric-type-p y)
	     (eq (numeric-type-class x) 'integer)
	     (eq (numeric-type-class y) 'integer)
	     (eq (numeric-type-complexp x) :real)
	     (eq (numeric-type-complexp y) :real))
	(multiple-value-bind (low high)
			     (funcall fun x y)
	  (make-numeric-type :class 'integer  :complexp :real
			     :low low  :high high))
	(numeric-contagion x y))))

ram's avatar
ram committed
;;; Derive-Real-Type  --  Internal
;;;
;;; Same as derive-integer-type except it can handle float types.
;;; This also contains derive-integer-type as a special case.
;;;
#+propagate-float-type
(progn
;;; Some functions only take one argument but derive-real-type assumes
;;; two.  For those cases of one argument functions, set IGNORE-Y to T
;;; because we don't want derive-real-type to process the second
;;; argument because it's meaningless.
  
ram's avatar
ram committed
(defun derive-real-type (x y fun)
  (declare (type continuation x y) (type function fun))
  (let ((x (continuation-type x))
	(y (continuation-type y)))
    (derive-real-numeric-or-union-type x y fun)))

;;; Some notes: This routine can handle X and Y if they are
;;; numeric-types or unions of numeric types.  If this is not true,
;;; general numeric contagion holds.  In particular if X is a member
;;; type, we could conceivably compute the right thing by looking
;;; inside the elements of the member type.  We don't do this yet.
;;; Perhaps it would be better to let the user say so.  Instead of
;;; saying (member 1 2 4), you should say (or (integer 1 1) (integer 2
;;; 2) (integer 4 4)).

ram's avatar
ram committed
(defun derive-real-numeric-or-union-type (x y fun)
  (labels ((combine (lx ly)
	     ;; Creates a new list containing all possible pairs from LX and LY.
	     (let ((result '()))
	       (dolist (ix lx)
		 (dolist (iy ly)
		   (push (list ix iy) result)))
	       (nreverse result)))
	   (listify (object)
	     ;; If object is a union type, get the list of the types.
	     ;; Otherwise make a list containing the single object.
	     (typecase object
	       (union-type
		(union-type-types object))
	       (t
		(list object)))))
	(let ((all (combine (listify x)
			    (listify y)))
	      (result '()))
	  (dolist (item all)
	    (destructuring-bind (ix iy)
		item
	      (push (derive-simple-real-type ix iy fun) result)))
	  (setf result (derive-merged-union-types result))
	  (if (cdr result)
	      (make-union-type result)
	      (first result)))))
ram's avatar
ram committed

(defun merge-types-aux (tlist)
  ;; Merge the first interval in the list with the rest of
  ;; intervals in the list.  The list of intervals MUST be
  ;; sorted in ascending order of lower limits.
  (let* ((cur (first tlist))
	 (cur-intvrl (numeric-type->interval cur))
ram's avatar
ram committed
	 (res (list cur)))
    (dolist (this-interval (rest tlist) res)
      (let ((this (numeric-type->interval this-interval)))
	;; If interval intersects cur or if they are adjacent, we can
	;; merge them together, but only if they are the same type of
	;; number.  If they are different, we can't merge them.
	(cond ((and (eq (numeric-type-class cur) 
			(numeric-type-class this-interval))
		    (or (interval-intersect-p cur-intvrl this)
			(interval-adjacent-p cur-intvrl this)))
	       (let ((result (interval-merge-pair cur-intvrl this)))
		 (when result
		   (setf (numeric-type-high cur)
			 (interval-high result)))))
	      (t
	       (setf res (cons this-interval res))))))))
ram's avatar
ram committed

(defun merge-types (ilist &optional (result '()))
  ;; Compare the first element with the rest to merge
  ;; whatever we can into the first element.  The first
  ;; element is totally merged, so we only need to consider
  ;; whatever is left.
  (cond ((null ilist)
	 result)
	((cdr ilist)
	 (let ((new-types (merge-types-aux ilist)))
	   (merge-types (rest new-types) (cons (first new-types) result))))
	(t
	 (cons (first ilist) result))))

(defun derive-merged-union-types (types)
  (labels ((num-interval-< (a b)
	     (when (and (numeric-type-p a)
			(numeric-type-p b))
	       (let ((a-lo (numeric-type-low a))
		     (b-lo (numeric-type-low b)))
		 (cond ((null a-lo)
			;; A has lower bound of -infinity, so it's
			;; lower than B, no matter what B is.
			t)
		       ((null b-lo)
			;; At this point A has a numeric lower bound,
			;; but B has -infinity, so A is not lower than
			;; B.
			nil)
		       (t
			;; Both A and B have numeric lower bounds.  Make the right decision
			(let ((av (bound-value a-lo))
			      (bv (bound-value b-lo)))
			  (cond ((< av bv)
				 ;; Obviously
				 t)
				((= av bv)
				 ;; Bounds are equal.  A is lower unless A is open and B is closed.
				 (or (numberp a-lo) (consp b-lo)))
				(t
				 nil)))))))))
    (merge-types (stable-sort types #'num-interval-<))))
ram's avatar
ram committed

(defun derive-simple-real-type (x y fun)
  (declare (type function fun))
  ;; We handle the case of real operands.  For the other cases, we use
  ;; general numeric contagion.
  (if (and (numeric-type-p x) (numeric-type-p y)
	   (eq (numeric-type-complexp x) :real)
	   (eq (numeric-type-complexp y) :real))
      (multiple-value-bind (low high type format)
	  (funcall fun x y)
	(make-numeric-type :class type
			   :complexp :real
			   :format format
			   :low low
			   :high high))
      (numeric-contagion x y)))
) ; end progn
ram's avatar
ram committed


#-propagate-float-type
wlott's avatar
wlott committed
(defoptimizer (+ derive-type) ((x y))
  (derive-integer-type
   x y
   #'(lambda (x y)
       (flet ((frob (x y)
		(if (and x y)
		    (+ x y)
		    nil)))
	 (values (frob (numeric-type-low x) (numeric-type-low y))
		 (frob (numeric-type-high x) (numeric-type-high y)))))))

(defoptimizer (- derive-type) ((x y))
  (derive-integer-type
   x y
   #'(lambda (x y)
       (flet ((frob (x y)
		(if (and x y)
		    (- x y)
		    nil)))
	 (values (frob (numeric-type-low x) (numeric-type-high y))
		 (frob (numeric-type-high x) (numeric-type-low y)))))))

ram's avatar
ram committed

wlott's avatar
wlott committed
(defoptimizer (* derive-type) ((x y))
  (derive-integer-type
   x y
   #'(lambda (x y)
       (let ((x-low (numeric-type-low x))
	     (x-high (numeric-type-high x))
	     (y-low (numeric-type-low y))
	     (y-high (numeric-type-high y)))
	 (cond ((not (and x-low y-low))
		(values nil nil))
	       ((or (minusp x-low) (minusp y-low))
		(if (and x-high y-high)
		    (let ((max (* (max (abs x-low) (abs x-high))
				  (max (abs y-low) (abs y-high)))))
		      (values (- max) max))
		    (values nil nil)))
	       (t
		(values (* x-low y-low)
			(if (and x-high y-high)
			    (* x-high y-high)
			    nil))))))))

(defoptimizer (/ derive-type) ((x y))
  (numeric-contagion (continuation-type x) (continuation-type y)))

) ; end progn

ram's avatar
ram committed
#+propagate-float-type
(progn
(defoptimizer (+ derive-type) ((x y))
  (derive-real-type
   x y
   #'(lambda (x y)
       (declare (type numeric-type x y))
       (let ((result (interval-add (numeric-type->interval x)
				   (numeric-type->interval y)))
	     (result-type (numeric-contagion x y)))
	 ;; If the result type is a float, we need to be sure to
	 ;; coerce the bounds into the correct type.
	 (when (eq (numeric-type-class result-type) 'float)
	   (setf result (interval-func
			 #'(lambda (x)
			     (coerce x (or (numeric-type-format result-type)
					   'float)))
			 result)))
	 (values (interval-low result)
		 (interval-high result)
		 (if (and (eq (numeric-type-class x) 'integer)
			  (eq (numeric-type-class y) 'integer))
		     ;; The sum of integers is always an integer
		     'integer
		     (numeric-type-class result-type))
		 (numeric-type-format result-type))))))

(defoptimizer (- derive-type) ((x y))
  (derive-real-type
   x y
   #'(lambda (x y)
       (declare (type numeric-type x y))
       (let ((result (interval-sub (numeric-type->interval x)
				   (numeric-type->interval y)))
	     (result-type (numeric-contagion x y)))
	 ;; If the result type is a float, we need to be sure to
	 ;; coerce the bounds into the correct type.
	 (when (eq (numeric-type-class result-type) 'float)
	   (setf result (interval-func
			 #'(lambda (x)
			     (coerce x (or (numeric-type-format result-type)
					   'float)))
			 result)))