(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
(t (values nil t))))
;;; And similarly for LIST*.
-(define-source-transform list* (&rest args)
- (case (length args)
- (2 `(cons ,(first args) ,(second args)))
- (t (values nil t))))
+(define-source-transform list* (arg &rest others)
+ (cond ((not others) arg)
+ ((not (cdr others)) `(cons ,arg ,(car others)))
+ (t (values nil t))))
+
+(defoptimizer (list* derive-type) ((arg &rest args))
+ (if args
+ (specifier-type 'cons)
+ (lvar-type arg)))
;;; Translate RPLACx to LET and SETF.
(define-source-transform rplaca (x y)
(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
-(define-source-transform last (x) `(sb!impl::last1 ,x))
+(deftransform last ((list &optional n) (t &optional t))
+ (let ((c (constant-lvar-p n)))
+ (cond ((or (not n)
+ (and c (eql 1 (lvar-value n))))
+ '(%last1 list))
+ ((and c (eql 0 (lvar-value n)))
+ '(%last0 list))
+ (t
+ (let ((type (lvar-type n)))
+ (cond ((csubtypep type (specifier-type 'fixnum))
+ '(%lastn/fixnum list n))
+ ((csubtypep type (specifier-type 'bignum))
+ '(%lastn/bignum list n))
+ (t
+ (give-up-ir1-transform "second argument type too vague"))))))))
+
(define-source-transform gethash (&rest args)
(case (length args)
(2 `(sb!impl::gethash3 ,@args nil))
nil
(set-bound y (consp x)))))))
+(defun safe-double-coercion-p (x)
+ (or (typep x 'double-float)
+ (<= most-negative-double-float x most-positive-double-float)))
+
+(defun safe-single-coercion-p (x)
+ (or (typep x 'single-float)
+ ;; Fix for bug 420, and related issues: during type derivation we often
+ ;; end up deriving types for both
+ ;;
+ ;; (some-op <int> <single>)
+ ;; and
+ ;; (some-op (coerce <int> 'single-float) <single>)
+ ;;
+ ;; or other equivalent transformed forms. The problem with this is that
+ ;; on some platforms like x86 (+ <int> <single>) is on the machine level
+ ;; equivalent of
+ ;;
+ ;; (coerce (+ (coerce <int> 'double-float)
+ ;; (coerce <single> 'double-float))
+ ;; 'single-float)
+ ;;
+ ;; so if the result of (coerce <int> 'single-float) is not exact, the
+ ;; derived types for the transformed forms will have an empty
+ ;; intersection -- which in turn means that the compiler will conclude
+ ;; that the call never returns, and all hell breaks lose when it *does*
+ ;; return at runtime. (This affects not just +, but other operators are
+ ;; well.)
+ (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
+ (integer (,most-positive-exactly-single-float-fixnum) *))))
+ (<= most-negative-single-float x most-positive-single-float))))
+
;;; 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
;;; is open if either X or Y is open.
(defmacro safely-binop (op x y)
`(cond
- ((typep ,x 'single-float)
- (if (or (typep ,y 'single-float)
- (<= most-negative-single-float ,y most-positive-single-float))
- (,op ,x ,y)))
- ((typep ,x 'double-float)
- (if (or (typep ,y 'double-float)
- (<= most-negative-double-float ,y most-positive-double-float))
- (,op ,x ,y)))
- ((typep ,y 'single-float)
- (if (<= most-negative-single-float ,x most-positive-single-float)
- (,op ,x ,y)))
- ((typep ,y 'double-float)
- (if (<= most-negative-double-float ,x most-positive-double-float)
- (,op ,x ,y)))
- (t (,op ,x ,y))))
+ ((typep ,x 'double-float)
+ (when (safe-double-coercion-p ,y)
+ (,op ,x ,y)))
+ ((typep ,y 'double-float)
+ (when (safe-double-coercion-p ,x)
+ (,op ,x ,y)))
+ ((typep ,x 'single-float)
+ (when (safe-single-coercion-p ,y)
+ (,op ,x ,y)))
+ ((typep ,y 'single-float)
+ (when (safe-single-coercion-p ,x)
+ (,op ,x ,y)))
+ (t (,op ,x ,y))))
(defmacro bound-binop (op x y)
`(and ,x ,y
(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
(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.)
#'%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
(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)
(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
;;;
;;; and similar for other arguments.
-(defun make-modular-fun-type-deriver (prototype class width)
+(defun make-modular-fun-type-deriver (prototype kind width signedp)
+ (declare (ignore kind))
#!-sb-fluid
(binding* ((info (info :function :info prototype) :exit-if-null)
(fun (fun-info-derive-type info) :exit-if-null)
(mask-type (specifier-type
- (ecase class
- (:unsigned (let ((mask (1- (ash 1 width))))
- `(integer ,mask ,mask)))
- (:signed `(signed-byte ,width))))))
+ (ecase signedp
+ ((nil) (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
+ ((t) `(signed-byte ,width))))))
(lambda (call)
(let ((res (funcall fun call)))
(when res
- (if (eq class :unsigned)
+ (if (eq signedp nil)
(logand-derive-type-aux res mask-type))))))
#!+sb-fluid
(lambda (call)
(fun (fun-info-derive-type info) :exit-if-null)
(res (funcall fun call) :exit-if-null)
(mask-type (specifier-type
- (ecase class
- (:unsigned (let ((mask (1- (ash 1 width))))
- `(integer ,mask ,mask)))
- (:signed `(signed-byte ,width))))))
- (if (eq class :unsigned)
+ (ecase signedp
+ ((nil) (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
+ ((t) `(signed-byte ,width))))))
+ (if (eq signedp nil)
(logand-derive-type-aux res mask-type)))))
;;; Try to recursively cut all uses of LVAR to WIDTH bits.
;;; modular version, if it exists, or NIL. If we have changed
;;; anything, we need to flush old derived types, because they have
;;; nothing in common with the new code.
-(defun cut-to-width (lvar class width)
+(defun cut-to-width (lvar kind width signedp)
(declare (type lvar lvar) (type (integer 0) width))
(let ((type (specifier-type (if (zerop width)
'(eql 0)
- `(,(ecase class (:unsigned 'unsigned-byte)
- (:signed 'signed-byte))
+ `(,(ecase signedp
+ ((nil) 'unsigned-byte)
+ ((t) 'signed-byte))
,width)))))
(labels ((reoptimize-node (node name)
(setf (node-derived-type node)
(eq (basic-combination-kind node) :known))
(let* ((fun-ref (lvar-use (combination-fun node)))
(fun-name (leaf-source-name (ref-leaf fun-ref)))
- (modular-fun (find-modular-version fun-name class width)))
+ (modular-fun (find-modular-version fun-name kind signedp width)))
(when (and modular-fun
(not (and (eq fun-name 'logand)
(csubtypep
did-something))
(cut-lvar lvar))))
+(defun best-modular-version (width signedp)
+ ;; 1. exact width-matched :untagged
+ ;; 2. >/>= width-matched :tagged
+ ;; 3. >/>= width-matched :untagged
+ (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
+ (uswidths (modular-class-widths *untagged-signed-modular-class*))
+ (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+ (twidths (modular-class-widths *tagged-modular-class*)))
+ (let ((exact (find (cons width signedp) uwidths :test #'equal)))
+ (when exact
+ (return-from best-modular-version (values width :untagged signedp))))
+ (flet ((inexact-match (w)
+ (cond
+ ((eq signedp (cdr w)) (<= width (car w)))
+ ((eq signedp nil) (< width (car w))))))
+ (let ((tgt (find-if #'inexact-match twidths)))
+ (when tgt
+ (return-from best-modular-version
+ (values (car tgt) :tagged (cdr tgt)))))
+ (let ((ugt (find-if #'inexact-match uwidths)))
+ (when ugt
+ (return-from best-modular-version
+ (values (car ugt) :untagged (cdr ugt))))))))
+
(defoptimizer (logand optimizer) ((x y) node)
(let ((result-type (single-value-type (node-derived-type node))))
(when (numeric-type-p result-type)
(numberp high)
(>= low 0))
(let ((width (integer-length high)))
- (when (some (lambda (x) (<= width x))
- (modular-class-widths *unsigned-modular-class*))
- ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
- (cut-to-width x :unsigned width)
- (cut-to-width y :unsigned width)
- nil ; After fixing above, replace with T.
- )))))))
+ (multiple-value-bind (w kind signedp)
+ (best-modular-version width nil)
+ (when w
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
+ (cut-to-width x kind width signedp)
+ (cut-to-width y kind width signedp)
+ nil ; After fixing above, replace with T.
+ ))))))))
(defoptimizer (mask-signed-field optimizer) ((width x) node)
(let ((result-type (single-value-type (node-derived-type node))))
(high (numeric-type-high result-type)))
(when (and (numberp low) (numberp high))
(let ((width (max (integer-length high) (integer-length low))))
- (when (some (lambda (x) (<= width x))
- (modular-class-widths *signed-modular-class*))
- ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
- (cut-to-width x :signed width)
- nil ; After fixing above, replace with T.
- )))))))
+ (multiple-value-bind (w kind)
+ (best-modular-version width t)
+ (when w
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T).
+ (cut-to-width x kind width t)
+ nil ; After fixing above, replace with T.
+ ))))))))
\f
;;; miscellanous numeric transforms
(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)))
((= 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
(let ((x-type (lvar-type x))
(y-type (lvar-type y))
(char-type (specifier-type 'character)))
- (flet ((simple-type-p (type)
- (csubtypep type (specifier-type '(or fixnum (not number)))))
- (fixnum-type-p (type)
+ (flet ((fixnum-type-p (type)
(csubtypep type (specifier-type 'fixnum))))
(cond
((same-leaf-ref-p x y) t)
'(char= x y))
((or (fixnum-type-p x-type) (fixnum-type-p y-type))
(commutative-arg-swap node))
- ((or (simple-type-p x-type) (simple-type-p y-type))
+ ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
'(eq x y))
((and (not (constant-lvar-p y))
(or (constant-lvar-p x)
(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))
;;; 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))))
(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))
: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
(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:
;; 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
(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
(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))
(policy-quality-name-p (lvar-value quality-name)))
(give-up-ir1-transform))
'(%policy-quality policy quality-name))
-