X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=44930bab142dca65f89a7e21fc269350e31186d6;hb=5ecef987f3847ed5de8c03f66ef9d8ab468af993;hp=a5ccd0279eafa80c69f785db1b64475f00bfcb47;hpb=988afd9d54ba6c8a915544822658824ab6ae0d6c;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index a5ccd02..44930ba 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2551,6 +2551,16 @@ `(let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand new mask) (logand int (lognot mask))))) + +(defoptimizer (mask-signed-field derive-type) ((size x)) + (let ((size (lvar-type size))) + (if (numeric-type-p size) + (let ((size-high (numeric-type-high size))) + (if (and size-high (<= 1 size-high sb!vm:n-word-bits)) + (specifier-type `(signed-byte ,size-high)) + *universal-type*)) + *universal-type*))) + ;;; Modular functions @@ -2559,6 +2569,31 @@ ;;; ;;; and similar for other arguments. +(defun make-modular-fun-type-deriver (prototype class width) + #!-sb-fluid + (binding* ((info (info :function :info prototype) :exit-if-null) + (fun (fun-info-derive-type info) :exit-if-null) + (mask-type (specifier-type + (ecase class + (:unsigned `(unsigned-byte* ,width)) + (:signed `(signed-byte ,width)))))) + (lambda (call) + (let ((res (funcall fun call))) + (when res + (if (eq class :unsigned) + (logand-derive-type-aux res mask-type)))))) + #!+sb-fluid + (lambda (call) + (binding* ((info (info :function :info prototype) :exit-if-null) + (fun (fun-info-derive-type info) :exit-if-null) + (res (funcall fun call) :exit-if-null) + (mask-type (specifier-type + (ecase class + (:unsigned `(unsigned-byte* ,width)) + (:signed `(signed-byte ,width)))))) + (if (eq class :unsigned) + (logand-derive-type-aux res mask-type))))) + ;;; Try to recursively cut all uses of LVAR to WIDTH bits. ;;; ;;; For good functions, we just recursively cut arguments; their @@ -2571,54 +2606,59 @@ ;;; modular version, if it exists, or NIL. If we have changed ;;; anything, we need to flush old derived types, because they have ;;; nothing in common with the new code. -(defun cut-to-width (lvar width) +(defun cut-to-width (lvar class width) (declare (type lvar lvar) (type (integer 0) width)) - (labels ((reoptimize-node (node name) - (setf (node-derived-type node) - (fun-type-returns - (info :function :type name))) - (setf (lvar-%derived-type (node-lvar node)) nil) - (setf (node-reoptimize node) t) - (setf (block-reoptimize (node-block node)) t) - (setf (component-reoptimize (node-component node)) t)) - (cut-node (node &aux did-something) - (when (and (not (block-delete-p (node-block node))) - (combination-p node) - (eq (basic-combination-kind node) :known)) - (let* ((fun-ref (lvar-use (combination-fun node))) - (fun-name (leaf-source-name (ref-leaf fun-ref))) - (modular-fun (find-modular-version fun-name width))) - (when (and modular-fun - (not (and (eq fun-name 'logand) - (csubtypep - (single-value-type (node-derived-type node)) - (specifier-type `(unsigned-byte* ,width)))))) - (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)) - did-something))))) - (cut-lvar (lvar &aux did-something) - (do-uses (node lvar) - (when (cut-node node) - (setq did-something t))) - did-something)) - (cut-lvar lvar))) + (let ((type (specifier-type (if (zerop width) + '(eql 0) + `(,(ecase class (:unsigned 'unsigned-byte) + (:signed 'signed-byte)) + ,width))))) + (labels ((reoptimize-node (node name) + (setf (node-derived-type node) + (fun-type-returns + (info :function :type name))) + (setf (lvar-%derived-type (node-lvar node)) nil) + (setf (node-reoptimize node) t) + (setf (block-reoptimize (node-block node)) t) + (reoptimize-component (node-component node) :maybe)) + (cut-node (node &aux did-something) + (when (and (not (block-delete-p (node-block node))) + (combination-p node) + (eq (basic-combination-kind node) :known)) + (let* ((fun-ref (lvar-use (combination-fun node))) + (fun-name (leaf-source-name (ref-leaf fun-ref))) + (modular-fun (find-modular-version fun-name class 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)) + did-something))))) + (cut-lvar (lvar &aux did-something) + (do-uses (node lvar) + (when (cut-node node) + (setq did-something t))) + did-something)) + (cut-lvar lvar)))) (defoptimizer (logand optimizer) ((x y) node) (let ((result-type (single-value-type (node-derived-type node)))) @@ -2630,10 +2670,24 @@ (>= low 0)) (let ((width (integer-length high))) (when (some (lambda (x) (<= width x)) - *modular-funs-widths*) + (modular-class-widths *unsigned-modular-class*)) ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). - (cut-to-width x width) - (cut-to-width y width) + (cut-to-width x :unsigned width) + (cut-to-width y :unsigned width) + nil ; After fixing above, replace with T. + ))))))) + +(defoptimizer (mask-signed-field optimizer) ((width x) node) + (let ((result-type (single-value-type (node-derived-type node)))) + (when (numeric-type-p result-type) + (let ((low (numeric-type-low result-type)) + (high (numeric-type-high result-type))) + (when (and (numberp low) (numberp high)) + (let ((width (max (integer-length high) (integer-length low)))) + (when (some (lambda (x) (<= width x)) + (modular-class-widths *signed-modular-class*)) + ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). + (cut-to-width x :signed width) nil ; After fixing above, replace with T. ))))))) @@ -2801,6 +2855,13 @@ (give-up-ir1-transform)) 'x)) +(deftransform mask-signed-field ((size x) ((constant-arg t) *) *) + "fold identity operation" + (let ((size (lvar-value size))) + (unless (csubtypep (lvar-type x) (specifier-type `(signed-byte ,size))) + (give-up-ir1-transform)) + 'x)) + ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and ;;; (* 0 -4.0) is -0.0. (deftransform - ((x y) ((constant-arg (member 0)) rational) *) @@ -2939,9 +3000,7 @@ ;;;; character operations -(deftransform char-equal ((a b) - ((character-set ((0 . 255))) - (character-set ((0 . 255))))) +(deftransform char-equal ((a b) (base-char base-char)) "open code" '(let* ((ac (char-code a)) (bc (char-code b)) @@ -2953,7 +3012,7 @@ (and (> sum 415) (< sum 461)) (and (> sum 463) (< sum 477)))))))) -(deftransform char-upcase ((x) ((character-set ((0 . 255))))) +(deftransform char-upcase ((x) (base-char)) "open code" '(let ((n-code (char-code x))) (if (or (and (> n-code #o140) ; Octal 141 is #\a. @@ -2965,7 +3024,7 @@ (code-char (logxor #x20 n-code)) x))) -(deftransform char-downcase ((x) ((character-set ((0 . 255))))) +(deftransform char-downcase ((x) (base-char)) "open code" '(let ((n-code (char-code x))) (if (or (and (> n-code 64) ; 65 is #\A. @@ -3046,19 +3105,27 @@ ;;; similarly to the EQL transform above, we attempt to constant-fold ;;; or convert to a simpler predicate: mostly we have to be careful -;;; with strings. +;;; with strings and bit-vectors. (deftransform equal ((x y) * *) "convert to simpler equality predicate" (let ((x-type (lvar-type x)) (y-type (lvar-type y)) - (string-type (specifier-type 'string))) + (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 (or (not (types-equal-or-intersect x-type string-type)) - (not (types-equal-or-intersect y-type string-type))) + ((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)))))