X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b858d5bc791a679e4698bca7370e5561018518b2;hb=0a82f2db352cc348d2107a882e50af222ff97ed3;hp=ee67ba7a529596cd1e28fbf59f31ec47b3176e24;hpb=0aafa73007d42f2bc8e626f98a243019b7e63284;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ee67ba7..b858d5b 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -43,7 +43,7 @@ (deftransform complement ((fun) * * :node node :when :both) "open code" (multiple-value-bind (min max) - (function-type-nargs (continuation-type fun)) + (fun-type-nargs (continuation-type fun)) (cond ((and min (eql min max)) (let ((dums (make-gensym-list min))) @@ -60,10 +60,9 @@ ;;;; list hackery -;;; Translate CxxR into CAR/CDR combos. - +;;; Translate CxR into CAR/CDR combos. (defun source-transform-cxr (form) - (if (or (byte-compiling) (/= (length form) 2)) + (if (/= (length form) 2) (values nil t) (let ((name (symbol-name (car form)))) (do ((i (- (length name) 2) (1- i)) @@ -74,14 +73,25 @@ ,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))) +;;; Make source transforms to turn CxR forms into combinations of CAR +;;; and CDR. ANSI specifies that everything up to 4 A/D operations is +;;; defined. +(/show0 "about to set CxR source transforms") +(loop for i of-type index from 2 upto 4 do + ;; Iterate over BUF = all names CxR where x = an I-element + ;; string of #\A or #\D characters. + (let ((buf (make-string (+ 2 i)))) + (setf (aref buf 0) #\C + (aref buf (1+ i)) #\R) + (dotimes (j (ash 2 i)) + (declare (type index j)) + (dotimes (k i) + (declare (type index k)) + (setf (aref buf (1+ k)) + (if (logbitp k j) #\A #\D))) + (setf (info :function :source-transform (intern buf)) + #'source-transform-cxr)))) +(/show0 "done setting CxR source transforms") ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming ;;; whatever is right for them is right for us. FIFTH..TENTH turn into @@ -148,19 +158,18 @@ ;;; Note that all the integer division functions are available for ;;; inline expansion. -;;; FIXME: DEF-FROB instead of FROB -(macrolet ((frob (fun) +(macrolet ((deffrob (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)) + (deffrob truncate) + (deffrob round) + #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + (deffrob floor) + #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + (deffrob ceiling)) (def-source-transform lognand (x y) `(lognot (logand ,x ,y))) (def-source-transform lognor (x y) `(lognot (logior ,x ,y))) @@ -190,18 +199,17 @@ (%denominator ,n-num) 1))) -;;;; Interval arithmetic for computing bounds -;;;; (toy@rtp.ericsson.se) +;;;; interval arithmetic for computing bounds ;;;; ;;;; This is a set of routines for operating on intervals. It ;;;; implements a simple interval arithmetic package. Although SBCL -;;;; has an interval type in numeric-type, we choose to use our own +;;;; has an interval type in NUMERIC-TYPE, we choose to use our own ;;;; for two reasons: ;;;; -;;;; 1. This package is simpler than numeric-type +;;;; 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 SBCL. (a +;;;; out these routines and test them independently of SBCL. (This is a ;;;; big win!) ;;;; ;;;; One disadvantage is a probable increase in consing because we @@ -209,11 +217,6 @@ ;;;; numeric-type has everything we want to know. Reason 2 wins for ;;;; now. -#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr) -(progn -#!+propagate-float-type -(progn - ;;; 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. @@ -225,11 +228,11 @@ (labels ((normalize-bound (val) (cond ((and (floatp val) (float-infinity-p val)) - ;; Handle infinities + ;; Handle infinities. nil) ((or (numberp val) (eq val nil)) - ;; Handle any closed bounds + ;; Handle any closed bounds. val) ((listp val) ;; We have an open bound. Normalize the numeric @@ -238,21 +241,16 @@ ;; 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 + ;; The bound exists, so keep it open still. (list new-val)))) (t - (error "Unknown bound type in make-interval!"))))) + (error "unknown bound type in MAKE-INTERVAL"))))) (%make-interval :low (normalize-bound low) :high (normalize-bound high)))) -#!-sb-fluid (declaim (inline bound-value set-bound)) - -;;; 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. +#!-sb-fluid (declaim (inline set-bound)) (defun set-bound (x open-p) (if (and x open-p) (list x) x)) @@ -264,11 +262,11 @@ ;; With these traps masked, we might get things like infinity ;; or negative infinity returned. Check for this and return ;; NIL to indicate unbounded. - (let ((y (funcall f (bound-value x)))) + (let ((y (funcall f (type-bound-number x)))) (if (and (floatp y) (float-infinity-p y)) nil - (set-bound (funcall f (bound-value x)) (consp x))))))) + (set-bound (funcall f (type-bound-number 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 @@ -278,14 +276,11 @@ (defmacro bound-binop (op x y) `(and ,x ,y (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - (set-bound (,op (bound-value ,x) - (bound-value ,y)) + (set-bound (,op (type-bound-number ,x) + (type-bound-number ,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) @@ -301,8 +296,6 @@ (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 CLOSE-LOWER is T, then the left ;;; interval contains P. If CLOSE-UPPER is T, the right interval @@ -315,14 +308,12 @@ (make-interval :low (if close-upper (list p) p) :high (copy-interval-limit (interval-high x))))) -;;; INTERVAL-CLOSURE -;;; ;;; Return the closure of the interval. That is, convert open bounds ;;; to closed bounds. (defun interval-closure (x) (declare (type interval x)) - (make-interval :low (bound-value (interval-low x)) - :high (bound-value (interval-high x)))) + (make-interval :low (type-bound-number (interval-low x)) + :high (type-bound-number (interval-high x)))) (defun signed-zero->= (x y) (declare (real x y)) @@ -331,8 +322,6 @@ (>= (float-sign (float x)) (float-sign (float y)))))) -;;; INTERVAL-RANGE-INFO -;;; ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return ;;; '-. Otherwise return NIL. #+nil @@ -340,9 +329,9 @@ (declare (type interval x)) (let ((lo (interval-low x)) (hi (interval-high x))) - (cond ((and lo (signed-zero->= (bound-value lo) point)) + (cond ((and lo (signed-zero->= (type-bound-number lo) point)) '+) - ((and hi (signed-zero->= point (bound-value hi))) + ((and hi (signed-zero->= point (type-bound-number hi))) '-) (t nil)))) @@ -354,15 +343,13 @@ (>= x y)))) (let ((lo (interval-low x)) (hi (interval-high x))) - (cond ((and lo (signed->= (bound-value lo) point)) + (cond ((and lo (signed->= (type-bound-number lo) point)) '+) - ((and hi (signed->= point (bound-value hi))) + ((and hi (signed->= point (type-bound-number hi))) '-) (t nil))))) -;;; INTERVAL-BOUNDED-P -;;; ;;; Test to see whether the interval X is bounded. HOW determines the ;;; test, and should be either ABOVE, BELOW, or BOTH. (defun interval-bounded-p (x how) @@ -375,9 +362,8 @@ ('both (and (interval-low x) (interval-high x))))) -;;; Signed zero comparison functions. Use these functions if we need +;;; signed zero comparison functions. Use these functions if we need ;;; to distinguish between signed zeroes. - (defun signed-zero-< (x y) (declare (real x y)) (or (< x y) @@ -390,13 +376,11 @@ (and (= x y) (> (float-sign (float x)) (float-sign (float y)))))) - (defun signed-zero-= (x y) (declare (real x y)) (and (= x y) (= (float-sign (float x)) (float-sign (float y))))) - (defun signed-zero-<= (x y) (declare (real x y)) (or (< x y) @@ -404,10 +388,8 @@ (<= (float-sign (float x)) (float-sign (float y)))))) -;;; INTERVAL-CONTAINS-P -;;; -;;; See whether the interval X contains the number P, taking into account -;;; that the interval might not be closed. +;;; See whether 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)) @@ -417,35 +399,33 @@ (hi (interval-high x))) (cond ((and lo hi) ;; The interval is bounded - (if (and (signed-zero-<= (bound-value lo) p) - (signed-zero-<= p (bound-value hi))) + (if (and (signed-zero-<= (type-bound-number lo) p) + (signed-zero-<= p (type-bound-number hi))) ;; P is definitely in the closure of the interval. ;; We just need to check the end points now. - (cond ((signed-zero-= p (bound-value lo)) + (cond ((signed-zero-= p (type-bound-number lo)) (numberp lo)) - ((signed-zero-= p (bound-value hi)) + ((signed-zero-= p (type-bound-number hi)) (numberp hi)) (t t)) nil)) (hi ;; Interval with upper bound - (if (signed-zero-< p (bound-value hi)) + (if (signed-zero-< p (type-bound-number hi)) t (and (numberp hi) (signed-zero-= p hi)))) (lo ;; Interval with lower bound - (if (signed-zero-> p (bound-value lo)) + (if (signed-zero-> p (type-bound-number lo)) t (and (numberp lo) (signed-zero-= 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. +;;; Determine whether 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 @@ -473,7 +453,7 @@ (flet ((adjacent (lo hi) ;; Check to see whether lo and hi are adjacent. If either is ;; nil, they can't be adjacent. - (when (and lo hi (= (bound-value lo) (bound-value hi))) + (when (and lo hi (= (type-bound-number lo) (type-bound-number 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. @@ -481,8 +461,6 @@ (or (adjacent (interval-low y) (interval-high x)) (adjacent (interval-low x) (interval-high y))))) -;;; INTERVAL-INTERSECTION/DIFFERENCE -;;; ;;; Compute the intersection and difference between two intervals. ;;; Two values are returned: the intersection and the difference. ;;; @@ -509,14 +487,14 @@ (list p))) (test-number (p int) ;; Test whether P is in the interval. - (when (interval-contains-p (bound-value p) + (when (interval-contains-p (type-bound-number p) (interval-closure int)) (let ((lo (interval-low int)) (hi (interval-high int))) - ;; Check for endpoints - (cond ((and lo (= (bound-value p) (bound-value lo))) + ;; Check for endpoints. + (cond ((and lo (= (type-bound-number p) (type-bound-number lo))) (not (and (consp p) (numberp lo)))) - ((and hi (= (bound-value p) (bound-value hi))) + ((and hi (= (type-bound-number p) (type-bound-number hi))) (not (and (numberp p) (consp hi)))) (t t))))) (test-lower-bound (p int) @@ -525,7 +503,7 @@ (test-number p int) (not (interval-bounded-p int 'below)))) (test-upper-bound (p int) - ;; P is an upper bound of an interval + ;; P is an upper bound of an interval. (if p (test-number p int) (not (interval-bounded-p int 'above))))) @@ -545,13 +523,13 @@ (y-hi-in-x (values y-hi (opposite-bound y-hi) x-hi))) (values (make-interval :low lo :high hi) - (list (make-interval :low left-lo :high left-hi) - (make-interval :low right-lo :high right-hi)))))) + (list (make-interval :low left-lo + :high left-hi) + (make-interval :low right-lo + :high right-hi)))))) (t (values nil (list x 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) @@ -561,15 +539,15 @@ (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))) + (let ((x1-val (type-bound-number x1)) + (x2-val (type-bound-number 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 is definitely better. x1) ((funcall max-op x1-val x2-val) - ;; x2 definitely better + ;; x2 is definitely better. x2) (t ;; Bounds are equal. Select either @@ -587,37 +565,29 @@ (make-interval :low (select-bound x-lo y-lo #'< #'>) :high (select-bound x-hi y-hi #'> #'<)))))) -;;; Basic arithmetic operations on intervals. We probably should do +;;; basic arithmetic operations on intervals. We probably should do ;;; true interval arithmetic here, but it's complicated because we ;;; have float and integer types and bounds can be open or closed. -;;; INTERVAL-NEG -;;; -;;; The negative of an interval +;;; 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 +;;; 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 +;;; 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 +;;; Multiply two intervals. (defun interval-mul (x y) (declare (type interval x y)) (flet ((bound-mul (x y) @@ -630,7 +600,7 @@ ;; is always a closed bound. But don't replace this ;; with zero; we want the multiplication to produce ;; the correct signed zero, if needed. - (* (bound-value x) (bound-value y))) + (* (type-bound-number x) (type-bound-number y))) ((or (and (floatp x) (float-infinity-p x)) (and (floatp y) (float-infinity-p y))) ;; Infinity times anything is infinity @@ -655,14 +625,13 @@ ((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)))) + ;; 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!")))))) + (error "internal error in INTERVAL-MUL")))))) -;;; INTERVAL-DIV -;;; ;;; Divide two intervals. (defun interval-div (top bot) (declare (type interval top bot)) @@ -673,12 +642,12 @@ ;; we need to watch out for the sign of the result, ;; to correctly handle signed zeros. We also need ;; to watch out for positive or negative infinity. - (if (floatp (bound-value x)) + (if (floatp (type-bound-number x)) (if y-low-p - (- (float-sign (bound-value x) 0.0)) - (float-sign (bound-value x) 0.0)) + (- (float-sign (type-bound-number x) 0.0)) + (float-sign (type-bound-number x) 0.0)) 0)) - ((zerop (bound-value y)) + ((zerop (type-bound-number y)) ;; Divide by zero means result is infinity nil) ((and (numberp x) (zerop x)) @@ -706,14 +675,13 @@ ;; 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) t) - :high (bound-div (interval-high top) (interval-low bot) nil))) + ;; the easy case + (make-interval + :low (bound-div (interval-low top) (interval-high bot) t) + :high (bound-div (interval-high top) (interval-low bot) nil))) (t - (error "This shouldn't happen!")))))) + (error "internal error in INTERVAL-DIV")))))) -;;; 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 @@ -724,8 +692,6 @@ (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) @@ -738,21 +704,19 @@ ;; 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 + (cond ((> (type-bound-number left) + (type-bound-number right)) + ;; The intervals definitely overlap, so result is NIL. nil) - ((< (bound-value left) - (bound-value right)) - ;; Definitely don't touch, so result is T + ((< (type-bound-number left) + (type-bound-number right)) + ;; The intervals 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))))))) -;;; INVTERVAL->= -;;; ;;; Return T if X >= Y. That is, every number in the interval X is ;;; always greater than any number in the interval Y. (defun interval->= (x y) @@ -760,12 +724,11 @@ ;; X >= Y if lower bound of X >= upper bound of Y (when (and (interval-bounded-p x 'below) (interval-bounded-p y 'above)) - (>= (bound-value (interval-low x)) (bound-value (interval-high y))))) + (>= (type-bound-number (interval-low x)) + (type-bound-number (interval-high y))))) -;;; INTERVAL-ABS -;;; -;;; Return an interval that is the absolute value of X. Thus, if X = -;;; [-1 10], the result is [0, 10]. +;;; 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) @@ -777,21 +740,18 @@ (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-func (lambda (x) (* x x)) (interval-abs x))) -)) ; end PROGN's -;;;; numeric derive-type methods +;;;; numeric DERIVE-TYPE methods -;;; 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. +;;; a 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)) @@ -808,10 +768,7 @@ :high high)) (numeric-contagion x y)))) -#!+(or propagate-float-type propagate-fun-type) -(progn - -;; Simple utility to flatten a list +;;; simple utility to flatten a list (defun flatten-list (x) (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'. (cond ((null x) r) @@ -852,7 +809,7 @@ new-args))))) ;;; Convert from the standard type convention for which -0.0 and 0.0 -;;; and equal to an intermediate convention for which they are +;;; are equal to an intermediate convention for which they are ;;; considered different which is more natural for some of the ;;; optimisers. #!-negative-zero-is-not-zero @@ -861,10 +818,10 @@ ;;; Only convert real float interval delimiters types. (if (eq (numeric-type-complexp type) :real) (let* ((lo (numeric-type-low type)) - (lo-val (bound-value lo)) + (lo-val (type-bound-number lo)) (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0))) (hi (numeric-type-high type)) - (hi-val (bound-value hi)) + (hi-val (type-bound-number hi)) (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0)))) (if (or lo-float-zero-p hi-float-zero-p) (make-numeric-type @@ -894,12 +851,12 @@ ;;; Only convert real float interval delimiters types. (if (eq (numeric-type-complexp type) :real) (let* ((lo (numeric-type-low type)) - (lo-val (bound-value lo)) + (lo-val (type-bound-number lo)) (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0) (float-sign lo-val))) (hi (numeric-type-high type)) - (hi-val (bound-value hi)) + (hi-val (type-bound-number hi)) (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0) (float-sign hi-val)))) @@ -907,8 +864,8 @@ ;; (float +0.0 +0.0) => (member 0.0) ;; (float -0.0 -0.0) => (member -0.0) ((and lo-float-zero-p hi-float-zero-p) - ;; Shouldn't have exclusive bounds here. - (assert (and (not (consp lo)) (not (consp hi)))) + ;; shouldn't have exclusive bounds here.. + (aver (and (not (consp lo)) (not (consp hi)))) (if (= lo-float-zero-p hi-float-zero-p) ;; (float +0.0 +0.0) => (member 0.0) ;; (float -0.0 -0.0) => (member -0.0) @@ -972,7 +929,7 @@ :high (list (float 0.0 hi-val))))))) (t type))) - ;; Not real float. + ;; not real float type)) ;;; Convert back a possible list of numeric types. @@ -996,11 +953,15 @@ (t type-list))) +;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably +;;; belong in the kernel's type logic, invoked always, instead of in +;;; the compiler, invoked only during some type optimizations. + ;;; Take a list of types and return a canonical type specifier, -;;; combining any MEMBER types together. If both positive and -;;; negative MEMBER types are present they are converted to a float -;;; type. XXX This would be far simpler if the type-union methods could -;;; handle member/number unions. +;;; combining any MEMBER types together. If both positive and negative +;;; MEMBER types are present they are converted to a float type. +;;; XXX This would be far simpler if the type-union methods could handle +;;; member/number unions. (defun make-canonical-union-type (type-list) (let ((members '()) (misc-types '())) @@ -1027,37 +988,21 @@ #!+negative-zero-is-not-zero (push (specifier-type '(single-float -0f0 0f0)) misc-types) (setf members (set-difference members '(-0f0 0f0)))) - (cond ((null members) - (let ((res (first misc-types))) - (dolist (type (rest misc-types)) - (setq res (type-union res type))) - res)) - ((null misc-types) - (make-member-type :members members)) - (t - (let ((res (first misc-types))) - (dolist (type (rest misc-types)) - (setq res (type-union res type))) - (dolist (type members) - (setq res (type-union - res (make-member-type :members (list type))))) - res))))) - -;;; Convert-Member-Type -;;; + (if members + (apply #'type-union (make-member-type :members members) misc-types) + (apply #'type-union misc-types)))) + ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) (let* ((members (member-type-members arg)) (member (first members)) (member-type (type-of member))) - (assert (not (rest members))) + (aver (not (rest members))) (specifier-type `(,(if (subtypep member-type 'integer) 'integer member-type) ,member ,member)))) -;;; ONE-ARG-DERIVE-TYPE -;;; ;;; This is used in defoptimizers for computing the resulting type of ;;; a function. ;;; @@ -1118,8 +1063,6 @@ (make-canonical-union-type results) (first results))))))) -;;; TWO-ARG-DERIVE-TYPE -;;; ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes ;;; two arguments. DERIVE-FCN takes 3 args in this case: the two ;;; original args and a third which is T to indicate if the two args @@ -1141,10 +1084,9 @@ (funcall fcn x y)))) (cond ((null result)) ((and (floatp result) (float-nan-p result)) - (make-numeric-type - :class 'float - :format (type-of result) - :complexp :real)) + (make-numeric-type :class 'float + :format (type-of result) + :complexp :real)) (t (make-member-type :members (list result)))))) ((and (member-type-p x) (numeric-type-p y)) @@ -1214,10 +1156,8 @@ (if (rest results) (make-canonical-union-type results) (first results))))))) - -) ; PROGN -#!-propagate-float-type +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defoptimizer (+ derive-type) ((x y)) (derive-integer-type @@ -1268,7 +1208,7 @@ ) ; PROGN -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defun +-derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) @@ -1291,13 +1231,13 @@ (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) (eq (numeric-type-class y) 'integer)) - ;; The sum of integers is always an integer + ;; The sum of integers is always an integer. 'integer (numeric-type-class result-type)) :format (numeric-type-format result-type) :low (interval-low result) :high (interval-high result))) - ;; General contagion + ;; general contagion (numeric-contagion x y))) (defoptimizer (+ derive-type) ((x y)) @@ -1307,7 +1247,7 @@ (if (and (numeric-type-real-p x) (numeric-type-real-p y)) (let ((result - ;; (- x x) is always 0. + ;; (- X X) is always 0. (if same-arg (make-interval :low 0 :high 0) (interval-sub (numeric-type->interval x) @@ -1324,13 +1264,13 @@ (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) (eq (numeric-type-class y) 'integer)) - ;; The difference of integers is always an integer + ;; The difference of integers is always an integer. 'integer (numeric-type-class result-type)) :format (numeric-type-format result-type) :low (interval-low result) :high (interval-high result))) - ;; General contagion + ;; general contagion (numeric-contagion x y))) (defoptimizer (- derive-type) ((x y)) @@ -1340,8 +1280,7 @@ (if (and (numeric-type-real-p x) (numeric-type-real-p y)) (let ((result - ;; (* x x) is always positive, so take care to do it - ;; right. + ;; (* X X) is always positive, so take care to do it right. (if same-arg (interval-sqr (numeric-type->interval x)) (interval-mul (numeric-type->interval x) @@ -1358,7 +1297,7 @@ (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) (eq (numeric-type-class y) 'integer)) - ;; The product of integers is always an integer + ;; The product of integers is always an integer. 'integer (numeric-type-class result-type)) :format (numeric-type-format result-type) @@ -1373,7 +1312,7 @@ (if (and (numeric-type-real-p x) (numeric-type-real-p y)) (let ((result - ;; (/ x x) is always 1, except if x can contain 0. In + ;; (/ X X) is always 1, except if X can contain 0. In ;; that case, we shouldn't optimize the division away ;; because we want 0/0 to signal an error. (if (and same-arg @@ -1403,93 +1342,13 @@ ) ; PROGN -;;; ASH derive type optimizer -;;; -;;; Large resulting bounds are easy to generate but are not -;;; particularly useful, so an open outer bound is returned for a -;;; shift greater than 64 - the largest word size of any of the ports. -;;; Large negative shifts are also problematic as the ASH -;;; implementation only accepts shifts greater than -;;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local -;;; functions: -;;; ASH-OUTER: Perform the shift when within an acceptable range, -;;; otherwise return an open bound. -;;; ASH-INNER: Perform the shift when within range, limited to a -;;; maximum of 64, otherwise returns the inner limit. -;;; ;;; KLUDGE: All this ASH optimization is suppressed under CMU CL ;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH ;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero) ;;; and it's hard to avoid that calculation in here. #-(and cmu sb-xc-host) (progn -#!-propagate-fun-type -(defoptimizer (ash derive-type) ((n shift)) - (flet ((ash-outer (n s) - (when (and (fixnump s) - (<= s 64) - (> s sb!vm:*target-most-negative-fixnum*)) - (ash n s))) - (ash-inner (n s) - (if (and (fixnump s) - (> s sb!vm:*target-most-negative-fixnum*)) - (ash n (min s 64)) - (if (minusp n) -1 0)))) - (or (let ((n-type (continuation-type n))) - (when (numeric-type-p n-type) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type))) - (if (constant-continuation-p shift) - (let ((shift (continuation-value shift))) - (make-numeric-type :class 'integer - :complexp :real - :low (when n-low (ash n-low shift)) - :high (when n-high (ash n-high shift)))) - (let ((s-type (continuation-type shift))) - (when (numeric-type-p s-type) - (let* ((s-low (numeric-type-low s-type)) - (s-high (numeric-type-high s-type)) - (low-slot (when n-low - (if (minusp n-low) - (ash-outer n-low s-high) - (ash-inner n-low s-low)))) - (high-slot (when n-high - (if (minusp n-high) - (ash-inner n-high s-low) - (ash-outer n-high s-high))))) - (make-numeric-type :class 'integer - :complexp :real - :low low-slot - :high high-slot)))))))) - *universal-type*)) - (or (let ((n-type (continuation-type n))) - (when (numeric-type-p n-type) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type))) - (if (constant-continuation-p shift) - (let ((shift (continuation-value shift))) - (make-numeric-type :class 'integer - :complexp :real - :low (when n-low (ash n-low shift)) - :high (when n-high (ash n-high shift)))) - (let ((s-type (continuation-type shift))) - (when (numeric-type-p s-type) - (let ((s-low (numeric-type-low s-type)) - (s-high (numeric-type-high s-type))) - (if (and s-low s-high (<= s-low 64) (<= s-high 64)) - (make-numeric-type :class 'integer - :complexp :real - :low (when n-low - (min (ash n-low s-high) - (ash n-low s-low))) - :high (when n-high - (max (ash n-high s-high) - (ash n-high s-low)))) - (make-numeric-type :class 'integer - :complexp :real))))))))) - *universal-type*)) - -#!+propagate-fun-type + (defun ash-derive-type-aux (n-type shift same-arg) (declare (ignore same-arg)) (flet ((ash-outer (n s) @@ -1522,12 +1381,11 @@ (ash-outer n-high s-high)))))) *universal-type*))) -#!+propagate-fun-type (defoptimizer (ash derive-type) ((n shift)) (two-arg-derive-type n shift #'ash-derive-type-aux #'ash)) ) ; PROGN -#!-propagate-float-type +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (macrolet ((frob (fun) `#'(lambda (type type2) (declare (ignore type2)) @@ -1536,40 +1394,34 @@ (values (if hi (,fun hi) nil) (if lo (,fun lo) nil)))))) (defoptimizer (%negate derive-type) ((num)) - (derive-integer-type num num (frob -))) + (derive-integer-type num num (frob -)))) - (defoptimizer (lognot derive-type) ((int)) - (derive-integer-type int int (frob lognot)))) - -#!+propagate-float-type (defoptimizer (lognot derive-type) ((int)) (derive-integer-type int int - #'(lambda (type type2) - (declare (ignore type2)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (values (if hi (lognot hi) nil) - (if lo (lognot lo) nil) - (numeric-type-class type) - (numeric-type-format type)))))) - -#!+propagate-float-type + (lambda (type type2) + (declare (ignore type2)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (values (if hi (lognot hi) nil) + (if lo (lognot lo) nil) + (numeric-type-class type) + (numeric-type-format type)))))) + +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (%negate derive-type) ((num)) (flet ((negate-bound (b) - (set-bound (- (bound-value b)) (consp b)))) + (and b + (set-bound (- (type-bound-number b)) + (consp b))))) (one-arg-derive-type num - #'(lambda (type) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type)) - (result (copy-numeric-type type))) - (setf (numeric-type-low result) - (if hi (negate-bound hi) nil)) - (setf (numeric-type-high result) - (if lo (negate-bound lo) nil)) - result)) + (lambda (type) + (modified-numeric-type + type + :low (negate-bound (numeric-type-high type)) + :high (negate-bound (numeric-type-low type)))) #'-))) -#!-propagate-float-type +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (abs derive-type) ((num)) (let ((type (continuation-type num))) (if (and (numeric-type-p type) @@ -1589,7 +1441,7 @@ nil))) (numeric-contagion type type)))) -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun abs-derive-type-aux (type) (cond ((eq (numeric-type-complexp type) :complex) ;; The absolute value of a complex number is always a @@ -1618,11 +1470,11 @@ :high (coerce-numeric-bound (interval-high abs-bnd) bound-type)))))) -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (abs derive-type) ((num)) (one-arg-derive-type num #'abs-derive-type-aux #'abs)) -#!-propagate-float-type +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (truncate derive-type) ((number divisor)) (let ((number-type (continuation-type number)) (divisor-type (continuation-type divisor)) @@ -1642,9 +1494,7 @@ divisor-low divisor-high)))) *universal-type*))) -#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr) -(progn -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defun rem-result-type (number-type divisor-type) @@ -1801,7 +1651,7 @@ (let ((q-aux (symbolicate q-name "-AUX")) (r-aux (symbolicate r-name "-AUX"))) `(progn - ;; Compute type of quotient (first) result + ;; Compute type of quotient (first) result. (defun ,q-aux (number-type divisor-type) (let* ((number-interval (numeric-type->interval number-type)) @@ -1811,7 +1661,7 @@ divisor-interval)))) (specifier-type `(integer ,(or (interval-low quot) '*) ,(or (interval-high quot) '*))))) - ;; Compute type of remainder + ;; Compute type of remainder. (defun ,r-aux (number-type divisor-type) (let* ((divisor-interval (numeric-type->interval divisor-type)) @@ -1831,16 +1681,16 @@ (values nil nil))) (when (member result-type '(float single-float double-float #!+long-float long-float)) - ;; Make sure the limits on the interval have + ;; Make sure that the limits on the interval have ;; the right type. - (setf rem (interval-func #'(lambda (x) - (coerce x result-type)) + (setf rem (interval-func (lambda (x) + (coerce x result-type)) rem))) (make-numeric-type :class class :format format :low (interval-low rem) :high (interval-high rem))))) - ;; The optimizer itself + ;; the optimizer itself (defoptimizer (,name derive-type) ((number divisor)) (flet ((derive-q (n d same-arg) (declare (ignore same-arg)) @@ -1859,8 +1709,7 @@ (rem (two-arg-derive-type number divisor #'derive-r #'mod))) (when (and quot rem) - (make-values-type :required (list quot rem)))))) - )))) + (make-values-type :required (list quot rem)))))))))) ;; FIXME: DEF-FROB-OPT, not just FROB-OPT (frob-opt floor floor-quotient-bound floor-rem-bound) @@ -1872,7 +1721,7 @@ (let ((q-aux (symbolicate "F" q-name "-AUX")) (r-aux (symbolicate r-name "-AUX"))) `(progn - ;; Compute type of quotient (first) result + ;; Compute type of quotient (first) result. (defun ,q-aux (number-type divisor-type) (let* ((number-interval (numeric-type->interval number-type)) @@ -1911,8 +1760,8 @@ (frob-opt ffloor floor-quotient-bound floor-rem-bound) (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound)) -;;; Functions to compute the bounds on the quotient and remainder for -;;; the FLOOR function. +;;; functions to compute the bounds on the quotient and remainder for +;;; the FLOOR function (defun floor-quotient-bound (quot) ;; Take the floor of the quotient and then massage it into what we ;; need. @@ -1921,9 +1770,9 @@ ;; Take the floor of the lower bound. The result is always a ;; closed lower bound. (setf lo (if lo - (floor (bound-value lo)) + (floor (type-bound-number lo)) nil)) - ;; For the upper bound, we need to be careful + ;; For the upper bound, we need to be careful. (setf hi (cond ((consp hi) ;; An open bound. We need to be careful here because @@ -1944,7 +1793,7 @@ ;; correct sign for the remainder if we can. (case (interval-range-info div) (+ - ;; Divisor is always positive. + ;; The divisor is always positive. (let ((rem (interval-abs div))) (setf (interval-low rem) 0) (when (and (numberp (interval-high rem)) @@ -1954,7 +1803,7 @@ (setf (interval-high rem) (list (interval-high rem)))) rem)) (- - ;; Divisor is always negative + ;; The divisor is always negative. (let ((rem (interval-neg (interval-abs div)))) (setf (interval-high rem) 0) (when (numberp (interval-low rem)) @@ -1962,11 +1811,10 @@ (setf (interval-low rem) (list (interval-low rem)))) rem)) (otherwise - ;; The divisor can be positive or negative. All bets off. - ;; The magnitude of remainder is the maximum value of the - ;; divisor. - (let ((limit (bound-value (interval-high (interval-abs div))))) - ;; The bound never reaches the limit, so make the interval open + ;; The divisor can be positive or negative. All bets off. The + ;; magnitude of remainder is the maximum value of the divisor. + (let ((limit (type-bound-number (interval-high (interval-abs div))))) + ;; The bound never reaches the limit, so make the interval open. (make-interval :low (if limit (list (- limit)) limit) @@ -2014,9 +1862,9 @@ ;; Take the ceiling of the upper bound. The result is always a ;; closed upper bound. (setf hi (if hi - (ceiling (bound-value hi)) + (ceiling (type-bound-number hi)) nil)) - ;; For the lower bound, we need to be careful + ;; For the lower bound, we need to be careful. (setf lo (cond ((consp lo) ;; An open bound. We need to be careful here because @@ -2035,7 +1883,6 @@ (defun ceiling-rem-bound (div) ;; The remainder depends only on the divisor. Try to get the ;; correct sign for the remainder if we can. - (case (interval-range-info div) (+ ;; Divisor is always positive. The remainder is negative. @@ -2056,11 +1903,10 @@ (setf (interval-high rem) (list (interval-high rem)))) rem)) (otherwise - ;; The divisor can be positive or negative. All bets off. - ;; The magnitude of remainder is the maximum value of the - ;; divisor. - (let ((limit (bound-value (interval-high (interval-abs div))))) - ;; The bound never reaches the limit, so make the interval open + ;; The divisor can be positive or negative. All bets off. The + ;; magnitude of remainder is the maximum value of the divisor. + (let ((limit (type-bound-number (interval-high (interval-abs div))))) + ;; The bound never reaches the limit, so make the interval open. (make-interval :low (if limit (list (- limit)) limit) @@ -2106,10 +1952,10 @@ ;; it's the union of the two pieces. (case (interval-range-info quot) (+ - ;; Just like floor + ;; just like FLOOR (floor-quotient-bound quot)) (- - ;; Just like ceiling + ;; just like CEILING (ceiling-quotient-bound quot)) (otherwise ;; Split the interval into positive and negative pieces, compute @@ -2119,9 +1965,9 @@ (floor-quotient-bound pos)))))) (defun truncate-rem-bound (num div) - ;; This is significantly more complicated than floor or ceiling. We + ;; This is significantly more complicated than FLOOR or CEILING. We ;; need both the number and the divisor to determine the range. The - ;; basic idea is to split the ranges of num and den into positive + ;; basic idea is to split the ranges of NUM and DEN into positive ;; and negative pieces and deal with each of the four possibilities ;; in turn. (case (interval-range-info num) @@ -2149,7 +1995,7 @@ (destructuring-bind (neg pos) (interval-split 0 num t t) (interval-merge-pair (truncate-rem-bound neg div) (truncate-rem-bound pos div)))))) -)) ; end PROGN's +) ; PROGN ;;; Derive useful information about the range. Returns three values: ;;; - '+ if its positive, '- negative, or nil if it overlaps 0. @@ -2166,9 +2012,9 @@ (defun integer-truncate-derive-type (number-low number-high divisor-low divisor-high) - ;; The result cannot be larger in magnitude than the number, but the sign - ;; might change. If we can determine the sign of either the number or - ;; the divisor, we can eliminate some of the cases. + ;; The result cannot be larger in magnitude than the number, but the + ;; sign might change. If we can determine the sign of either the + ;; number or the divisor, we can eliminate some of the cases. (multiple-value-bind (number-sign number-min number-max) (numeric-range-info number-low number-high) (multiple-value-bind (divisor-sign divisor-min divisor-max) @@ -2226,13 +2072,13 @@ ;; anything about the result. `integer))))) -#!-propagate-float-type +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun integer-rem-derive-type (number-low number-high divisor-low divisor-high) (if (and divisor-low divisor-high) - ;; We know the range of the divisor, and the remainder must be smaller - ;; than the divisor. We can tell the sign of the remainer if we know - ;; the sign of the number. + ;; We know the range of the divisor, and the remainder must be + ;; smaller than the divisor. We can tell the sign of the + ;; remainer if we know the sign of the number. (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high))))) `(integer ,(if (or (null number-low) (minusp number-low)) @@ -2242,21 +2088,21 @@ (plusp number-high)) divisor-max 0))) - ;; The divisor is potentially either very positive or very negative. - ;; Therefore, the remainer is unbounded, but we might be able to tell - ;; something about the sign from the number. + ;; The divisor is potentially either very positive or very + ;; negative. Therefore, the remainer is unbounded, but we might + ;; be able to tell something about the sign from the number. `(integer ,(if (and number-low (not (minusp number-low))) - ;; The number we are dividing is positive. Therefore, - ;; the remainder must be positive. + ;; The number we are dividing is positive. + ;; Therefore, the remainder must be positive. 0 '*) ,(if (and number-high (not (plusp number-high))) - ;; The number we are dividing is negative. Therefore, - ;; the remainder must be negative. + ;; The number we are dividing is negative. + ;; Therefore, the remainder must be negative. 0 '*)))) -#!-propagate-float-type +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (random derive-type) ((bound &optional state)) (let ((type (continuation-type bound))) (when (numeric-type-p type) @@ -2272,7 +2118,7 @@ ((or (consp high) (zerop high)) high) (t `(,high)))))))) -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun random-derive-type-aux (type) (let ((class (numeric-type-class type)) (high (numeric-type-high type)) @@ -2286,16 +2132,16 @@ ((or (consp high) (zerop high)) high) (t `(,high)))))) -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (random derive-type) ((bound &optional state)) (one-arg-derive-type bound #'random-derive-type-aux nil)) -;;;; logical derive-type methods +;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends -;;; Return the maximum number of bits an integer of the supplied type can take -;;; up, or NIL if it is unbounded. The second (third) value is T if the -;;; integer can be positive (negative) and NIL if not. Zero counts as -;;; positive. +;;; Return the maximum number of bits an integer of the supplied type +;;; can take up, or NIL if it is unbounded. The second (third) value +;;; is T if the integer can be positive (negative) and NIL if not. +;;; Zero counts as positive. (defun integer-type-length (type) (if (numeric-type-p type) (let ((min (numeric-type-low type)) @@ -2305,121 +2151,6 @@ (or (null min) (minusp min)))) (values nil t t))) -#!-propagate-fun-type -(progn -(defoptimizer (logand derive-type) ((x y)) - (multiple-value-bind (x-len x-pos x-neg) - (integer-type-length (continuation-type x)) - (declare (ignore x-pos)) - (multiple-value-bind (y-len y-pos y-neg) - (integer-type-length (continuation-type y)) - (declare (ignore y-pos)) - (if (not x-neg) - ;; X must be positive. - (if (not y-neg) - ;; The must both be positive. - (cond ((or (null x-len) (null y-len)) - (specifier-type 'unsigned-byte)) - ((or (zerop x-len) (zerop y-len)) - (specifier-type '(integer 0 0))) - (t - (specifier-type `(unsigned-byte ,(min x-len y-len))))) - ;; X is positive, but Y might be negative. - (cond ((null x-len) - (specifier-type 'unsigned-byte)) - ((zerop x-len) - (specifier-type '(integer 0 0))) - (t - (specifier-type `(unsigned-byte ,x-len))))) - ;; X might be negative. - (if (not y-neg) - ;; Y must be positive. - (cond ((null y-len) - (specifier-type 'unsigned-byte)) - ((zerop y-len) - (specifier-type '(integer 0 0))) - (t - (specifier-type - `(unsigned-byte ,y-len)))) - ;; Either might be negative. - (if (and x-len y-len) - ;; The result is bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; We can't tell squat about the result. - (specifier-type 'integer))))))) - -(defoptimizer (logior derive-type) ((x y)) - (multiple-value-bind (x-len x-pos x-neg) - (integer-type-length (continuation-type x)) - (multiple-value-bind (y-len y-pos y-neg) - (integer-type-length (continuation-type y)) - (cond - ((and (not x-neg) (not y-neg)) - ;; Both are positive. - (specifier-type `(unsigned-byte ,(if (and x-len y-len) - (max x-len y-len) - '*)))) - ((not x-pos) - ;; X must be negative. - (if (not y-pos) - ;; Both are negative. The result is going to be negative and be - ;; the same length or shorter than the smaller. - (if (and x-len y-len) - ;; It's bounded. - (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1)) - ;; It's unbounded. - (specifier-type '(integer * -1))) - ;; X is negative, but we don't know about Y. The result will be - ;; negative, but no more negative than X. - (specifier-type - `(integer ,(or (numeric-type-low (continuation-type x)) '*) - -1)))) - (t - ;; X might be either positive or negative. - (if (not y-pos) - ;; But Y is negative. The result will be negative. - (specifier-type - `(integer ,(or (numeric-type-low (continuation-type y)) '*) - -1)) - ;; We don't know squat about either. It won't get any bigger. - (if (and x-len y-len) - ;; Bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; Unbounded. - (specifier-type 'integer)))))))) - -(defoptimizer (logxor derive-type) ((x y)) - (multiple-value-bind (x-len x-pos x-neg) - (integer-type-length (continuation-type x)) - (multiple-value-bind (y-len y-pos y-neg) - (integer-type-length (continuation-type y)) - (cond - ((or (and (not x-neg) (not y-neg)) - (and (not x-pos) (not y-pos))) - ;; Either both are negative or both are positive. The result will be - ;; positive, and as long as the longer. - (specifier-type `(unsigned-byte ,(if (and x-len y-len) - (max x-len y-len) - '*)))) - ((or (and (not x-pos) (not y-neg)) - (and (not y-neg) (not y-pos))) - ;; Either X is negative and Y is positive of vice-verca. The result - ;; will be negative. - (specifier-type `(integer ,(if (and x-len y-len) - (ash -1 (max x-len y-len)) - '*) - -1))) - ;; We can't tell what the sign of the result is going to be. All we - ;; know is that we don't create new bits. - ((and x-len y-len) - (specifier-type `(signed-byte ,(1+ (max x-len y-len))))) - (t - (specifier-type 'integer)))))) - -) ; PROGN - -#!+propagate-fun-type -(progn (defun logand-derive-type-aux (x y &optional same-leaf) (declare (ignore same-leaf)) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) @@ -2429,7 +2160,7 @@ (if (not x-neg) ;; X must be positive. (if (not y-neg) - ;; The must both be positive. + ;; They must both be positive. (cond ((or (null x-len) (null y-len)) (specifier-type 'unsigned-byte)) ((or (zerop x-len) (zerop y-len)) @@ -2475,15 +2206,15 @@ ((not x-pos) ;; X must be negative. (if (not y-pos) - ;; Both are negative. The result is going to be negative and be - ;; the same length or shorter than the smaller. + ;; Both are negative. The result is going to be negative + ;; and be the same length or shorter than the smaller. (if (and x-len y-len) ;; It's bounded. (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1)) ;; It's unbounded. (specifier-type '(integer * -1))) - ;; X is negative, but we don't know about Y. The result will be - ;; negative, but no more negative than X. + ;; X is negative, but we don't know about Y. The result + ;; will be negative, but no more negative than X. (specifier-type `(integer ,(or (numeric-type-low x) '*) -1)))) @@ -2508,8 +2239,8 @@ (cond ((or (and (not x-neg) (not y-neg)) (and (not x-pos) (not y-pos))) - ;; Either both are negative or both are positive. The result will be - ;; positive, and as long as the longer. + ;; Either both are negative or both are positive. The result + ;; will be positive, and as long as the longer. (if (and x-len y-len (zerop x-len) (zerop y-len)) (specifier-type '(integer 0 0)) (specifier-type `(unsigned-byte ,(if (and x-len y-len) @@ -2517,34 +2248,35 @@ '*))))) ((or (and (not x-pos) (not y-neg)) (and (not y-neg) (not y-pos))) - ;; Either X is negative and Y is positive of vice-verca. The result - ;; will be negative. + ;; Either X is negative and Y is positive of vice-versa. The + ;; result will be negative. (specifier-type `(integer ,(if (and x-len y-len) (ash -1 (max x-len y-len)) '*) -1))) - ;; We can't tell what the sign of the result is going to be. All we - ;; know is that we don't create new bits. + ;; We can't tell what the sign of the result is going to be. + ;; All we know is that we don't create new bits. ((and x-len y-len) (specifier-type `(signed-byte ,(1+ (max x-len y-len))))) (t (specifier-type 'integer)))))) -(macrolet ((frob (logfcn) +(macrolet ((deffrob (logfcn) (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX"))) `(defoptimizer (,logfcn derive-type) ((x y)) (two-arg-derive-type x y #',fcn-aux #',logfcn))))) - ;; FIXME: DEF-FROB, not just FROB - (frob logand) - (frob logior) - (frob logxor)) + (deffrob logand) + (deffrob logior) + (deffrob logxor)) + +;;;; miscellaneous derive-type methods (defoptimizer (integer-length derive-type) ((x)) (let ((x-type (continuation-type x))) (when (and (numeric-type-p x-type) (csubtypep x-type (specifier-type 'integer))) - ;; If the X is of type (INTEGER LO HI), then the integer-length - ;; of X is (INTEGER (min lo hi) (max lo hi), basically. Be + ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH + ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be ;; careful about LO or HI being NIL, though. Also, if 0 is ;; contained in X, the lower bound is obviously 0. (flet ((null-or-min (a b) @@ -2560,9 +2292,6 @@ (when (ctypep 0 x-type) (setf min-len 0)) (specifier-type `(integer ,(or min-len '*) ,(or max-len '*)))))))) -) ; PROGN - -;;;; miscellaneous derive-type methods (defoptimizer (code-char derive-type) ((code)) (specifier-type 'base-char)) @@ -2575,21 +2304,22 @@ ;;;; byte operations ;;;; -;;;; We try to turn byte operations into simple logical operations. First, we -;;;; convert byte specifiers into separate size and position arguments passed -;;;; to internal %FOO functions. We then attempt to transform the %FOO -;;;; functions into boolean operations when the size and position are constant -;;;; and the operands are fixnums. - -(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to expressions that - ;; evaluate to the SIZE and POSITION of the byte-specifier form - ;; SPEC. We may wrap a let around the result of the body to bind - ;; some variables. +;;;; We try to turn byte operations into simple logical operations. +;;;; First, we convert byte specifiers into separate size and position +;;;; arguments passed to internal %FOO functions. We then attempt to +;;;; transform the %FOO functions into boolean operations when the +;;;; size and position are constant and the operands are fixnums. + +(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to + ;; expressions that evaluate to the SIZE and POSITION of + ;; the byte-specifier form SPEC. We may wrap a let around + ;; the result of the body to bind some variables. ;; - ;; If the spec is a BYTE form, then bind the vars to the subforms. - ;; otherwise, evaluate SPEC and use the BYTE-SIZE and BYTE-POSITION. - ;; The goal of this transformation is to avoid consing up byte - ;; specifiers and then immediately throwing them away. + ;; If the spec is a BYTE form, then bind the vars to the + ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE + ;; and BYTE-POSITION. The goal of this transformation is to + ;; avoid consing up byte specifiers and then immediately + ;; throwing them away. (with-byte-specifier ((size-var pos-var spec) &body body) (once-only ((spec `(macroexpand ,spec)) (temp '(gensym))) @@ -2625,7 +2355,7 @@ (if (and (numeric-type-p size) (csubtypep size (specifier-type 'integer))) (let ((size-high (numeric-type-high size))) - (if (and size-high (<= size-high sb!vm:word-bits)) + (if (and size-high (<= size-high sb!vm:n-word-bits)) (specifier-type `(unsigned-byte ,size-high)) (specifier-type 'unsigned-byte))) *universal-type*))) @@ -2640,7 +2370,7 @@ (let ((size-high (numeric-type-high size)) (posn-high (numeric-type-high posn))) (if (and size-high posn-high - (<= (+ size-high posn-high) sb!vm:word-bits)) + (<= (+ size-high posn-high) sb!vm:n-word-bits)) (specifier-type `(unsigned-byte ,(+ size-high posn-high))) (specifier-type 'unsigned-byte))) *universal-type*))) @@ -2660,7 +2390,7 @@ (high (numeric-type-high int)) (low (numeric-type-low int))) (if (and size-high posn-high high low - (<= (+ size-high posn-high) sb!vm:word-bits)) + (<= (+ size-high posn-high) sb!vm:n-word-bits)) (specifier-type (list (if (minusp low) 'signed-byte 'unsigned-byte) (max (integer-length high) @@ -2684,7 +2414,7 @@ (high (numeric-type-high int)) (low (numeric-type-low int))) (if (and size-high posn-high high low - (<= (+ size-high posn-high) sb!vm:word-bits)) + (<= (+ size-high posn-high) sb!vm:n-word-bits)) (specifier-type (list (if (minusp low) 'signed-byte 'unsigned-byte) (max (integer-length high) @@ -2695,30 +2425,30 @@ (deftransform %ldb ((size posn int) (fixnum fixnum integer) - (unsigned-byte #.sb!vm:word-bits)) + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(logand (ash int (- posn)) - (ash ,(1- (ash 1 sb!vm:word-bits)) - (- size ,sb!vm:word-bits)))) + (ash ,(1- (ash 1 sb!vm:n-word-bits)) + (- size ,sb!vm:n-word-bits)))) (deftransform %mask-field ((size posn int) (fixnum fixnum integer) - (unsigned-byte #.sb!vm:word-bits)) + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(logand int - (ash (ash ,(1- (ash 1 sb!vm:word-bits)) - (- size ,sb!vm:word-bits)) + (ash (ash ,(1- (ash 1 sb!vm:n-word-bits)) + (- size ,sb!vm:n-word-bits)) posn))) ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use ;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N)) -;;; as the result type, as that would allow result types -;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types -;;; of (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N). +;;; as the result type, as that would allow result types that cover +;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of +;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N). (deftransform %dpb ((new size posn int) * - (unsigned-byte #.sb!vm:word-bits)) + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ldb (byte size 0) -1))) (logior (ash (logand new mask) posn) @@ -2726,7 +2456,7 @@ (deftransform %dpb ((new size posn int) * - (signed-byte #.sb!vm:word-bits)) + (signed-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ldb (byte size 0) -1))) (logior (ash (logand new mask) posn) @@ -2734,7 +2464,7 @@ (deftransform %deposit-field ((new size posn int) * - (unsigned-byte #.sb!vm:word-bits)) + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand new mask) @@ -2742,7 +2472,7 @@ (deftransform %deposit-field ((new size posn int) * - (signed-byte #.sb!vm:word-bits)) + (signed-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand new mask) @@ -2754,14 +2484,14 @@ (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node) (if (and (constant-continuation-p x) (not (constant-continuation-p y))) - `(,(continuation-function-name (basic-combination-fun node)) + `(,(continuation-fun-name (basic-combination-fun node)) y ,(continuation-value x)) (give-up-ir1-transform))) (dolist (x '(= char= + * logior logand logxor)) (%deftransform x '(function * *) #'commutative-arg-swap - "place constant arg last.")) + "place constant arg last")) ;;; Handle the case of a constant BOOLE-CODE. (deftransform boole ((op x y) * * :when :both) @@ -2806,15 +2536,16 @@ `(- (ash x ,len)) `(ash x ,len)))) -;;; If both arguments and the result are (unsigned-byte 32), try to come up -;;; with a ``better'' multiplication using multiplier recoding. There are two -;;; different ways the multiplier can be recoded. The more obvious is to shift -;;; X by the correct amount for each bit set in Y and to sum the results. But -;;; if there is a string of bits that are all set, you can add X shifted by -;;; one more then the bit position of the first set bit and subtract X shifted -;;; by the bit position of the last set bit. We can't use this second method -;;; when the high order bit is bit 31 because shifting by 32 doesn't work -;;; too well. +;;; If both arguments and the result are (UNSIGNED-BYTE 32), try to +;;; come up with a ``better'' multiplication using multiplier +;;; recoding. There are two different ways the multiplier can be +;;; recoded. The more obvious is to shift X by the correct amount for +;;; each bit set in Y and to sum the results. But if there is a string +;;; of bits that are all set, you can add X shifted by one more then +;;; the bit position of the first set bit and subtract X shifted by +;;; the bit position of the last set bit. We can't use this second +;;; method when the high order bit is bit 31 because shifting by 32 +;;; doesn't work too well. (deftransform * ((x y) ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) @@ -2853,8 +2584,8 @@ (add '(ash x 31)))) (or result 0))) -;;; If arg is a constant power of two, turn FLOOR into a shift and mask. -;;; If CEILING, add in (1- (ABS Y)) and then do FLOOR. +;;; If arg is a constant power of two, turn FLOOR into a shift and +;;; mask. If CEILING, add in (1- (ABS Y)) and then do FLOOR. (flet ((frob (y ceil-p) (unless (constant-continuation-p y) (give-up-ir1-transform)) @@ -2931,10 +2662,11 @@ (logand x ,mask))))) ;;;; arithmetic and logical identity operation elimination -;;;; -;;;; Flush calls to various arith functions that convert to the identity -;;;; function or a constant. +;;; Flush calls to various arith functions that convert to the +;;; identity function or a constant. +;;; +;;; FIXME: Rewrite as DEF-FROB. (dolist (stuff '((ash 0 x) (logand -1 x) (logand 0 0) @@ -2956,12 +2688,12 @@ '(%negate y)) (deftransform * ((x y) (rational (constant-argument (member 0))) * :when :both) - "convert (* x 0) to 0." + "convert (* x 0) to 0" 0) -;;; Return T if in an arithmetic op including continuations X and Y, the -;;; result type is not affected by the type of X. That is, Y is at least as -;;; contagious as X. +;;; Return T if in an arithmetic op including continuations X and Y, +;;; the result type is not affected by the type of X. That is, Y is at +;;; least as contagious as X. #+nil (defun not-more-contagious (x y) (declare (type continuation x y)) @@ -2970,7 +2702,7 @@ (values (type= (numeric-contagion x y) (numeric-contagion y y))))) ;;; Patched version by Raymond Toy. dtc: Should be safer although it -;;; needs more work as valid transforms are missed; some cases are +;;; XXX needs more work as valid transforms are missed; some cases are ;;; specific to particular transform functions so the use of this ;;; function may need a re-think. (defun not-more-contagious (x y) @@ -2995,8 +2727,8 @@ ;;; Fold (+ x 0). ;;; -;;; If y is not constant, not zerop, or is contagious, or a -;;; positive float +0.0 then give up. +;;; If y is not constant, not zerop, or is contagious, or a positive +;;; float +0.0 then give up. (deftransform + ((x y) (t (constant-argument t)) * :when :both) "fold zero arg" (let ((val (continuation-value y))) @@ -3008,8 +2740,8 @@ ;;; Fold (- x 0). ;;; -;;; If y is not constant, not zerop, or is contagious, or a -;;; negative float -0.0 then give up. +;;; If y is not constant, not zerop, or is contagious, or a negative +;;; float -0.0 then give up. (deftransform - ((x y) (t (constant-argument t)) * :when :both) "fold zero arg" (let ((val (continuation-value y))) @@ -3102,8 +2834,9 @@ ;;;; equality predicate transforms -;;; Return true if X and Y are continuations whose only use is a reference -;;; to the same leaf, and the value of the leaf cannot change. +;;; Return true if X and Y are continuations whose only use is a +;;; reference to the same leaf, and the value of the leaf cannot +;;; change. (defun same-leaf-ref-p (x y) (declare (type continuation x y)) (let ((x-use (continuation-use x)) @@ -3113,24 +2846,25 @@ (eq (ref-leaf x-use) (ref-leaf y-use)) (constant-reference-p x-use)))) -;;; If X and Y are the same leaf, then the result is true. Otherwise, if -;;; there is no intersection between the types of the arguments, then the -;;; result is definitely false. +;;; If X and Y are the same leaf, then the result is true. Otherwise, +;;; if there is no intersection between the types of the arguments, +;;; then the result is definitely false. (deftransform simple-equality-transform ((x y) * * :defun-only t :when :both) (cond ((same-leaf-ref-p x y) - 't) - ((not (types-intersect (continuation-type x) (continuation-type y))) - 'nil) + t) + ((not (types-equal-or-intersect (continuation-type x) + (continuation-type y))) + nil) (t (give-up-ir1-transform)))) (dolist (x '(eq char= equal)) (%deftransform x '(function * *) #'simple-equality-transform)) -;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to -;;; convert to a type-specific predicate or EQ: +;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also +;;; try to convert to a type-specific predicate or EQ: ;;; -- If both args are characters, convert to CHAR=. This is better than ;;; just converting to EQ, since CHAR= may have special compilation ;;; strategies for non-standard representations, etc. @@ -3141,7 +2875,7 @@ ;;; it second. These rules make it easier for the back end to match ;;; these interesting cases. ;;; -- If Y is a fixnum, then we quietly pass because the back end can -;;; handle that case, otherwise give an efficency note. +;;; handle that case, otherwise give an efficiency note. (deftransform eql ((x y) * * :when :both) "convert to simpler equality predicate" (let ((x-type (continuation-type x)) @@ -3149,14 +2883,14 @@ (char-type (specifier-type 'character)) (number-type (specifier-type 'number))) (cond ((same-leaf-ref-p x y) - 't) - ((not (types-intersect x-type y-type)) - 'nil) + t) + ((not (types-equal-or-intersect x-type y-type)) + nil) ((and (csubtypep x-type char-type) (csubtypep y-type char-type)) '(char= x y)) - ((or (not (types-intersect x-type number-type)) - (not (types-intersect y-type number-type))) + ((or (not (types-equal-or-intersect x-type number-type)) + (not (types-equal-or-intersect y-type number-type))) '(eq x y)) ((and (not (constant-continuation-p y)) (or (constant-continuation-p x) @@ -3183,10 +2917,12 @@ (give-up-ir1-transform)) ((or (and (csubtypep x-type (specifier-type 'rational)) (csubtypep y-type (specifier-type 'rational))) - (and (csubtypep x-type (specifier-type '(complex rational))) - (csubtypep y-type (specifier-type '(complex rational))))) - ;; They are both rationals and complexp is the same. Convert - ;; to EQL. + (and (csubtypep x-type + (specifier-type '(complex rational))) + (csubtypep y-type + (specifier-type '(complex rational))))) + ;; They are both rationals and complexp is the same. + ;; Convert to EQL. '(eql x y)) (t (give-up-ir1-transform @@ -3194,7 +2930,7 @@ (give-up-ir1-transform "The operands might not be the same type.")))) -;;; If Cont's type is a numeric type, then return the type, otherwise +;;; If CONT's type is a numeric type, then return the type, otherwise ;;; GIVE-UP-IR1-TRANSFORM. (defun numeric-type-or-lose (cont) (declare (type continuation cont)) @@ -3202,17 +2938,17 @@ (unless (numeric-type-p res) (give-up-ir1-transform)) res)) -;;; See whether we can statically determine (< X Y) using type information. -;;; If X's high bound is < Y's low, then X < Y. Similarly, if X's low is >= -;;; to Y's high, the X >= Y (so return NIL). If not, at least make sure any -;;; constant arg is second. +;;; See whether we can statically determine (< X Y) using type +;;; information. If X's high bound is < Y's low, then X < Y. +;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return +;;; NIL). If not, at least make sure any constant arg is second. ;;; -;;; KLUDGE: Why should constant argument be second? It would be nice to find -;;; out and explain. -- WHN 19990917 -#!-propagate-float-type +;;; FIXME: Why should constant argument be second? It would be nice to +;;; find out and explain. +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun ir1-transform-< (x y first second inverse) (if (same-leaf-ref-p x y) - 'nil + nil (let* ((x-type (numeric-type-or-lose x)) (x-lo (numeric-type-low x-type)) (x-hi (numeric-type-high x-type)) @@ -3220,24 +2956,24 @@ (y-lo (numeric-type-low y-type)) (y-hi (numeric-type-high y-type))) (cond ((and x-hi y-lo (< x-hi y-lo)) - 't) + t) ((and y-hi x-lo (>= x-lo y-hi)) - 'nil) + nil) ((and (constant-continuation-p first) (not (constant-continuation-p second))) `(,inverse y x)) (t (give-up-ir1-transform)))))) -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun ir1-transform-< (x y first second inverse) (if (same-leaf-ref-p x y) - 'nil + nil (let ((xi (numeric-type->interval (numeric-type-or-lose x))) (yi (numeric-type->interval (numeric-type-or-lose y)))) (cond ((interval-< xi yi) - 't) + t) ((interval->= xi yi) - 'nil) + nil) ((and (constant-continuation-p first) (not (constant-continuation-p second))) `(,inverse y x)) @@ -3250,11 +2986,11 @@ (deftransform > ((x y) (integer integer) * :when :both) (ir1-transform-< y x x y '<)) -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (deftransform < ((x y) (float float) * :when :both) (ir1-transform-< x y x y '>)) -#!+propagate-float-type +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (deftransform > ((x y) (float float) * :when :both) (ir1-transform-< y x x y '<)) @@ -3287,11 +3023,11 @@ (last nil current) (current (gensym) (gensym)) (vars (list current) (cons current vars)) - (result 't (if not-p - `(if (,predicate ,current ,last) - nil ,result) - `(if (,predicate ,current ,last) - ,result nil)))) + (result t (if not-p + `(if (,predicate ,current ,last) + nil ,result) + `(if (,predicate ,current ,last) + ,result nil)))) ((zerop i) `((lambda ,vars ,result) . ,args))))))) @@ -3307,13 +3043,16 @@ (def-source-transform char<= (&rest args) (multi-compare 'char> args t)) (def-source-transform char>= (&rest args) (multi-compare 'char< args t)) -(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil)) -(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil)) +(def-source-transform char-equal (&rest args) + (multi-compare 'char-equal args nil)) +(def-source-transform char-lessp (&rest args) + (multi-compare 'char-lessp args nil)) (def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil)) (def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t)) -(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t)) +(def-source-transform char-not-lessp (&rest args) + (multi-compare 'char-lessp args t)) ;;; This function does source transformation of N-arg inequality ;;; functions such as /=. This is similar to Multi-Compare in the <3 @@ -3326,14 +3065,15 @@ ((= nargs 1) `(progn ,@args t)) ((= nargs 2) `(if (,predicate ,(first args) ,(second args)) nil t)) - ((not (policy nil (and (>= speed space) - (>= speed compilation-speed)))) + ((not (policy *lexenv* + (and (>= speed space) + (>= speed compilation-speed)))) (values nil t)) (t (let ((vars (make-gensym-list nargs))) (do ((var vars next) (next (cdr vars) (cdr next)) - (result 't)) + (result t)) ((null next) `((lambda ,vars ,result) . ,args)) (let ((v1 (first var))) @@ -3342,7 +3082,8 @@ (def-source-transform /= (&rest args) (multi-not-equal '= args)) (def-source-transform char/= (&rest args) (multi-not-equal 'char= args)) -(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args)) +(def-source-transform char-not-equal (&rest args) + (multi-not-equal 'char-equal args)) ;;; Expand MAX and MIN into the obvious comparisons. (def-source-transform max (arg &rest more-args) @@ -3365,7 +3106,7 @@ ;;;; N-arg arithmetic and logic functions are associated into two-arg ;;;; versions, and degenerate cases are flushed. -;;; Left-associate First-Arg and More-Args using Function. +;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION. (declaim (ftype (function (symbol t list) list) associate-arguments)) (defun associate-arguments (function first-arg more-args) (let ((next (rest more-args)) @@ -3436,7 +3177,7 @@ (def-source-transform / (&rest args) (source-transform-intransitive '/ args '(/ 1))) -;;;; APPLY +;;;; transforming APPLY ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler ;;; only needs to understand one kind of variable-argument call. It is @@ -3449,7 +3190,7 @@ (butlast args)) (values-list ,(car (last args)))))) -;;;; FORMAT +;;;; transforming FORMAT ;;;; ;;;; If the control string is a compile-time constant, then replace it ;;;; with a use of the FORMATTER macro so that the control string is @@ -3480,3 +3221,136 @@ (declare (ignore tee)) (funcall control *standard-output* ,@arg-names) nil))) + +(defoptimizer (coerce derive-type) ((value type)) + (let ((value-type (continuation-type value)) + (type-type (continuation-type type))) + (labels + ((good-cons-type-p (cons-type) + ;; Make sure the cons-type we're looking at is something + ;; we're prepared to handle which is basically something + ;; that array-element-type can return. + (or (and (member-type-p cons-type) + (null (rest (member-type-members cons-type))) + (null (first (member-type-members cons-type)))) + (let ((car-type (cons-type-car-type cons-type))) + (and (member-type-p car-type) + (null (rest (member-type-members car-type))) + (or (symbolp (first (member-type-members car-type))) + (numberp (first (member-type-members car-type))) + (and (listp (first (member-type-members car-type))) + (numberp (first (first (member-type-members + car-type)))))) + (good-cons-type-p (cons-type-cdr-type cons-type)))))) + (unconsify-type (good-cons-type) + ;; Convert the "printed" respresentation of a cons + ;; specifier into a type specifier. That is, the specifier + ;; (cons (eql signed-byte) (cons (eql 16) null)) is + ;; converted to (signed-byte 16). + (cond ((or (null good-cons-type) + (eq good-cons-type 'null)) + nil) + ((and (eq (first good-cons-type) 'cons) + (eq (first (second good-cons-type)) 'member)) + `(,(second (second good-cons-type)) + ,@(unconsify-type (caddr good-cons-type)))))) + (coerceable-p (c-type) + ;; Can the value be coerced to the given type? Coerce is + ;; complicated, so we don't handle every possible case + ;; here---just the most common and easiest cases: + ;; + ;; o Any real can be coerced to a float type. + ;; o Any number can be coerced to a complex single/double-float. + ;; o An integer can be coerced to an integer. + (let ((coerced-type c-type)) + (or (and (subtypep coerced-type 'float) + (csubtypep value-type (specifier-type 'real))) + (and (subtypep coerced-type + '(or (complex single-float) + (complex double-float))) + (csubtypep value-type (specifier-type 'number))) + (and (subtypep coerced-type 'integer) + (csubtypep value-type (specifier-type 'integer)))))) + (process-types (type) + ;; FIXME: + ;; This needs some work because we should be able to derive + ;; the resulting type better than just the type arg of + ;; coerce. That is, if x is (integer 10 20), the (coerce x + ;; 'double-float) should say (double-float 10d0 20d0) + ;; instead of just double-float. + (cond ((member-type-p type) + (let ((members (member-type-members type))) + (if (every #'coerceable-p members) + (specifier-type `(or ,@members)) + *universal-type*))) + ((and (cons-type-p type) + (good-cons-type-p type)) + (let ((c-type (unconsify-type (type-specifier type)))) + (if (coerceable-p c-type) + (specifier-type c-type) + *universal-type*))) + (t + *universal-type*)))) + (cond ((union-type-p type-type) + (apply #'type-union (mapcar #'process-types + (union-type-types type-type)))) + ((or (member-type-p type-type) + (cons-type-p type-type)) + (process-types type-type)) + (t + *universal-type*))))) + +(defoptimizer (array-element-type derive-type) ((array)) + (let* ((array-type (continuation-type array))) + (labels ((consify (list) + (if (endp list) + '(eql nil) + `(cons (eql ,(car list)) ,(consify (rest list))))) + (get-element-type (a) + (let ((element-type + (type-specifier (array-type-specialized-element-type a)))) + (cond ((eq element-type '*) + (specifier-type 'type-specifier)) + ((symbolp element-type) + (make-member-type :members (list element-type))) + ((consp element-type) + (specifier-type (consify element-type))) + (t + (error "can't understand type ~S~%" element-type)))))) + (cond ((array-type-p array-type) + (get-element-type array-type)) + ((union-type-p array-type) + (apply #'type-union + (mapcar #'get-element-type (union-type-types array-type)))) + (t + *universal-type*))))) + +;;;; debuggers' little helpers + +;;; for debugging when transforms are behaving mysteriously, +;;; e.g. when debugging a problem with an ASH transform +;;; (defun foo (&optional s) +;;; (sb-c::/report-continuation s "S outside WHEN") +;;; (when (and (integerp s) (> s 3)) +;;; (sb-c::/report-continuation s "S inside WHEN") +;;; (let ((bound (ash 1 (1- s)))) +;;; (sb-c::/report-continuation bound "BOUND") +;;; (let ((x (- bound)) +;;; (y (1- bound))) +;;; (sb-c::/report-continuation x "X") +;;; (sb-c::/report-continuation x "Y")) +;;; `(integer ,(- bound) ,(1- bound))))) +;;; (The DEFTRANSFORM doesn't do anything but report at compile time, +;;; and the function doesn't do anything at all.) +#!+sb-show +(progn + (defknown /report-continuation (t t) null) + (deftransform /report-continuation ((x message) (t t)) + (format t "~%/in /REPORT-CONTINUATION~%") + (format t "/(CONTINUATION-TYPE X)=~S~%" (continuation-type x)) + (when (constant-continuation-p x) + (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x))) + (format t "/MESSAGE=~S~%" (continuation-value message)) + (give-up-ir1-transform "not a real transform")) + (defun /report-continuation (&rest rest) + (declare (ignore rest))))