(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
(give-up-ir1-transform
"The function doesn't have a fixed argument count.")))))
\f
+;;;; 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))
+\f
;;;; list hackery
;;; Translate CxR into CAR/CDR combos.
(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)
(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
(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)
(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
(setf results (append results result))
(push result results))))))
(if (rest results)
- (make-canonical-union-type results)
+ (make-derived-union-type results)
(first results)))))))
\f
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
`(- (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.
`(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 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) ->
+;;; (ASH (%MULTIPLY (ASH X 0) 14757395258967641293) -3)
+;;;
+;;; (UNSIGNED-DIV-TRANSFORMER 7) ->
+;;; (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)
+ (declare (type (integer 3 #.most-positive-word) y))
+ (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))
+ (shift1 0))
+ (multiple-value-bind (m shift2)
+ (choose-multiplier y sb!vm:n-word-bits)
+ (when (and (>= m n) (evenp y))
+ (setq shift1 (ld (logand y (- y))))
+ (multiple-value-setq (m shift2)
+ (choose-multiplier (/ y (ash 1 shift1))
+ (- sb!vm:n-word-bits shift1))))
+ (if (>= m n)
+ (flet ((word-mod (x)
+ `(ldb (byte #.sb!vm:n-word-bits 0) ,x)))
+ `(let* ((num x)
+ (t1 (%multiply num ,(- m n))))
+ (ash ,(word-mod `(+ t1 (ash ,(word-mod `(- num t1))
+ -1)))
+ ,(- 1 shift2))))
+ `(ash (%multiply (ash x ,(- shift1)) ,m)
+ ,(- 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) ((unsigned-byte #.sb!vm:n-word-bits)
+ (constant-arg
+ (unsigned-byte #.sb!vm:n-word-bits)))
+ *
+ :policy (and (> speed compilation-speed)
+ (> speed space)))
+ "convert integer division to multiplication"
+ (let ((y (lvar-value y)))
+ ;; 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))
+ (rem (ldb (byte #.sb!vm:n-word-bits 0)
+ (- x (* quot ,y)))))
+ (values quot rem))))
\f
;;;; arithmetic and logical identity operation elimination
;;;; 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)
(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)))
\f
;;;; transforming APPLY
(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)))))))
+
\f
;;;; transforming FORMAT
;;;;
: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),
(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
projects / sbcl.git / blobdiff