X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=c808988499c711bd19b13aba32bafd4761a24a64;hb=0e8649cf907d26f111864e4e29c7f9787828efbd;hp=e13c30e019e7799ab08cf50a3f42b4620e683ba5;hpb=1daa58cfa315fe86634069c941cf54ec8f95623c;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index e13c30e..c808988 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -242,7 +242,7 @@ (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)))) @@ -2522,7 +2522,7 @@ `(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))) @@ -2955,10 +2955,11 @@ (setf (block-reoptimize (node-block node)) t) (reoptimize-component (node-component node) :maybe)) t) - (cut-node (node &aux did-something) + (cut-node (node &aux did-something over-wide) "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 @@ -2987,32 +2988,51 @@ (fun-name (lvar-fun-name (combination-fun node))) (modular-fun (find-modular-version fun-name kind signedp width))) - (when (and modular-fun - (not (and (eq fun-name 'logand) - (csubtypep - (single-value-type (node-derived-type node)) - type)))) - (binding* ((name (etypecase modular-fun - ((eql :good) fun-name) - (modular-fun-info - (modular-fun-info-name modular-fun)) - (function - (funcall modular-fun node width))) - :exit-if-null)) - (unless (eql modular-fun :good) - (setq did-something 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)))) - (when did-something - (reoptimize-node node name)) - (values t did-something)))))))) - (cut-lvar (lvar &aux did-something must-insert) + (cond ((not modular-fun) + ;; don't know what to do here + (values nil nil)) + ((let ((dtype (single-value-type + (node-derived-type node)))) + (and + (case fun-name + (logand + (csubtypep dtype + (specifier-type 'unsigned-byte))) + (logior + (csubtypep dtype + (specifier-type '(integer * 0)))) + (mask-signed-field + t) + (t nil)) + (csubtypep dtype type))) + ;; nothing to do + (values t nil)) + (t + (binding* ((name (etypecase modular-fun + ((eql :good) fun-name) + (modular-fun-info + (modular-fun-info-name modular-fun)) + (function + (funcall modular-fun node width))) + :exit-if-null)) + (unless (eql modular-fun :good) + (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)) + (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 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 @@ -3021,22 +3041,29 @@ 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 @@ -3044,7 +3071,10 @@ ;; 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)) + (uwidths (if (and uuwidths uswidths) + (merge 'list (copy-list uuwidths) (copy-list uswidths) + #'< :key #'car) + (or uuwidths uswidths))) (twidths (modular-class-widths *tagged-modular-class*))) (let ((exact (find (cons width signedp) uwidths :test #'equal))) (when exact @@ -3075,6 +3105,8 @@ (return (values nil nil))) (let ((this-low (numeric-type-low type)) (this-high (numeric-type-high type))) + (unless (and this-low this-high) + (return (values nil nil))) (setf low (min this-low (or low this-low)) high (max this-high (or high this-high))))))))) @@ -3153,7 +3185,7 @@ ,(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")) @@ -3675,7 +3707,8 @@ ;;;; 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)) @@ -3687,6 +3720,19 @@ (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))) @@ -3789,25 +3835,72 @@ "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. @@ -3975,15 +4068,15 @@ '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 @@ -4032,6 +4125,48 @@ `(values (the real ,arg0)) `(let ((minrest (min ,@rest))) (if (<= ,arg0 minrest) ,arg0 minrest))))) + +;;; Simplify some cross-type comparisons +(macrolet ((def (comparator round) + `(progn + (deftransform ,comparator + ((x y) (rational (constant-arg float))) + "open-code RATIONAL to FLOAT comparison" + (let ((y (lvar-value y))) + #-sb-xc-host + (when (or (float-nan-p y) + (float-infinity-p y)) + (give-up-ir1-transform)) + (setf y (rational y)) + `(,',comparator + x ,(if (csubtypep (lvar-type x) + (specifier-type 'integer)) + (,round y) + y)))) + (deftransform ,comparator + ((x y) (integer (constant-arg ratio))) + "open-code INTEGER to RATIO comparison" + `(,',comparator x ,(,round (lvar-value y))))))) + (def < ceiling) + (def > floor)) + +(deftransform = ((x y) (rational (constant-arg float))) + "open-code RATIONAL to FLOAT comparison" + (let ((y (lvar-value y))) + #-sb-xc-host + (when (or (float-nan-p y) + (float-infinity-p y)) + (give-up-ir1-transform)) + (setf y (rational y)) + (if (and (csubtypep (lvar-type x) + (specifier-type 'integer)) + (ratiop y)) + nil + `(= x ,y)))) + +(deftransform = ((x y) (integer (constant-arg ratio))) + "constant-fold INTEGER to RATIO comparison" + nil) ;;;; converting N-arg arithmetic functions ;;;;