(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))
;;;
;;; 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
(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
(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)
(policy-quality-name-p (lvar-value quality-name)))
(give-up-ir1-transform))
'(%policy-quality policy quality-name))
-
projects / sbcl.git / blobdiff