(define-source-transform last (x) `(sb!impl::last1 ,x))
(define-source-transform gethash (&rest args)
(case (length args)
- (2 `(sb!impl::gethash2 ,@args))
+ (2 `(sb!impl::gethash3 ,@args nil))
(3 `(sb!impl::gethash3 ,@args))
(t (values nil t))))
(define-source-transform get (&rest args)
(if (member-type-p arg)
;; Run down the list of members and convert to a list of
;; member types.
- (dolist (member (member-type-members arg))
- (push (if (numberp member)
- (make-member-type :members (list member))
- *empty-type*)
- new-args))
+ (mapc-member-type-members
+ (lambda (member)
+ (push (if (numberp member)
+ (make-member-type :members (list member))
+ *empty-type*)
+ new-args))
+ arg)
(push arg new-args)))
(unless (member *empty-type* new-args)
new-args)))))
;;; XXX This would be far simpler if the type-union methods could handle
;;; member/number unions.
(defun make-canonical-union-type (type-list)
- (let ((members '())
+ (let ((xset (alloc-xset))
+ (fp-zeroes '())
(misc-types '()))
(dolist (type type-list)
- (if (member-type-p type)
- (setf members (union members (member-type-members type)))
- (push type misc-types)))
- #!+long-float
- (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))
- (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
- (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
- (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
- (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
- (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))
- (if members
- (apply #'type-union (make-member-type :members members) misc-types)
- (apply #'type-union misc-types))))
+ (cond ((member-type-p type)
+ (mapc-member-type-members
+ (lambda (member)
+ (if (fp-zero-p member)
+ (unless (member member fp-zeroes)
+ (pushnew member fp-zeroes))
+ (add-to-xset member xset)))
+ 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))))
;;; Convert a member type with a single member to a numeric type.
(defun convert-member-type (arg)
;;;
;;; 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)
;; 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)))
+ (eql 1 (member-type-size 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))))))
+ (eql 1 (member-type-members car-type))
+ (let ((elt (first (member-type-members car-type))))
+ (or (symbolp elt)
+ (numberp elt)
+ (and (listp elt)
+ (numberp (first elt)))))
(good-cons-type-p (cons-type-cdr-type cons-type))))))
(unconsify-type (good-cons-type)
;; Convert the "printed" respresentation of a cons
;; (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*)))
+ (block punt
+ (let (members)
+ (mapc-member-type-members
+ (lambda (member)
+ (if (coerceable-p member)
+ (push member members)
+ (return-from punt *universal-type*)))
+ type)
+ (specifier-type `(or ,@members)))))
((and (cons-type-p type)
(good-cons-type-p type))
(let ((c-type (unconsify-type (type-specifier type))))
(unless (and (constant-lvar-p quality-name)
(policy-quality-name-p (lvar-value quality-name)))
(give-up-ir1-transform))
- `(let* ((acons (assoc quality-name policy))
- (result (or (cdr acons) 1)))
- result))
-
+ '(%policy-quality policy quality-name))