(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 over-wide)
+ (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. The third return value tells whether
(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
over-wide t)
,(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)))
'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