X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=363e3c69016bffa2480e291314af63473ca6d755;hb=5d0643d3b70aade43037e8b7cdf39b7e12f5d3fd;hp=b82e87ce535eb21a23db35247c80f515cea84d19;hpb=591f88ee8323e7ac196b43fb7949227079674ca5;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index b82e87c..363e3c6 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -29,12 +29,14 @@ (define-source-transform identity (x) `(prog1 ,x)) (define-source-transform values (x) `(prog1 ,x)) -;;; Bind the values and make a closure that returns them. +;;; Bind the value and make a closure that returns it. (define-source-transform constantly (value) - (let ((rest (gensym "CONSTANTLY-REST-"))) - `(lambda (&rest ,rest) - (declare (ignore ,rest)) - ,value))) + (let ((rest (gensym "CONSTANTLY-REST-")) + (n-value (gensym "CONSTANTLY-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 @@ -258,6 +260,7 @@ ;;; 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 @@ -688,7 +691,8 @@ ;;; 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))) @@ -1072,6 +1076,7 @@ ;;; 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)) + (declare (type function derive-fcn fcn)) #!+negative-zero-is-not-zero (declare (ignore convert-type)) (flet (#!-negative-zero-is-not-zero @@ -1342,16 +1347,19 @@ ) ; 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 - (defun ash-derive-type-aux (n-type shift same-arg) (declare (ignore same-arg)) + ;; 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) @@ -1384,7 +1392,6 @@ (defoptimizer (ash derive-type) ((n shift)) (two-arg-derive-type n shift #'ash-derive-type-aux #'ash)) -) ; PROGN #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (macrolet ((frob (fun) @@ -2584,7 +2591,8 @@ (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. +;;; 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)) @@ -2594,13 +2602,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)) @@ -3233,83 +3242,159 @@ nil))) (defoptimizer (coerce derive-type) ((value type)) - (let ((value-type (continuation-type value)) - (type-type (continuation-type type))) - (labels - ((good-cons-type-p (cons-type) - ;; Make sure the cons-type we're looking at is something - ;; we're prepared to handle which is basically something - ;; that array-element-type can return. - (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) - (null (first (member-type-members cons-type)))) - (let ((car-type (cons-type-car-type cons-type))) - (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members car-type))) - (numberp (first (first (member-type-members - car-type)))))) - (good-cons-type-p (cons-type-cdr-type cons-type)))))) - (unconsify-type (good-cons-type) - ;; Convert the "printed" respresentation of a cons - ;; specifier into a type specifier. That is, the specifier - ;; (cons (eql signed-byte) (cons (eql 16) null)) is - ;; converted to (signed-byte 16). - (cond ((or (null good-cons-type) - (eq good-cons-type 'null)) - nil) - ((and (eq (first good-cons-type) 'cons) - (eq (first (second good-cons-type)) 'member)) - `(,(second (second good-cons-type)) - ,@(unconsify-type (caddr good-cons-type)))))) - (coerceable-p (c-type) - ;; Can the value be coerced to the given type? Coerce is - ;; complicated, so we don't handle every possible case - ;; here---just the most common and easiest cases: - ;; - ;; o Any real can be coerced to a float type. - ;; o Any number can be coerced to a complex single/double-float. - ;; o An integer can be coerced to an integer. - (let ((coerced-type c-type)) - (or (and (subtypep coerced-type 'float) - (csubtypep value-type (specifier-type 'real))) - (and (subtypep coerced-type - '(or (complex single-float) - (complex double-float))) - (csubtypep value-type (specifier-type 'number))) - (and (subtypep coerced-type 'integer) - (csubtypep value-type (specifier-type 'integer)))))) - (process-types (type) - ;; FIXME: - ;; This needs some work because we should be able to derive - ;; the resulting type better than just the type arg of - ;; coerce. That is, if x is (integer 10 20), the (coerce x - ;; 'double-float) should say (double-float 10d0 20d0) - ;; instead of just double-float. - (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) - ((and (cons-type-p type) - (good-cons-type-p type)) - (let ((c-type (unconsify-type (type-specifier type)))) - (if (coerceable-p c-type) - (specifier-type c-type) - *universal-type*))) - (t - *universal-type*)))) - (cond ((union-type-p type-type) - (apply #'type-union (mapcar #'process-types - (union-type-types type-type)))) - ((or (member-type-p type-type) - (cons-type-p type-type)) - (process-types type-type)) - (t - *universal-type*))))) + (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) @@ -3334,6 +3419,79 @@ (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