X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=cc7cb91bfe837c973b77768aabdf3a539a444f5d;hb=0dda5090b6c16a641000b4eb2dcd479f39b784ca;hp=764e617bd993695cfd7c89b2e059d236c9c83356;hpb=672b2f6cb751566526c7f3bb3de6b7d8424760e2;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 764e617..cc7cb91 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -29,13 +29,11 @@ (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)))) + +;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type. +(defoptimizer (constantly derive-type) ((value)) + (specifier-type + `(function (&rest t) (values ,(type-specifier (lvar-type value)) &optional)))) ;;; If the function has a known number of arguments, then return a ;;; lambda with the appropriate fixed number of args. If the @@ -59,6 +57,26 @@ (give-up-ir1-transform "The function doesn't have a fixed argument count."))))) +;;;; SYMBOL-VALUE &co +(defun derive-symbol-value-type (lvar node) + (if (constant-lvar-p lvar) + (let* ((sym (lvar-value lvar)) + (var (maybe-find-free-var sym)) + (local-type (when var + (let ((*lexenv* (node-lexenv node))) + (lexenv-find var type-restrictions)))) + (global-type (info :variable :type sym))) + (if local-type + (type-intersection local-type global-type) + global-type)) + *universal-type*)) + +(defoptimizer (symbol-value derive-type) ((symbol) node) + (derive-symbol-value-type symbol node)) + +(defoptimizer (symbol-global-value derive-type) ((symbol) node) + (derive-symbol-value-type symbol node)) + ;;;; list hackery ;;; Translate CxR into CAR/CDR combos. @@ -332,15 +350,20 @@ (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 (type-bound-number x)))) - (if (and (floatp y) - (float-infinity-p y)) - nil - (set-bound y (consp x))))))) + (handler-case + (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 (type-bound-number x)))) + (if (and (floatp y) + (float-infinity-p y)) + nil + (set-bound y (consp x))))) + ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g. + ;; in the course of converting a bignum to a float. Default to + ;; NIL in that case. + (simple-type-error ())))) (defun safe-double-coercion-p (x) (or (typep x 'double-float) @@ -401,11 +424,38 @@ (t (,op ,x ,y)))) (defmacro bound-binop (op x y) - `(and ,x ,y - (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - (set-bound (safely-binop ,op (type-bound-number ,x) - (type-bound-number ,y)) - (or (consp ,x) (consp ,y)))))) + (with-unique-names (xb yb res) + `(and ,x ,y + (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) + (let* ((,xb (type-bound-number ,x)) + (,yb (type-bound-number ,y)) + (,res (safely-binop ,op ,xb ,yb))) + (set-bound ,res + (and (or (consp ,x) (consp ,y)) + ;; Open bounds can very easily be messed up + ;; by FP rounding, so take care here. + ,(case op + (* + ;; Multiplying a greater-than-zero with + ;; less than one can round to zero. + `(or (not (fp-zero-p ,res)) + (cond ((and (consp ,x) (fp-zero-p ,xb)) + (>= (abs ,yb) 1)) + ((and (consp ,y) (fp-zero-p ,yb)) + (>= (abs ,xb) 1))))) + (/ + ;; Dividing a greater-than-zero with + ;; greater than one can round to zero. + `(or (not (fp-zero-p ,res)) + (cond ((and (consp ,x) (fp-zero-p ,xb)) + (<= (abs ,yb) 1)) + ((and (consp ,y) (fp-zero-p ,yb)) + (<= (abs ,xb) 1))))) + ((+ -) + ;; Adding or subtracting greater-than-zero + ;; can end up with identity. + `(and (not (fp-zero-p ,xb)) + (not (fp-zero-p ,yb)))))))))))) (defun coerce-for-bound (val type) (if (consp val) @@ -1096,7 +1146,7 @@ (t ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0))) ;; (float x -0.0) => (or (member -0.0) (float x (0.0))) - (list (make-member-type :members (list (float -0.0 hi-val))) + (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))) (make-numeric-type :class (numeric-type-class type) :format (numeric-type-format type) :complexp :real @@ -1127,21 +1177,26 @@ (t type-list))) -;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably -;;; belong in the kernel's type logic, invoked always, instead of in -;;; the compiler, invoked only during some type optimizations. (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 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) +;;; +;;; If we're about to generate an overly complex union of numeric types, start +;;; collapse the ranges together. +;;; +;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and +;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic, +;;; invoked always, instead of in the compiler, invoked only during some type +;;; optimizations. +(defvar *derived-numeric-union-complexity-limit* 6) + +(defun make-derived-union-type (type-list) (let ((xset (alloc-xset)) (fp-zeroes '()) - (misc-types '())) + (misc-types '()) + (numeric-type *empty-type*)) (dolist (type type-list) (cond ((member-type-p type) (mapc-member-type-members @@ -1151,11 +1206,19 @@ (pushnew member fp-zeroes)) (add-to-xset member xset))) type)) + ((numeric-type-p type) + (let ((*approximate-numeric-unions* + (when (and (union-type-p numeric-type) + (nthcdr *derived-numeric-union-complexity-limit* + (union-type-types numeric-type))) + t))) + (setf numeric-type (type-union type numeric-type)))) (t (push type misc-types)))) (if (and (xset-empty-p xset) (not fp-zeroes)) - (apply #'type-union misc-types) - (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types)))) + (apply #'type-union numeric-type misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) + numeric-type misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -1220,7 +1283,7 @@ (setf results (append results result)) (push result results)))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes @@ -1293,7 +1356,7 @@ (setf results (append results result)) (push result results)))))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) @@ -1789,6 +1852,16 @@ #'%unary-truncate-derive-type-aux #'%unary-truncate)) +(defoptimizer (%unary-truncate/single-float derive-type) ((number)) + (one-arg-derive-type number + #'%unary-truncate-derive-type-aux + #'%unary-truncate)) + +(defoptimizer (%unary-truncate/double-float derive-type) ((number)) + (one-arg-derive-type number + #'%unary-truncate-derive-type-aux + #'%unary-truncate)) + (defoptimizer (%unary-ftruncate derive-type) ((number)) (let ((divisor (specifier-type '(integer 1 1)))) (one-arg-derive-type number @@ -1796,6 +1869,28 @@ (ftruncate-derive-type-quot-aux n divisor nil)) #'%unary-ftruncate))) +(defoptimizer (%unary-round derive-type) ((number)) + (one-arg-derive-type number + (lambda (n) + (block nil + (unless (numeric-type-real-p n) + (return *empty-type*)) + (let* ((interval (numeric-type->interval n)) + (low (interval-low interval)) + (high (interval-high interval))) + (when (consp low) + (setf low (car low))) + (when (consp high) + (setf high (car high))) + (specifier-type + `(integer ,(if low + (round low) + '*) + ,(if high + (round high) + '*)))))) + #'%unary-round)) + ;;; Define optimizers for FLOOR and CEILING. (macrolet ((def (name q-name r-name) @@ -2616,6 +2711,27 @@ (hi-res (if hi (isqrt hi) '*))) (specifier-type `(integer ,lo-res ,hi-res)))))) +(defoptimizer (char-code derive-type) ((char)) + (let ((type (type-intersection (lvar-type char) (specifier-type 'character)))) + (cond ((member-type-p type) + (specifier-type + `(member + ,@(loop for member in (member-type-members type) + when (characterp member) + collect (char-code member))))) + ((sb!kernel::character-set-type-p type) + (specifier-type + `(or + ,@(loop for (low . high) + in (character-set-type-pairs type) + collect `(integer ,low ,high))))) + ((csubtypep type (specifier-type 'base-char)) + (specifier-type + `(mod ,base-char-code-limit))) + (t + (specifier-type + `(mod ,char-code-limit)))))) + (defoptimizer (code-char derive-type) ((code)) (let ((type (lvar-type code))) ;; FIXME: unions of integral ranges? It ought to be easier to do @@ -3075,6 +3191,15 @@ `(- (ash x ,len)) `(ash x ,len)))) +;;; These must come before the ones below, so that they are tried +;;; first. Since %FLOOR and %CEILING are inlined, this allows +;;; the general case to be handled by TRUNCATE transforms. +(deftransform floor ((x y)) + `(%floor x y)) + +(deftransform ceiling ((x y)) + `(%ceiling x y)) + ;;; 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. @@ -3153,6 +3278,113 @@ `(if (minusp x) (- (logand (- x) ,mask)) (logand x ,mask))))) + +;;; Return an expression to calculate the integer quotient of X and +;;; constant Y, using multiplication, shift and add/sub instead of +;;; division. Both arguments must be unsigned, fit in a machine word and +;;; Y must neither be zero nor a power of two. The quotient is rounded +;;; towards zero. +;;; The algorithm is taken from the paper "Division by Invariant +;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and +;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the +;;; case of division by powers of two. +;;; The algorithm includes an adaptive precision argument. Use it, since +;;; we often have sub-word value ranges. Careful, in this case, we need +;;; p s.t 2^p > n, not the ceiling of the binary log. +;;; Also, for some reason, the paper prefers shifting to masking. Mask +;;; instead. Masking is equivalent to shifting right, then left again; +;;; all the intermediate values are still words, so we just have to shift +;;; right a bit more to compensate, at the end. +;;; +;;; The following two examples show an average case and the worst case +;;; with respect to the complexity of the generated expression, under +;;; a word size of 64 bits: +;;; +;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) -> +;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3) +;;; +;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) -> +;;; (LET* ((NUM X) +;;; (T1 (%MULTIPLY NUM 2635249153387078803))) +;;; (ASH (LDB (BYTE 64 0) +;;; (+ T1 (ASH (LDB (BYTE 64 0) +;;; (- NUM T1)) +;;; -1))) +;;; -2)) +;;; +(defun gen-unsigned-div-by-constant-expr (y max-x) + (declare (type (integer 3 #.most-positive-word) y) + (type word max-x)) + (aver (not (zerop (logand y (1- y))))) + (labels ((ld (x) + ;; the floor of the binary logarithm of (positive) X + (integer-length (1- x))) + (choose-multiplier (y precision) + (do* ((l (ld y)) + (shift l (1- shift)) + (expt-2-n+l (expt 2 (+ sb!vm:n-word-bits l))) + (m-low (truncate expt-2-n+l y) (ash m-low -1)) + (m-high (truncate (+ expt-2-n+l + (ash expt-2-n+l (- precision))) + y) + (ash m-high -1))) + ((not (and (< (ash m-low -1) (ash m-high -1)) + (> shift 0))) + (values m-high shift))))) + (let ((n (expt 2 sb!vm:n-word-bits)) + (precision (integer-length max-x)) + (shift1 0)) + (multiple-value-bind (m shift2) + (choose-multiplier y precision) + (when (and (>= m n) (evenp y)) + (setq shift1 (ld (logand y (- y)))) + (multiple-value-setq (m shift2) + (choose-multiplier (/ y (ash 1 shift1)) + (- precision shift1)))) + (cond ((>= m n) + (flet ((word (x) + `(truly-the word ,x))) + `(let* ((num x) + (t1 (%multiply-high num ,(- m n)))) + (ash ,(word `(+ t1 (ash ,(word `(- num t1)) + -1))) + ,(- 1 shift2))))) + ((and (zerop shift1) (zerop shift2)) + (let ((max (truncate max-x y))) + ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM + ;; VOP. + `(truly-the (integer 0 ,max) + (%multiply-high x ,m)))) + (t + `(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m) + ,(- (+ shift1 shift2))))))))) + +;;; If the divisor is constant and both args are positive and fit in a +;;; machine word, replace the division by a multiplication and possibly +;;; some shifts and an addition. Calculate the remainder by a second +;;; multiplication and a subtraction. Dead code elimination will +;;; suppress the latter part if only the quotient is needed. If the type +;;; of the dividend allows to derive that the quotient will always have +;;; the same value, emit much simpler code to handle that. (This case +;;; may be rare but it's easy to detect and the compiler doesn't find +;;; this optimization on its own.) +(deftransform truncate ((x y) (word (constant-arg word)) + * + :policy (and (> speed compilation-speed) + (> speed space))) + "convert integer division to multiplication" + (let* ((y (lvar-value y)) + (x-type (lvar-type x)) + (max-x (or (and (numeric-type-p x-type) + (numeric-type-high x-type)) + most-positive-word))) + ;; Division by zero, one or powers of two is handled elsewhere. + (when (zerop (logand y (1- y))) + (give-up-ir1-transform)) + `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x)) + (rem (ldb (byte #.sb!vm:n-word-bits 0) + (- x (* quot ,y))))) + (values quot rem)))) ;;;; arithmetic and logical identity operation elimination @@ -3231,41 +3463,32 @@ (values (type= (numeric-contagion x y) (numeric-contagion y y))))))) +(def!type exact-number () + '(or rational (complex rational))) + ;;; 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-arg t)) *) +;;; Only safely applicable for exact numbers. For floating-point +;;; x, one would have to first show that neither x or y are signed +;;; 0s, and that x isn't an SNaN. +(deftransform + ((x y) (exact-number (constant-arg (eql 0))) *) "fold zero arg" - (let ((val (lvar-value y))) - (unless (and (zerop val) - (not (and (floatp val) (plusp (float-sign val)))) - (not-more-contagious y x)) - (give-up-ir1-transform))) 'x) ;;; 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-arg t)) *) +(deftransform - ((x y) (exact-number (constant-arg (eql 0))) *) "fold zero arg" - (let ((val (lvar-value y))) - (unless (and (zerop val) - (not (and (floatp val) (minusp (float-sign val)))) - (not-more-contagious y x)) - (give-up-ir1-transform))) 'x) ;;; Fold (OP x +/-1) -(macrolet ((def (name result minus-result) - `(deftransform ,name ((x y) (t (constant-arg real)) *) - "fold identity operations" - (let ((val (lvar-value y))) - (unless (and (= (abs val) 1) - (not-more-contagious y x)) - (give-up-ir1-transform)) - (if (minusp val) ',minus-result ',result))))) +;;; +;;; %NEGATE might not always signal correctly. +(macrolet + ((def (name result minus-result) + `(deftransform ,name ((x y) + (exact-number (constant-arg (member 1 -1)))) + "fold identity operations" + (if (minusp (lvar-value y)) ',minus-result ',result)))) (def * x (%negate x)) (def / x (%negate x)) (def expt x (/ 1 x))) @@ -3302,6 +3525,15 @@ ((= val -1/2) '(/ (sqrt x))) (t (give-up-ir1-transform))))) +(deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *) + "recode as an ODDP check" + (let ((val (lvar-value x))) + (if (eql -1 val) + '(- 1 (* 2 (logand 1 y))) + `(if (oddp y) + ,val + ,(abs val))))) + ;;; 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 @@ -3392,10 +3624,6 @@ (def eq) (def char=)) -;;; True if EQL comparisons involving type can be simplified to EQ. -(defun eq-comparable-type-p (type) - (csubtypep type (specifier-type '(or fixnum (not number))))) - ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, 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 @@ -3473,7 +3701,13 @@ (cond ((or (and (csubtypep x-type (specifier-type 'float)) (csubtypep y-type (specifier-type 'float))) (and (csubtypep x-type (specifier-type '(complex float))) - (csubtypep y-type (specifier-type '(complex float))))) + (csubtypep y-type (specifier-type '(complex float)))) + #!+complex-float-vops + (and (csubtypep x-type (specifier-type '(or single-float (complex single-float)))) + (csubtypep y-type (specifier-type '(or single-float (complex single-float))))) + #!+complex-float-vops + (and (csubtypep x-type (specifier-type '(or double-float (complex double-float)))) + (csubtypep y-type (specifier-type '(or double-float (complex double-float)))))) ;; They are both floats. Leave as = so that -0.0 is ;; handled correctly. (give-up-ir1-transform)) @@ -3688,34 +3922,57 @@ ;;;; versions, and degenerate cases are flushed. ;;; 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) +(declaim (ftype (sfunction (symbol t list t) list) associate-args)) +(defun associate-args (fun first-arg more-args identity) (let ((next (rest more-args)) (arg (first more-args))) (if (null next) - `(,function ,first-arg ,arg) - (associate-args function `(,function ,first-arg ,arg) next)))) + `(,fun ,first-arg ,(if arg arg identity)) + (associate-args fun `(,fun ,first-arg ,arg) next identity)))) + +;;; Reduce constants in ARGS list. +(declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants)) +(defun reduce-constants (fun args identity one-arg-result-type) + (let ((one-arg-constant-p (ecase one-arg-result-type + (number #'numberp) + (integer #'integerp))) + (reduced-value identity) + (reduced-p nil)) + (collect ((not-constants)) + (dolist (arg args) + (if (funcall one-arg-constant-p arg) + (setf reduced-value (funcall fun reduced-value arg) + reduced-p t) + (not-constants arg))) + ;; It is tempting to drop constants reduced to identity here, + ;; but if X is SNaN in (* X 1), we cannot drop the 1. + (if (not-constants) + (if reduced-p + `(,reduced-value ,@(not-constants)) + (not-constants)) + `(,reduced-value))))) ;;; Do source transformations for transitive functions such as +. ;;; One-arg cases are replaced with the arg and zero arg cases with -;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to -;;; ensure (with THE) that the argument in one-argument calls is. +;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE) +;;; that the argument in one-argument calls is. +(declaim (ftype (function (symbol list t &optional symbol list) + (values t &optional (member nil t))) + source-transform-transitive)) (defun source-transform-transitive (fun args identity - &optional one-arg-result-type) - (declare (symbol fun) (list args)) + &optional (one-arg-result-type 'number) + (one-arg-prefixes '(values))) (case (length args) (0 identity) - (1 (if one-arg-result-type - `(values (the ,one-arg-result-type ,(first args))) - `(values ,(first args)))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) (2 (values nil t)) - (t - (associate-args fun (first args) (rest args))))) + (t (let ((reduced-args (reduce-constants fun args identity one-arg-result-type))) + (associate-args fun (first reduced-args) (rest reduced-args) identity))))) (define-source-transform + (&rest args) - (source-transform-transitive '+ args 0 'number)) + (source-transform-transitive '+ args 0)) (define-source-transform * (&rest args) - (source-transform-transitive '* args 1 'number)) + (source-transform-transitive '* args 1)) (define-source-transform logior (&rest args) (source-transform-transitive 'logior args 0 'integer)) (define-source-transform logxor (&rest args) @@ -3724,41 +3981,30 @@ (source-transform-transitive 'logand args -1 'integer)) (define-source-transform logeqv (&rest args) (source-transform-transitive 'logeqv args -1 'integer)) - -;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM -;;; because when they are given one argument, they return its absolute -;;; value. - (define-source-transform gcd (&rest args) - (case (length args) - (0 0) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'gcd (first args) (rest args))))) - + (source-transform-transitive 'gcd args 0 'integer '(abs))) (define-source-transform lcm (&rest args) - (case (length args) - (0 1) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'lcm (first args) (rest args))))) + (source-transform-transitive 'lcm args 1 'integer '(abs))) ;;; 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) +(declaim (ftype (function (symbol symbol list t list &optional symbol) (values list &optional (member nil t))) source-transform-intransitive)) -(defun source-transform-intransitive (function args inverse) +(defun source-transform-intransitive (fun fun* args identity one-arg-prefixes + &optional (one-arg-result-type 'number)) (case (length args) ((0 2) (values nil t)) - (1 `(,@inverse ,(first args))) - (t (associate-args function (first args) (rest args))))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) + (t (let ((reduced-args + (reduce-constants fun* (rest args) identity one-arg-result-type))) + (associate-args fun (first args) reduced-args identity))))) (define-source-transform - (&rest args) - (source-transform-intransitive '- args '(%negate))) + (source-transform-intransitive '- '+ args 0 '(%negate))) (define-source-transform / (&rest args) - (source-transform-intransitive '/ args '(/ 1))) + (source-transform-intransitive '/ '* args 1 '(/ 1))) ;;;; transforming APPLY @@ -3768,10 +4014,60 @@ (define-source-transform apply (fun arg &rest more-args) (let ((args (cons arg more-args))) `(multiple-value-call ,fun - ,@(mapcar (lambda (x) - `(values ,x)) - (butlast args)) + ,@(mapcar (lambda (x) `(values ,x)) (butlast args)) (values-list ,(car (last args)))))) + +;;; When &REST argument are at play, we also have extra context and count +;;; arguments -- convert to %VALUES-LIST-OR-CONTEXT when possible, so that the +;;; deftransform can decide what to do after everything has been converted. +(define-source-transform values-list (list) + (if (symbolp list) + (let* ((var (lexenv-find list vars)) + (info (when (lambda-var-p var) + (lambda-var-arg-info var)))) + (if (and info + (eq :rest (arg-info-kind info)) + (consp (arg-info-default info))) + (destructuring-bind (context count &optional used) (arg-info-default info) + (declare (ignore used)) + `(%values-list-or-context ,list ,context ,count)) + (values nil t))) + (values nil t))) + +(deftransform %values-list-or-context ((list context count) * * :node node) + (let* ((use (lvar-use list)) + (var (when (ref-p use) (ref-leaf use))) + (home (when (lambda-var-p var) (lambda-var-home var))) + (info (when (lambda-var-p var) (lambda-var-arg-info var)))) + (flet ((ref-good-for-more-context-p (ref) + (let ((dest (principal-lvar-end (node-lvar ref)))) + (and (combination-p dest) + ;; Uses outside VALUES-LIST will require a &REST list anyways, + ;; to it's no use saving effort here -- plus they might modify + ;; the list destructively. + (eq '%values-list-or-context (lvar-fun-name (combination-fun dest))) + ;; If the home lambda is different and isn't DX, it might + ;; escape -- in which case using the more context isn't safe. + (let ((clambda (node-home-lambda dest))) + (or (eq home clambda) + (leaf-dynamic-extent clambda))))))) + (let ((context-ok + (and info + (consp (arg-info-default info)) + (not (lambda-var-specvar var)) + (not (lambda-var-sets var)) + (every #'ref-good-for-more-context-p (lambda-var-refs var)) + (policy node (= 3 rest-conversion))))) + (cond (context-ok + (destructuring-bind (context count &optional used) (arg-info-default info) + (declare (ignore used)) + (setf (arg-info-default info) (list context count t))) + `(%more-arg-values context 0 count)) + (t + (when info + (setf (arg-info-default info) t)) + `(values-list list))))))) + ;;;; transforming FORMAT ;;;; @@ -3820,7 +4116,7 @@ ;;; error messages, and those don't need to be particularly fast. #+sb-xc (deftransform format ((dest control &rest args) (t simple-string &rest t) * - :policy (> speed space)) + :policy (>= speed space)) (unless (constant-lvar-p control) (give-up-ir1-transform "The control string is not a constant.")) (let ((arg-names (make-gensym-list (length args)))) @@ -3828,15 +4124,13 @@ (declare (ignore control)) (format dest (formatter ,(lvar-value control)) ,@arg-names)))) -(deftransform format ((stream control &rest args) (stream function &rest t) * - :policy (> speed space)) +(deftransform format ((stream control &rest args) (stream function &rest t)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (stream control ,@arg-names) (funcall control stream ,@arg-names) nil))) -(deftransform format ((tee control &rest args) ((member t) function &rest t) * - :policy (> speed space)) +(deftransform format ((tee control &rest args) ((member t) function &rest t)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (tee control ,@arg-names) (declare (ignore tee)) @@ -3903,7 +4197,7 @@ :format-arguments (list nargs 'cerror y x (max max1 max2)))))))))))))) -(defoptimizer (coerce derive-type) ((value type)) +(defoptimizer (coerce derive-type) ((value type) node) (cond ((constant-lvar-p type) ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2), @@ -3948,7 +4242,17 @@ (type-union result-typeoid (type-intersection (lvar-type value) (specifier-type 'rational)))))) - (t result-typeoid)))) + ((and (policy node (zerop safety)) + (csubtypep result-typeoid (specifier-type '(array * (*))))) + ;; At zero safety the deftransform for COERCE can elide dimension + ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we + ;; need to simplify the type to drop the dimension information. + (let ((vtype (simplify-vector-type result-typeoid))) + (if vtype + (specifier-type vtype) + result-typeoid))) + (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 @@ -3990,7 +4294,7 @@ (eq (first (second good-cons-type)) 'member)) `(,(second (second good-cons-type)) ,@(unconsify-type (caddr good-cons-type)))))) - (coerceable-p (c-type) + (coerceable-p (part) ;; 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: @@ -4012,13 +4316,14 @@ ;; 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)))))) + (let ((coerced-type (careful-specifier-type part))) + (when coerced-type + (or (and (csubtypep coerced-type (specifier-type 'float)) + (csubtypep value-type (specifier-type 'real))) + (and (csubtypep coerced-type + (specifier-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 @@ -4078,19 +4383,16 @@ (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*))))) + (labels ((recurse (type) + (cond ((array-type-p type) + (get-element-type type)) + ((union-type-p type) + (apply #'type-union + (mapcar #'recurse (union-type-types type)))) + (t + *universal-type*)))) + (recurse array-type))))) -;;; Like CMU CL, we use HEAPSORT. However, other than that, this code -;;; isn't really related to the CMU CL code, since instead of trying -;;; to generalize the CMU CL code to allow START and END values, this -;;; code has been written from scratch following Chapter 7 of -;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. (define-source-transform sb!impl::sort-vector (vector start end predicate key) ;; Like CMU CL, we use HEAPSORT. However, other than that, this code ;; isn't really related to the CMU CL code, since instead of trying @@ -4142,7 +4444,7 @@ (start-1 (1- ,',start)) (current-heap-size (- ,',end ,',start)) (keyfun ,keyfun)) - (declare (type (integer -1 #.(1- most-positive-fixnum)) + (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum)) start-1)) (declare (type index current-heap-size)) (declare (type function keyfun))