(t (values nil t))))
(define-source-transform get (&rest args)
(case (length args)
- (2 `(sb!impl::get2 ,@args))
+ (2 `(sb!impl::get3 ,@args nil))
(3 `(sb!impl::get3 ,@args))
(t (values nil t))))
`(mod ,base-char-code-limit)))
(t
(specifier-type
- `(mod ,char-code-limit))))))
+ `(mod ,sb!xc:char-code-limit))))))
(defoptimizer (code-char derive-type) ((code))
(let ((type (lvar-type code)))
(setf (block-reoptimize (node-block node)) t)
(reoptimize-component (node-component node) :maybe))
t)
- (cut-node (node &aux did-something)
+ (cut-node (node)
"Try to cut a node to width. The primary return value is
whether we managed to cut (cleverly), and the second whether
- anything was changed."
+ anything was changed. The third return value tells whether
+ the cut value might be wider than expected."
(when (block-delete-p (node-block node))
(return-from cut-node (values t nil)))
(typecase node
(typecase (ref-leaf node)
(constant
(let* ((constant-value (constant-value (ref-leaf node)))
- (new-value (if signedp
- (mask-signed-field width constant-value)
- (ldb (byte width 0) constant-value))))
+ (new-value
+ (cond ((not (integerp constant-value))
+ (return-from cut-node (values t nil)))
+ (signedp
+ (mask-signed-field width constant-value))
+ (t
+ (ldb (byte width 0) constant-value)))))
(cond ((= constant-value new-value)
(values t nil)) ; we knew what to do and did nothing
(t
(modular-fun-info-name modular-fun))
(function
(funcall modular-fun node width)))
- :exit-if-null))
+ :exit-if-null)
+ (did-something nil)
+ (over-wide nil))
(unless (eql modular-fun :good)
- (setq did-something t)
+ (setq did-something t
+ over-wide t)
(change-ref-leaf
fun-ref
(find-free-fun name "in a strange place"))
(setf (combination-kind node) :full))
(unless (functionp modular-fun)
(dolist (arg (basic-combination-args node))
- (when (cut-lvar arg)
- (setq did-something t))))
+ (multiple-value-bind (change wide)
+ (cut-lvar arg)
+ (setf did-something (or did-something change)
+ over-wide (or over-wide wide)))))
(when did-something
(reoptimize-node node name))
- (values t did-something)))))))))
- (cut-lvar (lvar &aux did-something must-insert)
+ (values t did-something over-wide)))))))))
+ (cut-lvar (lvar &key head
+ &aux did-something must-insert over-wide)
"Cut all the LVAR's use nodes. If any of them wasn't handled
and its type is too wide for the operation we wish to perform
insert an explicit bit-width narrowing operation (LOGAND or
destination is already such an operation, to avoid endless
recursion.
+ If we're at the head, forcibly insert a cut operation if the
+ result might be too wide.
+
(*) We can't easily do that for each node, and doing so might
result in code bloat, anyway. (I'm also not sure it would be
correct for complicated C/D FG)"
(do-uses (node lvar)
- (multiple-value-bind (handled any-change)
+ (multiple-value-bind (handled any-change wide)
(cut-node node)
(setf did-something (or did-something any-change)
must-insert (or must-insert
(not (or handled
(csubtypep (single-value-type
(node-derived-type node))
- type)))))))
- (when must-insert
- (setf did-something (or (insert-lvar-cut lvar) did-something)))
- did-something))
- (cut-lvar lvar))))
+ type))))
+ over-wide (or over-wide wide))))
+ (when (or must-insert
+ (and head over-wide))
+ (setf did-something (or (insert-lvar-cut lvar) did-something)
+ ;; we're just the right width after an explicit cut.
+ over-wide nil))
+ (values did-something over-wide)))
+ (cut-lvar lvar :head t))))
(defun best-modular-version (width signedp)
;; 1. exact width-matched :untagged
,(lvar-value x))
(give-up-ir1-transform)))
-(dolist (x '(= char= + * logior logand logxor logtest))
+(dolist (x '(= char= two-arg-char-equal + * logior logand logxor logtest))
(%deftransform x '(function * *) #'commutative-arg-swap
"place constant arg last"))
\f
;;;; character operations
-(deftransform char-equal ((a b) (base-char base-char))
+(deftransform two-arg-char-equal ((a b) (base-char base-char) *
+ :policy (> speed space))
"open code"
'(let* ((ac (char-code a))
(bc (char-code b))
(and (> sum 415) (< sum 461))
(and (> sum 463) (< sum 477))))))))
+(deftransform two-arg-char-equal ((a b) (* (constant-arg character)) *
+ :node node)
+ (let ((char (lvar-value b)))
+ (if (both-case-p char)
+ (let ((reverse (if (upper-case-p char)
+ (char-downcase char)
+ (char-upcase char))))
+ (if (policy node (> speed space))
+ `(or (char= a ,char)
+ (char= a ,reverse))
+ `(char-equal-constant a ,char ,reverse)))
+ '(char= a b))))
+
(deftransform char-upcase ((x) (base-char))
"open code"
'(let ((n-code (char-code x)))
"convert to simpler equality predicate"
(let ((x-type (lvar-type x))
(y-type (lvar-type y))
- (string-type (specifier-type 'string))
- (bit-vector-type (specifier-type 'bit-vector)))
- (cond
- ((same-leaf-ref-p x y) t)
- ((and (csubtypep x-type string-type)
- (csubtypep y-type string-type))
- '(string= x y))
- ((and (csubtypep x-type bit-vector-type)
- (csubtypep y-type bit-vector-type))
- '(bit-vector-= x y))
- ;; if at least one is not a string, and at least one is not a
- ;; bit-vector, then we can reason from types.
- ((and (not (and (types-equal-or-intersect x-type string-type)
- (types-equal-or-intersect y-type string-type)))
- (not (and (types-equal-or-intersect x-type bit-vector-type)
- (types-equal-or-intersect y-type bit-vector-type)))
- (not (types-equal-or-intersect x-type y-type)))
- nil)
- (t (give-up-ir1-transform)))))
+ (combination-type (specifier-type '(or bit-vector string
+ cons pathname))))
+ (flet ((both-csubtypep (type)
+ (let ((ctype (specifier-type type)))
+ (and (csubtypep x-type ctype)
+ (csubtypep y-type ctype)))))
+ (cond
+ ((same-leaf-ref-p x y) t)
+ ((both-csubtypep 'string)
+ '(string= x y))
+ ((both-csubtypep 'bit-vector)
+ '(bit-vector-= x y))
+ ((both-csubtypep 'pathname)
+ '(pathname= x y))
+ ((or (not (types-equal-or-intersect x-type combination-type))
+ (not (types-equal-or-intersect y-type combination-type)))
+ (if (types-equal-or-intersect x-type y-type)
+ '(eql x y)
+ ;; Can't simply check for type intersection if both types are combination-type
+ ;; since array specialization would mean types don't intersect, even when EQUAL
+ ;; doesn't care for specialization.
+ ;; Previously checking for intersection in the outer COND resulted in
+ ;;
+ ;; (equal (the (cons (or simple-bit-vector
+ ;; simple-base-string))
+ ;; x)
+ ;; (the (cons (or (and bit-vector (not simple-array))
+ ;; (simple-array character (*))))
+ ;; y))
+ ;; being incorrectly folded to NIL
+ nil))
+ (t (give-up-ir1-transform))))))
+
+(deftransform equalp ((x y) * *)
+ "convert to simpler equality predicate"
+ (let ((x-type (lvar-type x))
+ (y-type (lvar-type y))
+ (combination-type (specifier-type '(or number array
+ character
+ cons pathname
+ instance hash-table))))
+ (flet ((both-csubtypep (type)
+ (let ((ctype (specifier-type type)))
+ (and (csubtypep x-type ctype)
+ (csubtypep y-type ctype)))))
+ (cond
+ ((same-leaf-ref-p x y) t)
+ ((both-csubtypep 'string)
+ '(string-equal x y))
+ ((both-csubtypep 'bit-vector)
+ '(bit-vector-= x y))
+ ((both-csubtypep 'pathname)
+ '(pathname= x y))
+ ((both-csubtypep 'character)
+ '(char-equal x y))
+ ((both-csubtypep 'number)
+ '(= x y))
+ ((both-csubtypep 'hash-table)
+ '(hash-table-equalp x y))
+ ((or (not (types-equal-or-intersect x-type combination-type))
+ (not (types-equal-or-intersect y-type combination-type)))
+ ;; See the comment about specialized types in the EQUAL transform above
+ (if (types-equal-or-intersect y-type x-type)
+ '(eq x y)
+ nil))
+ (t (give-up-ir1-transform))))))
;;; Convert to EQL if both args are rational and complexp is specified
;;; and the same for both.
'character))
(define-source-transform char-equal (&rest args)
- (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t))
+ (multi-compare 'two-arg-char-equal args nil 'character t))
(define-source-transform char-lessp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t))
+ (multi-compare 'two-arg-char-lessp args nil 'character t))
(define-source-transform char-greaterp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t))
+ (multi-compare 'two-arg-char-greaterp args nil 'character t))
(define-source-transform char-not-greaterp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t))
+ (multi-compare 'two-arg-char-greaterp args t 'character t))
(define-source-transform char-not-lessp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t))
+ (multi-compare 'two-arg-char-lessp args t 'character t))
;;; This function does source transformation of N-arg inequality
;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
projects / sbcl.git / blobdiff