X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b66f0f44e9373d3c2d5ef1b42753af6d92e86daa;hb=d01d509257052e694365b76be5ab597fa06764ec;hp=2fc1c400b322b74228ea85b3fad530b45fc8826e;hpb=e240610bcc02cfe6f970131a362502d33be114c5;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 2fc1c40..b66f0f4 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -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 @@ -3794,25 +3821,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. @@ -3980,15 +4054,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