X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=69275ff44502e6031f50d7ccf1d8eece3981cfe7;hb=cd1b14acf6f548b28b8a14e554d779f0473122ec;hp=7c7f8fda88183dea80357c0e00250ab33dcead61;hpb=69018386b391f17fb722a4ded00474be182db355;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 7c7f8fd..69275ff 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2771,8 +2771,13 @@ (defun %ash/right (integer amount) (ash integer (- amount))) - (deftransform ash ((integer amount) (sb!vm:signed-word (integer * 0))) + (deftransform ash ((integer amount)) "Convert ASH of signed word to %ASH/RIGHT" + (unless (and (csubtypep (lvar-type integer) ; do that ourselves to avoid + (specifier-type 'sb!vm:signed-word)) ; optimization + (csubtypep (lvar-type amount) ; notes. + (specifier-type '(integer * 0)))) + (give-up-ir1-transform)) (when (constant-lvar-p amount) (give-up-ir1-transform)) (let ((use (lvar-uses amount))) @@ -2789,8 +2794,13 @@ ,(1- sb!vm:n-word-bits) (- amount))))))) - (deftransform ash ((integer amount) (word (integer * 0))) + (deftransform ash ((integer amount)) "Convert ASH of word to %ASH/RIGHT" + (unless (and (csubtypep (lvar-type integer) + (specifier-type 'sb!vm:word)) + (csubtypep (lvar-type amount) + (specifier-type '(integer * 0)))) + (give-up-ir1-transform)) (when (constant-lvar-p amount) (give-up-ir1-transform)) (let ((use (lvar-uses amount))) @@ -2945,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 @@ -2977,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 @@ -3011,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 @@ -3034,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 @@ -3065,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))))))))) @@ -4022,6 +4064,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 ;;;;