X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=e7bae1b0e108f078fb6c91291aa7f95a135c606c;hb=4ad052044a22f502d9dc6faf6dfe01f3bab84262;hp=d8e2ac0eec7af518ed9cb7e43ea03afb0576853f;hpb=5eb97830eca716fef626c6e12429c99c9b97e3c8;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index d8e2ac0..e7bae1b 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -15,31 +15,26 @@ ;;; 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)) +(define-source-transform not (x) `(if ,x nil t)) +(define-source-transform null (x) `(if ,x nil t)) -;;; ENDP is just NULL with a LIST assertion. -(def-source-transform endp (x) `(null (the list ,x))) -;;; FIXME: Is THE LIST a strong enough assertion for ANSI's "should -;;; return an error"? (THE LIST is optimized away when safety is low; -;;; does that satisfy the spec?) +;;; ENDP is just NULL with a LIST assertion. The assertion will be +;;; optimized away when SAFETY optimization is low; hopefully that +;;; is consistent with ANSI's "should return an error". +(define-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)) +(define-source-transform identity (x) `(prog1 ,x)) +(define-source-transform values (x) `(prog1 ,x)) ;;; Bind the values and make a closure that returns them. -(def-source-transform constantly (value &rest values) - (let ((temps (make-gensym-list (1+ (length values)))) - (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))))) +(define-source-transform constantly (value) + (let ((rest (gensym "CONSTANTLY-REST-"))) + `(lambda (&rest ,rest) + (declare (ignore ,rest)) + ,value))) ;;; If the function has a known number of arguments, then return a ;;; lambda with the appropriate fixed number of args. If the @@ -48,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))) @@ -65,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)) @@ -79,44 +73,55 @@ ,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 ;;; 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)) +(define-source-transform first (x) `(car ,x)) +(define-source-transform rest (x) `(cdr ,x)) +(define-source-transform second (x) `(cadr ,x)) +(define-source-transform third (x) `(caddr ,x)) +(define-source-transform fourth (x) `(cadddr ,x)) +(define-source-transform fifth (x) `(nth 4 ,x)) +(define-source-transform sixth (x) `(nth 5 ,x)) +(define-source-transform seventh (x) `(nth 6 ,x)) +(define-source-transform eighth (x) `(nth 7 ,x)) +(define-source-transform ninth (x) `(nth 8 ,x)) +(define-source-transform tenth (x) `(nth 9 ,x)) ;;; Translate RPLACx to LET and SETF. -(def-source-transform rplaca (x y) +(define-source-transform rplaca (x y) (once-only ((n-x x)) `(progn (setf (car ,n-x) ,y) ,n-x))) -(def-source-transform rplacd (x y) +(define-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))) +(define-source-transform nth (n l) `(car (nthcdr ,n ,l))) (defvar *default-nthcdr-open-code-limit* 6) (defvar *extreme-nthcdr-open-code-limit* 20) @@ -127,7 +132,7 @@ (give-up-ir1-transform)) (let ((n (continuation-value n))) (when (> n - (if (policy node (= speed 3) (= space 0)) + (if (policy node (and (= speed 3) (= space 0))) *extreme-nthcdr-open-code-limit* *default-nthcdr-open-code-limit*)) (give-up-ir1-transform)) @@ -138,95 +143,73 @@ `(cdr ,(frob (1- n)))))) (frob n)))) -;;; MNA: cons compound-type patch -;;; FIXIT: all commented out - -; ;;;; CONS assessor derive type optimizers. - -; (defoptimizer (car derive-type) ((cons)) -; (let ((type (continuation-type cons))) -; (cond ((eq type (specifier-type 'null)) -; (specifier-type 'null)) -; ((cons-type-p type) -; (cons-type-car-type type))))) - -; (defoptimizer (cdr derive-type) ((cons)) -; (let ((type (continuation-type cons))) -; (cond ((eq type (specifier-type 'null)) -; (specifier-type 'null)) -; ((cons-type-p type) -; (cons-type-cdr-type type))))) - - ;;;; arithmetic and numerology -(def-source-transform plusp (x) `(> ,x 0)) -(def-source-transform minusp (x) `(< ,x 0)) -(def-source-transform zerop (x) `(= ,x 0)) +(define-source-transform plusp (x) `(> ,x 0)) +(define-source-transform minusp (x) `(< ,x 0)) +(define-source-transform zerop (x) `(= ,x 0)) -(def-source-transform 1+ (x) `(+ ,x 1)) -(def-source-transform 1- (x) `(- ,x 1)) +(define-source-transform 1+ (x) `(+ ,x 1)) +(define-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))) +(define-source-transform oddp (x) `(not (zerop (logand ,x 1)))) +(define-source-transform evenp (x) `(zerop (logand ,x 1))) ;;; Note that all the integer division functions are available for ;;; inline expansion. -;;; FIXME: DEF-FROB instead of FROB -(macrolet ((frob (fun) - `(def-source-transform ,fun (x &optional (y nil y-p)) +(macrolet ((deffrob (fun) + `(define-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)) - -(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) + (deffrob truncate) + (deffrob round) + #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + (deffrob floor) + #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + (deffrob ceiling)) + +(define-source-transform lognand (x y) `(lognot (logand ,x ,y))) +(define-source-transform lognor (x y) `(lognot (logior ,x ,y))) +(define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y)) +(define-source-transform logandc2 (x y) `(logand ,x (lognot ,y))) +(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y)) +(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y))) +(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y)))) +(define-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) +(define-source-transform byte (size position) `(cons ,size ,position)) +(define-source-transform byte-size (spec) `(car ,spec)) +(define-source-transform byte-position (spec) `(cdr ,spec)) +(define-source-transform ldb-test (bytespec integer) `(not (zerop (mask-field ,bytespec ,integer)))) ;;; 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) +(define-source-transform numerator (num) (once-only ((n-num `(the rational ,num))) `(if (ratiop ,n-num) (%numerator ,n-num) ,n-num))) -(def-source-transform denominator (num) +(define-source-transform denominator (num) (once-only ((n-num `(the rational ,num))) `(if (ratiop ,n-num) (%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 @@ -234,27 +217,22 @@ ;;;; 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. -(defstruct (interval - (:constructor %make-interval)) +(defstruct (interval (:constructor %make-interval) + (:copier nil)) low high) (defun make-interval (&key low high) (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 @@ -263,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)) @@ -289,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 @@ -303,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) @@ -326,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 @@ -340,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)) @@ -356,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 @@ -365,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)))) @@ -379,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) @@ -400,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) @@ -415,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) @@ -429,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)) @@ -442,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 @@ -498,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. @@ -506,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. ;;; @@ -534,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) @@ -550,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))))) @@ -570,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) @@ -586,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 @@ -612,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) @@ -655,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 @@ -680,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)) @@ -698,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)) @@ -731,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 @@ -749,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) @@ -763,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) @@ -785,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) @@ -802,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)) @@ -833,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) @@ -877,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 @@ -886,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 @@ -919,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)))) @@ -932,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) @@ -997,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. @@ -1021,13 +953,15 @@ (t type-list))) -;;; Make-Canonical-Union-Type -;;; +;;; 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 members types together. If both positive and -;;; negative members types are present they are converted to a float -;;; type. X 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 '())) @@ -1054,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. ;;; @@ -1145,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 @@ -1168,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)) @@ -1241,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 @@ -1295,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) @@ -1318,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)) @@ -1334,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) @@ -1351,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)) @@ -1367,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) @@ -1385,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) @@ -1400,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 @@ -1429,68 +1341,51 @@ ) ; PROGN + ;;; 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)) - (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)) - (or (and (csubtypep n-type (specifier-type 'integer)) - (csubtypep shift (specifier-type 'integer)) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type)) - (s-low (numeric-type-low shift)) - (s-high (numeric-type-high shift))) - ;; KLUDGE: The bare 64's here should be related to - ;; symbolic machine word size values somehow. - (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 + (flet ((ash-outer (n s) + (when (and (fixnump s) + (<= s 64) + (> s sb!vm:*target-most-negative-fixnum*)) + (ash n s))) + ;; KLUDGE: The bare 64's here should be related to + ;; symbolic machine word size values somehow. + + (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 (and (csubtypep n-type (specifier-type 'integer)) + (csubtypep shift (specifier-type 'integer)) + (let ((n-low (numeric-type-low n-type)) + (n-high (numeric-type-high n-type)) + (s-low (numeric-type-low shift)) + (s-high (numeric-type-high shift))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low + (if (minusp n-low) + (ash-outer n-low s-high) + (ash-inner n-low s-low))) + :high (when n-high + (if (minusp n-high) + (ash-inner n-high s-low) + (ash-outer n-high s-high)))))) + *universal-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)) @@ -1499,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 -))) - - (defoptimizer (lognot derive-type) ((int)) - (derive-integer-type int int (frob lognot)))) + (derive-integer-type num num (frob -)))) -#!+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) @@ -1552,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 @@ -1581,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)) @@ -1605,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) @@ -1764,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)) @@ -1774,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)) @@ -1794,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)) @@ -1822,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) @@ -1835,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)) @@ -1874,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. @@ -1884,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 @@ -1907,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)) @@ -1917,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)) @@ -1925,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) @@ -1977,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 @@ -1998,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. @@ -2019,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) @@ -2069,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 @@ -2082,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) @@ -2112,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. @@ -2129,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) @@ -2189,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)) @@ -2205,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) @@ -2235,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)) @@ -2249,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)) @@ -2268,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) @@ -2392,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)) @@ -2438,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)))) @@ -2471,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) @@ -2480,35 +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 -;; MNA: defoptimizer for integer-length patch (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) @@ -2524,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)) @@ -2539,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))) @@ -2568,19 +2334,19 @@ `(let ((,,temp ,,spec)) ,,@body)))))) - (def-source-transform ldb (spec int) + (define-source-transform ldb (spec int) (with-byte-specifier (size pos spec) `(%ldb ,size ,pos ,int))) - (def-source-transform dpb (newbyte spec int) + (define-source-transform dpb (newbyte spec int) (with-byte-specifier (size pos spec) `(%dpb ,newbyte ,size ,pos ,int))) - (def-source-transform mask-field (spec int) + (define-source-transform mask-field (spec int) (with-byte-specifier (size pos spec) `(%mask-field ,size ,pos ,int))) - (def-source-transform deposit-field (newbyte spec int) + (define-source-transform deposit-field (newbyte spec int) (with-byte-specifier (size pos spec) `(%deposit-field ,newbyte ,size ,pos ,int)))) @@ -2589,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*))) @@ -2604,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*))) @@ -2624,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) @@ -2648,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) @@ -2659,55 +2425,55 @@ (deftransform %ldb ((size posn int) (fixnum fixnum integer) - (unsigned-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + (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)) - "convert to inline logical ops" + (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)) - "convert to inline logical ops" + (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) (logand int (lognot (ash mask posn)))))) (deftransform %dpb ((new size posn int) * - (signed-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + (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) (logand int (lognot (ash mask posn)))))) (deftransform %deposit-field ((new size posn int) * - (unsigned-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + (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) (logand int (lognot mask))))) (deftransform %deposit-field ((new size posn int) * - (signed-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + (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) (logand int (lognot mask))))) @@ -2718,18 +2484,18 @@ (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) - "convert to inline logical ops" + "convert to inline logical operations" (unless (constant-continuation-p op) (give-up-ir1-transform "BOOLE code is not a constant.")) (let ((control (continuation-value op))) @@ -2770,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)) @@ -2817,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)) @@ -2895,22 +2662,21 @@ (logand x ,mask))))) ;;;; arithmetic and logical identity operation elimination -;;;; -;;;; Flush calls to various arith functions that convert to the identity -;;;; function or a constant. - -(dolist (stuff '((ash 0 x) - (logand -1 x) - (logand 0 0) - (logior 0 x) - (logior -1 -1) - (logxor -1 (lognot x)) - (logxor 0 x))) - (destructuring-bind (name identity result) stuff - (deftransform name ((x y) `(* (constant-argument (member ,identity))) '* - :eval-name t :when :both) - "fold identity operations" - result))) + +;;; Flush calls to various arith functions that convert to the +;;; identity function or a constant. +(macrolet ((def-frob (name identity result) + `(deftransform ,name ((x y) (* (constant-argument (member ,identity))) + * :when :both) + "fold identity operations" + ',result))) + (def-frob ash 0 x) + (def-frob logand -1 x) + (def-frob logand 0 0) + (def-frob logior 0 x) + (def-frob logior -1 -1) + (def-frob logxor -1 (lognot x)) + (def-frob logxor 0 x)) ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and ;;; (* 0 -4.0) is -0.0. @@ -2920,12 +2686,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)) @@ -2934,7 +2700,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) @@ -2959,8 +2725,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))) @@ -2972,8 +2738,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))) @@ -2984,18 +2750,18 @@ 'x) ;;; Fold (OP x +/-1) -(dolist (stuff '((* x (%negate x)) - (/ x (%negate x)) - (expt x (/ 1 x)))) - (destructuring-bind (name result minus-result) stuff - (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t - :when :both) - "fold identity operations" - (let ((val (continuation-value y))) - (unless (and (= (abs val) 1) - (not-more-contagious y x)) - (give-up-ir1-transform)) - (if (minusp val) minus-result result))))) +(macrolet ((def-frob (name result minus-result) + `(deftransform ,name ((x y) (t (constant-argument real)) + * :when :both) + "fold identity operations" + (let ((val (continuation-value y))) + (unless (and (= (abs val) 1) + (not-more-contagious y x)) + (give-up-ir1-transform)) + (if (minusp val) ',minus-result ',result))))) + (def-frob * x (%negate x)) + (def-frob / x (%negate x)) + (def-frob expt x (/ 1 x))) ;;; Fold (expt x n) into multiplications for small integral values of ;;; N; convert (expt x 1/2) to sqrt. @@ -3020,18 +2786,25 @@ ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these ;;; transformations? ;;; Perhaps we should have to prove that the denominator is nonzero before -;;; doing them? (Also the DOLIST over macro calls is weird. Perhaps -;;; just FROB?) -- WHN 19990917 -(dolist (name '(ash /)) - (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '* - :eval-name t :when :both) - "fold zero arg" - 0)) -(dolist (name '(truncate round floor ceiling)) - (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '* - :eval-name t :when :both) - "fold zero arg" - '(values 0 0))) +;;; doing them? -- WHN 19990917 +(macrolet ((def-frob (name) + `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer) + * :when :both) + "fold zero arg" + 0))) + (def-frob ash) + (def-frob /)) + +(macrolet ((def-frob (name) + `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer) + * :when :both) + "fold zero arg" + '(values 0 0)))) + (def-frob truncate) + (def-frob round) + (def-frob floor) + (def-frob ceiling)) + ;;;; character operations @@ -3063,8 +2836,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)) @@ -3074,33 +2848,39 @@ (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. -(deftransform simple-equality-transform ((x y) * * :defun-only t +;;; 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: -;;; -- 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. -;;; -- If either arg is definitely not a number, then we can compare with EQ. -;;; -- Otherwise, we try to put the arg we know more about second. If X is -;;; constant then we put it second. If X is a subtype of Y, we put 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. +(macrolet ((def-frob (x) + `(%deftransform ',x '(function * *) #'simple-equality-transform))) + (def-frob eq) + (def-frob char=) + (def-frob equal)) + +;;; 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. +;;; -- If either arg is definitely not a number, then we can compare +;;; with EQ. +;;; -- Otherwise, we try to put the arg we know more about second. If X +;;; is constant then we put it second. If X is a subtype of Y, we put +;;; 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 efficiency note. (deftransform eql ((x y) * * :when :both) "convert to simpler equality predicate" (let ((x-type (continuation-type x)) @@ -3108,14 +2888,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) @@ -3142,10 +2922,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 @@ -3153,7 +2935,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)) @@ -3161,17 +2943,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)) @@ -3179,24 +2961,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)) @@ -3209,11 +2991,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 '<)) @@ -3246,31 +3028,36 @@ (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))))))) -(def-source-transform = (&rest args) (multi-compare '= args nil)) -(def-source-transform < (&rest args) (multi-compare '< args nil)) -(def-source-transform > (&rest args) (multi-compare '> args nil)) -(def-source-transform <= (&rest args) (multi-compare '> args t)) -(def-source-transform >= (&rest args) (multi-compare '< args t)) - -(def-source-transform char= (&rest args) (multi-compare 'char= args nil)) -(def-source-transform char< (&rest args) (multi-compare 'char< args nil)) -(def-source-transform char> (&rest args) (multi-compare 'char> args nil)) -(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-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)) +(define-source-transform = (&rest args) (multi-compare '= args nil)) +(define-source-transform < (&rest args) (multi-compare '< args nil)) +(define-source-transform > (&rest args) (multi-compare '> args nil)) +(define-source-transform <= (&rest args) (multi-compare '> args t)) +(define-source-transform >= (&rest args) (multi-compare '< args t)) + +(define-source-transform char= (&rest args) (multi-compare 'char= args nil)) +(define-source-transform char< (&rest args) (multi-compare 'char< args nil)) +(define-source-transform char> (&rest args) (multi-compare 'char> args nil)) +(define-source-transform char<= (&rest args) (multi-compare 'char> args t)) +(define-source-transform char>= (&rest args) (multi-compare 'char< args t)) + +(define-source-transform char-equal (&rest args) + (multi-compare 'char-equal args nil)) +(define-source-transform char-lessp (&rest args) + (multi-compare 'char-lessp args nil)) +(define-source-transform char-greaterp (&rest args) + (multi-compare 'char-greaterp args nil)) +(define-source-transform char-not-greaterp (&rest args) + (multi-compare 'char-greaterp args t)) +(define-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 @@ -3283,32 +3070,35 @@ ((= nargs 1) `(progn ,@args t)) ((= nargs 2) `(if (,predicate ,(first args) ,(second args)) nil t)) - ((not (policy nil (>= speed space) (>= speed cspeed))) + ((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))) (dolist (v2 next) (setq result `(if (,predicate ,v1 ,v2) nil ,result)))))))))) -(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)) +(define-source-transform /= (&rest args) (multi-not-equal '= args)) +(define-source-transform char/= (&rest args) (multi-not-equal 'char= args)) +(define-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) +(define-source-transform max (arg &rest more-args) (if (null more-args) `(values ,arg) (once-only ((arg1 arg) (arg2 `(max ,@more-args))) `(if (> ,arg1 ,arg2) ,arg1 ,arg2)))) -(def-source-transform min (arg &rest more-args) +(define-source-transform min (arg &rest more-args) (if (null more-args) `(values ,arg) (once-only ((arg1 arg) @@ -3321,7 +3111,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)) @@ -3332,7 +3122,7 @@ ;;; Do source transformations for transitive functions such as +. ;;; One-arg cases are replaced with the arg and zero arg cases with -;;; the identity. If Leaf-Fun is true, then replace two-arg calls with +;;; the identity. If LEAF-FUN is true, then replace two-arg calls with ;;; a call to that function. (defun source-transform-transitive (fun args identity &optional leaf-fun) (declare (symbol fun leaf-fun) (list args)) @@ -3345,13 +3135,18 @@ (t (associate-arguments fun (first args) (rest args))))) -(def-source-transform + (&rest args) (source-transform-transitive '+ args 0)) -(def-source-transform * (&rest args) (source-transform-transitive '* args 1)) -(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0)) -(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0)) -(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1)) - -(def-source-transform logeqv (&rest args) +(define-source-transform + (&rest args) + (source-transform-transitive '+ args 0)) +(define-source-transform * (&rest args) + (source-transform-transitive '* args 1)) +(define-source-transform logior (&rest args) + (source-transform-transitive 'logior args 0)) +(define-source-transform logxor (&rest args) + (source-transform-transitive 'logxor args 0)) +(define-source-transform logand (&rest args) + (source-transform-transitive 'logand args -1)) + +(define-source-transform logeqv (&rest args) (if (evenp (length args)) `(lognot (logxor ,@args)) `(logxor ,@args))) @@ -3360,14 +3155,14 @@ ;;; because when they are given one argument, they return its absolute ;;; value. -(def-source-transform gcd (&rest args) +(define-source-transform gcd (&rest args) (case (length args) (0 0) (1 `(abs (the integer ,(first args)))) (2 (values nil t)) (t (associate-arguments 'gcd (first args) (rest args))))) -(def-source-transform lcm (&rest args) +(define-source-transform lcm (&rest args) (case (length args) (0 1) (1 `(abs (the integer ,(first args)))) @@ -3384,17 +3179,17 @@ (1 `(,@inverse ,(first args))) (t (associate-arguments function (first args) (rest args))))) -(def-source-transform - (&rest args) +(define-source-transform - (&rest args) (source-transform-intransitive '- args '(%negate))) -(def-source-transform / (&rest args) +(define-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 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY. -(def-source-transform apply (fun arg &rest more-args) +(define-source-transform apply (fun arg &rest more-args) (let ((args (cons arg more-args))) `(multiple-value-call ,fun ,@(mapcar #'(lambda (x) @@ -3402,7 +3197,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 @@ -3433,3 +3228,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))))