X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=c1a53a9bd8d8b9e98035b260705a17cf710bbd0a;hb=05525d3a5906d7a89fcb689c26177732493c40ce;hp=6a18bcf2c1c2e55f9f607ee3c6fd264aac0d2120;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 6a18bcf..c1a53a9 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1,6 +1,6 @@ ;;;; This file contains macro-like source transformations which ;;;; convert uses of certain functions into the canonical form desired -;;;; within the compiler. ### and other IR1 transforms and stuff. +;;;; within the compiler. FIXME: and other IR1 transforms and stuff. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -15,40 +15,36 @@ ;;; 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)) - -;;; 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 identity (x) `(prog1 ,x)) +(define-source-transform values (x) `(prog1 ,x)) + +;;; Bind the value and make a closure that returns it. +(define-source-transform constantly (value) + (with-unique-names (rest n-value) + `(let ((,n-value ,value)) + (lambda (&rest ,rest) + (declare (ignore ,rest)) + ,n-value)))) ;;; If the function has a known number of arguments, then return a ;;; lambda with the appropriate fixed number of args. If the ;;; destination is a FUNCALL, then do the &REST APPLY thing, and let ;;; MV optimization figure things out. -(deftransform complement ((fun) * * :node node :when :both) +(deftransform complement ((fun) * * :node node) "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 +61,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 +74,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 +133,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)) @@ -140,73 +146,72 @@ ;;;; 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 @@ -214,27 +219,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 @@ -243,37 +243,33 @@ ;; 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)) ;;; Apply the function F to a bound X. If X is an open bound, then ;;; the result will be open. IF X is NIL, the result is NIL. (defun bound-func (f x) + (declare (type function f)) (and x (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) ;; 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 @@ -283,14 +279,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) @@ -306,8 +299,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 @@ -320,14 +311,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)) @@ -336,8 +325,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 @@ -345,9 +332,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)))) @@ -359,30 +346,27 @@ (>= 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) (declare (type interval x)) (ecase how - ('above + (above (interval-high x)) - ('below + (below (interval-low x)) - ('both + (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) @@ -395,13 +379,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) @@ -409,10 +391,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)) @@ -422,35 +402,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 @@ -478,7 +456,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. @@ -486,8 +464,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. ;;; @@ -514,14 +490,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) @@ -530,7 +506,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))))) @@ -550,13 +526,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) @@ -566,15 +542,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 @@ -592,37 +568,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) @@ -635,7 +603,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 @@ -660,14 +628,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!")))))) + (bug "excluded case in INTERVAL-MUL")))))) -;;; INTERVAL-DIV -;;; ;;; Divide two intervals. (defun interval-div (top bot) (declare (type interval top bot)) @@ -678,12 +645,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)) @@ -711,26 +678,24 @@ ;; 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!")))))) + (bug "excluded case 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 ;;; non-decreasing). (defun interval-func (f x) - (declare (type interval x)) + (declare (type function f) + (type interval x)) (let ((lo (bound-func f (interval-low x))) (hi (bound-func f (interval-high x)))) (make-interval :low lo :high hi))) -;;; INTERVAL-< -;;; ;;; Return T if X < Y. That is every number in the interval X is ;;; always less than any number in the interval Y. (defun interval-< (x y) @@ -743,21 +708,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) @@ -765,38 +728,34 @@ ;; 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) - ('+ + (+ (copy-interval x)) - ('- + (- (interval-neg x)) (t (destructuring-bind (x- x+) (interval-split 0 x t t) (interval-merge-pair (interval-neg x-) x+))))) -;;; INTERVAL-SQR -;;; ;;; Compute the square of an interval. (defun interval-sqr (x) (declare (type interval x)) - (interval-func #'(lambda (x) (* x x)) + (interval-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)) @@ -813,10 +772,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) @@ -857,19 +813,18 @@ 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 (defun convert-numeric-type (type) (declare (type numeric-type type)) ;;; 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 @@ -879,11 +834,11 @@ :low (if lo-float-zero-p (if (consp lo) (list (float 0.0 lo-val)) - (float -0.0 lo-val)) + (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val)) lo) :high (if hi-float-zero-p (if (consp hi) - (list (float -0.0 hi-val)) + (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)) (float 0.0 hi-val)) hi)) type)) @@ -893,18 +848,17 @@ ;;; Convert back from the intermediate convention for which -0.0 and ;;; 0.0 are considered different to the standard type convention for ;;; which and equal. -#!-negative-zero-is-not-zero (defun convert-back-numeric-type (type) (declare (type numeric-type type)) ;;; 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)))) @@ -912,8 +866,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) @@ -977,11 +931,10 @@ :high (list (float 0.0 hi-val))))))) (t type))) - ;; Not real float. + ;; not real float type)) ;;; Convert back a possible list of numeric types. -#!-negative-zero-is-not-zero (defun convert-back-numeric-type-list (type-list) (typecase type-list (list @@ -1001,13 +954,17 @@ (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. (In +;;; fact, as of 0.pre8.100 or so they probably are, under +;;; MAKE-MEMBER-TYPE, so probably this code can be deleted) + ;;; 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 '())) @@ -1016,55 +973,30 @@ (setf members (union members (member-type-members type))) (push type misc-types))) #!+long-float - (when (null (set-difference '(-0l0 0l0) members)) - #!-negative-zero-is-not-zero - (push (specifier-type '(long-float 0l0 0l0)) misc-types) - #!+negative-zero-is-not-zero - (push (specifier-type '(long-float -0l0 0l0)) misc-types) - (setf members (set-difference members '(-0l0 0l0)))) - (when (null (set-difference '(-0d0 0d0) members)) - #!-negative-zero-is-not-zero - (push (specifier-type '(double-float 0d0 0d0)) misc-types) - #!+negative-zero-is-not-zero - (push (specifier-type '(double-float -0d0 0d0)) misc-types) - (setf members (set-difference members '(-0d0 0d0)))) - (when (null (set-difference '(-0f0 0f0) members)) - #!-negative-zero-is-not-zero - (push (specifier-type '(single-float 0f0 0f0)) misc-types) - #!+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 -;;; + (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) + (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) + (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) + (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) + (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) + (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) + (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. ;;; @@ -1080,8 +1012,7 @@ (defun one-arg-derive-type (arg derive-fcn member-fcn &optional (convert-type t)) (declare (type function derive-fcn) - (type (or null function) member-fcn) - #!+negative-zero-is-not-zero (ignore convert-type)) + (type (or null function) member-fcn)) (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))) (when arg-list (flet ((deriver (x) @@ -1097,20 +1028,14 @@ ;; Otherwise convert to a numeric type. (let ((result-type-list (funcall derive-fcn (convert-member-type x)))) - #!-negative-zero-is-not-zero (if convert-type (convert-back-numeric-type-list result-type-list) - result-type-list) - #!+negative-zero-is-not-zero - result-type-list))) + result-type-list)))) (numeric-type - #!-negative-zero-is-not-zero (if convert-type (convert-back-numeric-type-list (funcall derive-fcn (convert-numeric-type x))) - (funcall derive-fcn x)) - #!+negative-zero-is-not-zero - (funcall derive-fcn x)) + (funcall derive-fcn x))) (t *universal-type*)))) ;; Run down the list of args and derive the type of each one, @@ -1125,8 +1050,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 @@ -1135,10 +1058,8 @@ ;;; positive. If we didn't do this, we wouldn't be able to tell. (defun two-arg-derive-type (arg1 arg2 derive-fcn fcn &optional (convert-type t)) - #!+negative-zero-is-not-zero - (declare (ignore convert-type)) - (flet (#!-negative-zero-is-not-zero - (deriver (x y same-arg) + (declare (type function derive-fcn fcn)) + (flet ((deriver (x y same-arg) (cond ((and (member-type-p x) (member-type-p y)) (let* ((x (first (member-type-members x))) (y (first (member-type-members y))) @@ -1148,10 +1069,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)) @@ -1176,26 +1096,6 @@ (convert-back-numeric-type-list result) result))) (t - *universal-type*))) - #!+negative-zero-is-not-zero - (deriver (x y same-arg) - (cond ((and (member-type-p x) (member-type-p y)) - (let* ((x (first (member-type-members x))) - (y (first (member-type-members y))) - (result (with-float-traps-masked - (:underflow :overflow :divide-by-zero) - (funcall fcn x y)))) - (if result - (make-member-type :members (list result))))) - ((and (member-type-p x) (numeric-type-p y)) - (let ((x (convert-member-type x))) - (funcall derive-fcn x y same-arg))) - ((and (numeric-type-p x) (member-type-p y)) - (let ((y (convert-member-type y))) - (funcall derive-fcn x y same-arg))) - ((and (numeric-type-p x) (numeric-type-p y)) - (funcall derive-fcn x y same-arg)) - (t *universal-type*)))) (let ((same-arg (same-leaf-ref-p arg1 arg2)) (a1 (prepare-arg-for-derive-type (continuation-type arg1))) @@ -1221,10 +1121,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 @@ -1275,7 +1173,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) @@ -1298,13 +1196,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)) @@ -1314,7 +1212,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) @@ -1331,13 +1229,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)) @@ -1347,8 +1245,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) @@ -1365,7 +1262,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) @@ -1380,7 +1277,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 @@ -1409,68 +1306,53 @@ ) ; 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 + ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for + ;; some bignum cases because as of version 2.4.6 for Debian and 18d, + ;; 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) + (when (and (or (typep (numeric-type-low n-type) 'bignum) + (typep (numeric-type-high n-type) 'bignum)) + (or (typep (numeric-type-low shift) 'bignum) + (typep (numeric-type-high shift) 'bignum))) + (return-from ash-derive-type-aux *universal-type*)) + (flet ((ash-outer (n s) + (when (and (fixnump s) + (<= s 64) + (> s sb!xc: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!xc: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)) @@ -1479,40 +1361,34 @@ (values (if hi (,fun hi) nil) (if lo (,fun lo) nil)))))) (defoptimizer (%negate derive-type) ((num)) - (derive-integer-type num num (frob -))) + (derive-integer-type num num (frob -)))) - (defoptimizer (lognot derive-type) ((int)) - (derive-integer-type int int (frob lognot)))) - -#!+propagate-float-type (defoptimizer (lognot derive-type) ((int)) (derive-integer-type int int - #'(lambda (type type2) - (declare (ignore type2)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (values (if hi (lognot hi) nil) - (if lo (lognot lo) nil) - (numeric-type-class type) - (numeric-type-format type)))))) - -#!+propagate-float-type + (lambda (type type2) + (declare (ignore type2)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (values (if hi (lognot hi) nil) + (if lo (lognot lo) nil) + (numeric-type-class type) + (numeric-type-format type)))))) + +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (%negate derive-type) ((num)) (flet ((negate-bound (b) - (set-bound (- (bound-value b)) (consp b)))) + (and b + (set-bound (- (type-bound-number b)) + (consp b))))) (one-arg-derive-type num - #'(lambda (type) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type)) - (result (copy-numeric-type type))) - (setf (numeric-type-low result) - (if hi (negate-bound hi) nil)) - (setf (numeric-type-high result) - (if lo (negate-bound lo) nil)) - result)) + (lambda (type) + (modified-numeric-type + type + :low (negate-bound (numeric-type-high type)) + :high (negate-bound (numeric-type-low type)))) #'-))) -#!-propagate-float-type +#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (abs derive-type) ((num)) (let ((type (continuation-type num))) (if (and (numeric-type-p type) @@ -1532,7 +1408,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 @@ -1561,11 +1437,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)) @@ -1585,9 +1461,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) @@ -1740,11 +1614,11 @@ ;;; Define optimizers for FLOOR and CEILING. (macrolet - ((frob-opt (name q-name r-name) + ((def (name q-name r-name) (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)) @@ -1754,7 +1628,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)) @@ -1774,62 +1648,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 - (defoptimizer (,name derive-type) ((number divisor)) - (flet ((derive-q (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,q-aux n d) - *empty-type*)) - (derive-r (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,r-aux n d) - *empty-type*))) - (let ((quot (two-arg-derive-type - number divisor #'derive-q #',name)) - (rem (two-arg-derive-type - number divisor #'derive-r #'mod))) - (when (and 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) - (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound)) - -;;; Define optimizers for FFLOOR and FCEILING -(macrolet - ((frob-opt (name q-name r-name) - (let ((q-aux (symbolicate "F" q-name "-AUX")) - (r-aux (symbolicate r-name "-AUX"))) - `(progn - ;; Compute type of quotient (first) result - (defun ,q-aux (number-type divisor-type) - (let* ((number-interval - (numeric-type->interval number-type)) - (divisor-interval - (numeric-type->interval divisor-type)) - (quot (,q-name (interval-div number-interval - divisor-interval))) - (res-type (numeric-contagion number-type divisor-type))) - (make-numeric-type - :class (numeric-type-class res-type) - :format (numeric-type-format res-type) - :low (interval-low quot) - :high (interval-high quot)))) - + ;; the optimizer itself (defoptimizer (,name derive-type) ((number divisor)) (flet ((derive-q (n d same-arg) (declare (ignore same-arg)) @@ -1850,12 +1678,55 @@ (when (and quot rem) (make-values-type :required (list quot rem)))))))))) - ;; FIXME: DEF-FROB-OPT, not just FROB-OPT - (frob-opt ffloor floor-quotient-bound floor-rem-bound) - (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound)) + (def floor floor-quotient-bound floor-rem-bound) + (def ceiling ceiling-quotient-bound ceiling-rem-bound)) -;;; Functions to compute the bounds on the quotient and remainder for -;;; the FLOOR function. +;;; Define optimizers for FFLOOR and FCEILING +(macrolet ((def (name q-name r-name) + (let ((q-aux (symbolicate "F" q-name "-AUX")) + (r-aux (symbolicate r-name "-AUX"))) + `(progn + ;; Compute type of quotient (first) result. + (defun ,q-aux (number-type divisor-type) + (let* ((number-interval + (numeric-type->interval number-type)) + (divisor-interval + (numeric-type->interval divisor-type)) + (quot (,q-name (interval-div number-interval + divisor-interval))) + (res-type (numeric-contagion number-type + divisor-type))) + (make-numeric-type + :class (numeric-type-class res-type) + :format (numeric-type-format res-type) + :low (interval-low quot) + :high (interval-high quot)))) + + (defoptimizer (,name derive-type) ((number divisor)) + (flet ((derive-q (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,q-aux n d) + *empty-type*)) + (derive-r (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,r-aux n d) + *empty-type*))) + (let ((quot (two-arg-derive-type + number divisor #'derive-q #',name)) + (rem (two-arg-derive-type + number divisor #'derive-r #'mod))) + (when (and quot rem) + (make-values-type :required (list quot rem)))))))))) + + (def ffloor floor-quotient-bound floor-rem-bound) + (def fceiling ceiling-quotient-bound ceiling-rem-bound)) + +;;; 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. @@ -1864,9 +1735,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 @@ -1887,7 +1758,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)) @@ -1897,7 +1768,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)) @@ -1905,11 +1776,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) @@ -1957,9 +1827,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 @@ -1978,7 +1848,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. @@ -1999,11 +1868,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) @@ -2049,10 +1917,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 @@ -2062,9 +1930,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) @@ -2092,7 +1960,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. @@ -2109,9 +1977,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) @@ -2169,13 +2037,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)) @@ -2185,21 +2053,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) @@ -2215,7 +2083,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)) @@ -2229,16 +2097,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)) @@ -2248,121 +2116,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) @@ -2372,7 +2125,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)) @@ -2418,15 +2171,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)))) @@ -2451,8 +2204,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) @@ -2460,58 +2213,78 @@ '*))))) ((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)) - -) ; PROGN + (deffrob logand) + (deffrob logior) + (deffrob logxor)) ;;;; miscellaneous derive-type methods +(defoptimizer (integer-length derive-type) ((x)) + (let ((x-type (continuation-type x))) + (when (and (numeric-type-p x-type) + (csubtypep x-type (specifier-type 'integer))) + ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH + ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be + ;; 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) + (and a b (min (integer-length a) + (integer-length b)))) + (null-or-max (a b) + (and a b (max (integer-length a) + (integer-length b))))) + (let* ((min (numeric-type-low x-type)) + (max (numeric-type-high x-type)) + (min-len (null-or-min min max)) + (max-len (null-or-max min max))) + (when (ctypep 0 x-type) + (setf min-len 0)) + (specifier-type `(integer ,(or min-len '*) ,(or max-len '*)))))))) + (defoptimizer (code-char derive-type) ((code)) (specifier-type 'base-char)) (defoptimizer (values derive-type) ((&rest values)) (values-specifier-type - `(values ,@(mapcar #'(lambda (x) - (type-specifier (continuation-type x))) + `(values ,@(mapcar (lambda (x) + (type-specifier (continuation-type x))) values)))) ;;;; 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))) @@ -2526,19 +2299,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)))) @@ -2547,7 +2320,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*))) @@ -2562,7 +2335,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*))) @@ -2582,7 +2355,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) @@ -2606,7 +2379,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) @@ -2617,55 +2390,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))))) @@ -2676,18 +2449,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" +(deftransform boole ((op x y) * *) + "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))) @@ -2715,7 +2488,7 @@ ;;;; converting special case multiply/divide to shifts ;;; If arg is a constant power of two, turn * into a shift. -(deftransform * ((x y) (integer integer) * :when :both) +(deftransform * ((x y) (integer integer) *) "convert x*2^k to shift" (unless (constant-continuation-p y) (give-up-ir1-transform)) @@ -2728,15 +2501,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)) @@ -2775,8 +2549,9 @@ (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)), do FLOOR and correct a +;;; remainder. (flet ((frob (y ceil-p) (unless (constant-continuation-p y) (give-up-ir1-transform)) @@ -2786,13 +2561,14 @@ (unless (= y-abs (ash 1 len)) (give-up-ir1-transform)) (let ((shift (- len)) - (mask (1- y-abs))) - `(let ,(when ceil-p `((x (+ x ,(1- y-abs))))) + (mask (1- y-abs)) + (delta (if ceil-p (* (signum y) (1- y-abs)) 0))) + `(let ((x (+ x ,delta))) ,(if (minusp y) `(values (ash (- x) ,shift) - (- (logand (- x) ,mask))) + (- (- (logand (- x) ,mask)) ,delta)) `(values (ash x ,shift) - (logand x ,mask)))))))) + (- (logand x ,mask) ,delta)))))))) (deftransform floor ((x y) (integer integer) *) "convert division by 2^k to shift" (frob y nil)) @@ -2801,7 +2577,7 @@ (frob y t))) ;;; Do the same for MOD. -(deftransform mod ((x y) (integer integer) * :when :both) +(deftransform mod ((x y) (integer integer) *) "convert remainder mod 2^k to LOGAND" (unless (constant-continuation-p y) (give-up-ir1-transform)) @@ -2838,7 +2614,7 @@ (logand x ,mask)))))) ;;; And the same for REM. -(deftransform rem ((x y) (integer integer) * :when :both) +(deftransform rem ((x y) (integer integer) *) "convert remainder mod 2^k to LOGAND" (unless (constant-continuation-p y) (give-up-ir1-transform)) @@ -2853,37 +2629,33 @@ (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 (name identity result) + `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *) + "fold identity operations" + ',result))) + (def ash 0 x) + (def logand -1 x) + (def logand 0 0) + (def logior 0 x) + (def logior -1 -1) + (def logxor -1 (lognot x)) + (def 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. -(deftransform - ((x y) ((constant-argument (member 0)) rational) * - :when :both) +(deftransform - ((x y) ((constant-arg (member 0)) rational) *) "convert (- 0 x) to negate" '(%negate y)) -(deftransform * ((x y) (rational (constant-argument (member 0))) * - :when :both) - "convert (* x 0) to 0." +(deftransform * ((x y) (rational (constant-arg (member 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)) @@ -2892,7 +2664,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) @@ -2917,9 +2689,9 @@ ;;; Fold (+ x 0). ;;; -;;; 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) +;;; If y is not constant, not zerop, or is contagious, or a positive +;;; float +0.0 then give up. +(deftransform + ((x y) (t (constant-arg t)) *) "fold zero arg" (let ((val (continuation-value y))) (unless (and (zerop val) @@ -2930,9 +2702,9 @@ ;;; Fold (- x 0). ;;; -;;; 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) +;;; If y is not constant, not zerop, or is contagious, or a negative +;;; float -0.0 then give up. +(deftransform - ((x y) (t (constant-arg t)) *) "fold zero arg" (let ((val (continuation-value y))) (unless (and (zerop val) @@ -2942,22 +2714,21 @@ '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 (name result minus-result) + `(deftransform ,name ((x y) (t (constant-arg real)) *) + "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 * x (%negate x)) + (def / x (%negate x)) + (def expt x (/ 1 x))) ;;; Fold (expt x n) into multiplications for small integral values of ;;; N; convert (expt x 1/2) to sqrt. -(deftransform expt ((x y) (t (constant-argument real)) *) +(deftransform expt ((x y) (t (constant-arg real)) *) "recode as multiplication or sqrt" (let ((val (continuation-value y))) ;; If Y would cause the result to be promoted to the same type as @@ -2978,18 +2749,24 @@ ;;; 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 (name) + `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer) + *) + "fold zero arg" + 0))) + (def ash) + (def /)) + +(macrolet ((def (name) + `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer) + *) + "fold zero arg" + '(values 0 0)))) + (def truncate) + (def round) + (def floor) + (def ceiling)) ;;;; character operations @@ -3021,8 +2798,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)) @@ -3032,48 +2810,53 @@ (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 - :when :both) +;;; 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) (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. -(deftransform eql ((x y) * * :when :both) +(macrolet ((def (x) + `(%deftransform ',x '(function * *) #'simple-equality-transform))) + (def eq) + (def char=) + (def 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) * *) "convert to simpler equality predicate" (let ((x-type (continuation-type x)) (y-type (continuation-type y)) (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) @@ -3085,7 +2868,7 @@ ;;; Convert to EQL if both args are rational and complexp is specified ;;; and the same for both. -(deftransform = ((x y) * * :when :both) +(deftransform = ((x y) * *) "open code" (let ((x-type (continuation-type x)) (y-type (continuation-type y))) @@ -3100,10 +2883,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 @@ -3111,7 +2896,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)) @@ -3119,17 +2904,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)) @@ -3137,42 +2922,42 @@ (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)) (t (give-up-ir1-transform)))))) -(deftransform < ((x y) (integer integer) * :when :both) +(deftransform < ((x y) (integer integer) *) (ir1-transform-< x y x y '>)) -(deftransform > ((x y) (integer integer) * :when :both) +(deftransform > ((x y) (integer integer) *) (ir1-transform-< y x x y '<)) -#!+propagate-float-type -(deftransform < ((x y) (float float) * :when :both) +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +(deftransform < ((x y) (float float) *) (ir1-transform-< x y x y '>)) -#!+propagate-float-type -(deftransform > ((x y) (float float) * :when :both) +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +(deftransform > ((x y) (float float) *) (ir1-transform-< y x x y '<)) ;;;; converting N-arg comparisons @@ -3204,34 +2989,39 @@ (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 +;;; functions such as /=. This is similar to MULTI-COMPARE in the <3 ;;; arg cases. If there are more than two args, then we expand into ;;; the appropriate n^2 comparisons only when speed is important. (declaim (ftype (function (symbol list) *) multi-not-equal)) @@ -3241,75 +3031,91 @@ ((= 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)) + +;;; FIXME: can go away once bug 194 is fixed and we can use (THE REAL X) +;;; as God intended +(defun error-not-a-real (x) + (error 'simple-type-error + :datum x + :expected-type 'real + :format-control "not a REAL: ~S" + :format-arguments (list x))) ;;; Expand MAX and MIN into the obvious comparisons. -(def-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) - (if (null more-args) - `(values ,arg) - (once-only ((arg1 arg) - (arg2 `(min ,@more-args))) - `(if (< ,arg1 ,arg2) - ,arg1 ,arg2)))) +(define-source-transform max (arg0 &rest rest) + (once-only ((arg0 arg0)) + (if (null rest) + `(values (the real ,arg0)) + `(let ((maxrest (max ,@rest))) + (if (> ,arg0 maxrest) ,arg0 maxrest))))) +(define-source-transform min (arg0 &rest rest) + (once-only ((arg0 arg0)) + (if (null rest) + `(values (the real ,arg0)) + `(let ((minrest (min ,@rest))) + (if (< ,arg0 minrest) ,arg0 minrest))))) ;;;; converting N-arg arithmetic functions ;;;; ;;;; 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. -(declaim (ftype (function (symbol t list) list) associate-arguments)) -(defun associate-arguments (function first-arg more-args) +;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION. +(declaim (ftype (function (symbol t list) list) associate-args)) +(defun associate-args (function first-arg more-args) (let ((next (rest more-args)) (arg (first more-args))) (if (null next) `(,function ,first-arg ,arg) - (associate-arguments function `(,function ,first-arg ,arg) next)))) + (associate-args function `(,function ,first-arg ,arg) next)))) ;;; 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 -;;; a call to that function. -(defun source-transform-transitive (fun args identity &optional leaf-fun) +;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to +;;; ensure (with THE) that the argument in one-argument calls is. +(defun source-transform-transitive (fun args identity + &optional one-arg-result-type) (declare (symbol fun leaf-fun) (list args)) (case (length args) (0 identity) - (1 `(values ,(first args))) - (2 (if leaf-fun - `(,leaf-fun ,(first args) ,(second args)) - (values nil t))) + (1 (if one-arg-result-type + `(values (the ,one-arg-result-type ,(first args))) + `(values ,(first args)))) + (2 (values nil t)) (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) + (associate-args fun (first args) (rest args))))) + +(define-source-transform + (&rest args) + (source-transform-transitive '+ args 0 'number)) +(define-source-transform * (&rest args) + (source-transform-transitive '* args 1 'number)) +(define-source-transform logior (&rest args) + (source-transform-transitive 'logior args 0 'integer)) +(define-source-transform logxor (&rest args) + (source-transform-transitive 'logxor args 0 'integer)) +(define-source-transform logand (&rest args) + (source-transform-transitive 'logand args -1 'integer)) + +(define-source-transform logeqv (&rest args) (if (evenp (length args)) `(lognot (logxor ,@args)) `(logxor ,@args))) @@ -3318,49 +3124,51 @@ ;;; 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))))) + (t (associate-args '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)))) (2 (values nil t)) - (t (associate-arguments 'lcm (first args) (rest args))))) + (t (associate-args 'lcm (first args) (rest args))))) ;;; Do source transformations for intransitive n-arg functions such as ;;; /. With one arg, we form the inverse. With two args we pass. ;;; Otherwise we associate into two-arg calls. -(declaim (ftype (function (symbol list t) list) source-transform-intransitive)) +(declaim (ftype (function (symbol list t) + (values list &optional (member nil t))) + source-transform-intransitive)) (defun source-transform-intransitive (function args inverse) (case (length args) ((0 2) (values nil t)) (1 `(,@inverse ,(first args))) - (t (associate-arguments function (first args) (rest args))))) + (t (associate-args 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) - `(values ,x)) + ,@(mapcar (lambda (x) + `(values ,x)) (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 @@ -3391,3 +3199,285 @@ (declare (ignore tee)) (funcall control *standard-output* ,@arg-names) nil))) + +(defoptimizer (coerce derive-type) ((value type)) + (cond + ((constant-continuation-p type) + ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2), + ;; but dealing with the niggle that complex canonicalization gets + ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of + ;; type COMPLEX. + (let* ((specifier (continuation-value type)) + (result-typeoid (careful-specifier-type specifier))) + (cond + ((null result-typeoid) nil) + ((csubtypep result-typeoid (specifier-type 'number)) + ;; the difficult case: we have to cope with ANSI 12.1.5.3 + ;; Rule of Canonical Representation for Complex Rationals, + ;; which is a truly nasty delivery to field. + (cond + ((csubtypep result-typeoid (specifier-type 'real)) + ;; cleverness required here: it would be nice to deduce + ;; that something of type (INTEGER 2 3) coerced to type + ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0). + ;; FLOAT gets its own clause because it's implemented as + ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE + ;; logic below. + result-typeoid) + ((and (numeric-type-p result-typeoid) + (eq (numeric-type-complexp result-typeoid) :real)) + ;; FIXME: is this clause (a) necessary or (b) useful? + result-typeoid) + ((or (csubtypep result-typeoid + (specifier-type '(complex single-float))) + (csubtypep result-typeoid + (specifier-type '(complex double-float))) + #!+long-float + (csubtypep result-typeoid + (specifier-type '(complex long-float)))) + ;; float complex types are never canonicalized. + result-typeoid) + (t + ;; if it's not a REAL, or a COMPLEX FLOAToid, it's + ;; probably just a COMPLEX or equivalent. So, in that + ;; case, we will return a complex or an object of the + ;; provided type if it's rational: + (type-union result-typeoid + (type-intersection (continuation-type value) + (specifier-type 'rational)))))) + (t result-typeoid)))) + (t + ;; OK, the result-type argument isn't constant. However, there + ;; are common uses where we can still do better than just + ;; *UNIVERSAL-TYPE*: e.g. (COERCE X (ARRAY-ELEMENT-TYPE Y)), + ;; where Y is of a known type. See messages on cmucl-imp + ;; 2001-02-14 and sbcl-devel 2002-12-12. We only worry here + ;; about types that can be returned by (ARRAY-ELEMENT-TYPE Y), on + ;; the basis that it's unlikely that other uses are both + ;; time-critical and get to this branch of the COND (non-constant + ;; second argument to COERCE). -- CSR, 2002-12-16 + (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: + ;; + ;; * Any REAL can be coerced to a FLOAT type. + ;; * Any NUMBER can be coerced to a (COMPLEX + ;; SINGLE/DOUBLE-FLOAT). + ;; + ;; FIXME I: we should also be able to deal with characters + ;; here. + ;; + ;; FIXME II: I'm not sure that anything is necessary + ;; here, at least while COMPLEX is not a specialized + ;; array element type in the system. Reasoning: if + ;; something cannot be coerced to the requested type, an + ;; error will be raised (and so any downstream compiled + ;; code on the assumption of the returned type is + ;; unreachable). If something can, then it will be of + ;; the requested type, because (by assumption) COMPLEX + ;; (and other difficult types like (COMPLEX INTEGER) + ;; aren't specialized types. + (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)))))) + (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), then (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 (compile derive-type) ((nameoid function)) + (when (csubtypep (continuation-type nameoid) + (specifier-type 'null)) + (values-specifier-type '(values function boolean boolean)))) + +;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving +;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE +;;; optimizer, above). +(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*))))) + +(define-source-transform sb!impl::sort-vector (vector start end predicate key) + `(macrolet ((%index (x) `(truly-the index ,x)) + (%parent (i) `(ash ,i -1)) + (%left (i) `(%index (ash ,i 1))) + (%right (i) `(%index (1+ (ash ,i 1)))) + (%heapify (i) + `(do* ((i ,i) + (left (%left i) (%left i))) + ((> left current-heap-size)) + (declare (type index i left)) + (let* ((i-elt (%elt i)) + (i-key (funcall keyfun i-elt)) + (left-elt (%elt left)) + (left-key (funcall keyfun left-elt))) + (multiple-value-bind (large large-elt large-key) + (if (funcall ,',predicate i-key left-key) + (values left left-elt left-key) + (values i i-elt i-key)) + (let ((right (%right i))) + (multiple-value-bind (largest largest-elt) + (if (> right current-heap-size) + (values large large-elt) + (let* ((right-elt (%elt right)) + (right-key (funcall keyfun right-elt))) + (if (funcall ,',predicate large-key right-key) + (values right right-elt) + (values large large-elt)))) + (cond ((= largest i) + (return)) + (t + (setf (%elt i) largest-elt + (%elt largest) i-elt + i largest))))))))) + (%sort-vector (keyfun &optional (vtype 'vector)) + `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting + ;; type inference to propagate all the way + ;; through this tangled mess of + ;; inlining. The TRULY-THE here works + ;; around that. -- WHN + (%elt (i) + `(aref (truly-the ,',vtype ,',',vector) + (%index (+ (%index ,i) start-1))))) + (let ((start-1 (1- ,',start)) ; Heaps prefer 1-based addressing. + (current-heap-size (- ,',end ,',start)) + (keyfun ,keyfun)) + (declare (type (integer -1 #.(1- most-positive-fixnum)) + start-1)) + (declare (type index current-heap-size)) + (declare (type function keyfun)) + (loop for i of-type index + from (ash current-heap-size -1) downto 1 do + (%heapify i)) + (loop + (when (< current-heap-size 2) + (return)) + (rotatef (%elt 1) (%elt current-heap-size)) + (decf current-heap-size) + (%heapify 1)))))) + (if (typep ,vector 'simple-vector) + ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is + ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA. + (if (null ,key) + ;; Special-casing the KEY=NIL case lets us avoid some + ;; function calls. + (%sort-vector #'identity simple-vector) + (%sort-vector ,key simple-vector)) + ;; It's hard to anticipate many speed-critical applications for + ;; sorting vector types other than (VECTOR T), so we just lump + ;; them all together in one slow dynamically typed mess. + (locally + (declare (optimize (speed 2) (space 2) (inhibit-warnings 3))) + (%sort-vector (or ,key #'identity)))))) + +;;;; 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))))