X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b17b40422d29bc57c7cd758427a1e30fce883a6a;hb=f87f749ba5ffeb2e51b28c83d01ac7e33a5ca76d;hp=bdab82c41f7f5a26902c960155731f028ce48640;hpb=ab6672fd5c392b8678681bdda138c4dc9e4de31a;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index bdab82c..b17b404 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -123,10 +123,15 @@ (t (values nil t)))) ;;; And similarly for LIST*. -(define-source-transform list* (&rest args) - (case (length args) - (2 `(cons ,(first args) ,(second args))) - (t (values nil t)))) +(define-source-transform list* (arg &rest others) + (cond ((not others) arg) + ((not (cdr others)) `(cons ,arg ,(car others))) + (t (values nil t)))) + +(defoptimizer (list* derive-type) ((arg &rest args)) + (if args + (specifier-type 'cons) + (lvar-type arg))) ;;; Translate RPLACx to LET and SETF. (define-source-transform rplaca (x y) @@ -142,7 +147,22 @@ (define-source-transform nth (n l) `(car (nthcdr ,n ,l))) -(define-source-transform last (x) `(sb!impl::last1 ,x)) +(deftransform last ((list &optional n) (t &optional t)) + (let ((c (constant-lvar-p n))) + (cond ((or (not n) + (and c (eql 1 (lvar-value n)))) + '(%last1 list)) + ((and c (eql 0 (lvar-value n))) + '(%last0 list)) + (t + (let ((type (lvar-type n))) + (cond ((csubtypep type (specifier-type 'fixnum)) + '(%lastn/fixnum list n)) + ((csubtypep type (specifier-type 'bignum)) + '(%lastn/bignum list n)) + (t + (give-up-ir1-transform "second argument type too vague")))))))) + (define-source-transform gethash (&rest args) (case (length args) (2 `(sb!impl::gethash3 ,@args nil)) @@ -322,6 +342,37 @@ nil (set-bound y (consp x))))))) +(defun safe-double-coercion-p (x) + (or (typep x 'double-float) + (<= most-negative-double-float x most-positive-double-float))) + +(defun safe-single-coercion-p (x) + (or (typep x 'single-float) + ;; Fix for bug 420, and related issues: during type derivation we often + ;; end up deriving types for both + ;; + ;; (some-op ) + ;; and + ;; (some-op (coerce 'single-float) ) + ;; + ;; or other equivalent transformed forms. The problem with this is that + ;; on some platforms like x86 (+ ) is on the machine level + ;; equivalent of + ;; + ;; (coerce (+ (coerce 'double-float) + ;; (coerce 'double-float)) + ;; 'single-float) + ;; + ;; so if the result of (coerce 'single-float) is not exact, the + ;; derived types for the transformed forms will have an empty + ;; intersection -- which in turn means that the compiler will conclude + ;; that the call never returns, and all hell breaks lose when it *does* + ;; return at runtime. (This affects not just +, but other operators are + ;; well.) + (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum)) + (integer (,most-positive-exactly-single-float-fixnum) *)))) + (<= most-negative-single-float x most-positive-single-float)))) + ;;; Apply a binary operator OP to two bounds X and Y. The result is ;;; NIL if either is NIL. Otherwise bound is computed and the result ;;; is open if either X or Y is open. @@ -335,21 +386,19 @@ (defmacro safely-binop (op x y) `(cond - ((typep ,x 'single-float) - (if (or (typep ,y 'single-float) - (<= most-negative-single-float ,y most-positive-single-float)) - (,op ,x ,y))) - ((typep ,x 'double-float) - (if (or (typep ,y 'double-float) - (<= most-negative-double-float ,y most-positive-double-float)) - (,op ,x ,y))) - ((typep ,y 'single-float) - (if (<= most-negative-single-float ,x most-positive-single-float) - (,op ,x ,y))) - ((typep ,y 'double-float) - (if (<= most-negative-double-float ,x most-positive-double-float) - (,op ,x ,y))) - (t (,op ,x ,y)))) + ((typep ,x 'double-float) + (when (safe-double-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'double-float) + (when (safe-double-coercion-p ,x) + (,op ,x ,y))) + ((typep ,x 'single-float) + (when (safe-single-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'single-float) + (when (safe-single-coercion-p ,x) + (,op ,x ,y))) + (t (,op ,x ,y)))) (defmacro bound-binop (op x y) `(and ,x ,y @@ -2816,19 +2865,20 @@ ;;; ;;; and similar for other arguments. -(defun make-modular-fun-type-deriver (prototype class width) +(defun make-modular-fun-type-deriver (prototype kind width signedp) + (declare (ignore kind)) #!-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 (let ((mask (1- (ash 1 width)))) - `(integer ,mask ,mask))) - (:signed `(signed-byte ,width)))))) + (ecase signedp + ((nil) (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) + ((t) `(signed-byte ,width)))))) (lambda (call) (let ((res (funcall fun call))) (when res - (if (eq class :unsigned) + (if (eq signedp nil) (logand-derive-type-aux res mask-type)))))) #!+sb-fluid (lambda (call) @@ -2836,11 +2886,11 @@ (fun (fun-info-derive-type info) :exit-if-null) (res (funcall fun call) :exit-if-null) (mask-type (specifier-type - (ecase class - (:unsigned (let ((mask (1- (ash 1 width)))) - `(integer ,mask ,mask))) - (:signed `(signed-byte ,width)))))) - (if (eq class :unsigned) + (ecase signedp + ((nil) (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) + ((t) `(signed-byte ,width)))))) + (if (eq signedp nil) (logand-derive-type-aux res mask-type))))) ;;; Try to recursively cut all uses of LVAR to WIDTH bits. @@ -2855,12 +2905,13 @@ ;;; 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 class width) +(defun cut-to-width (lvar kind width signedp) (declare (type lvar lvar) (type (integer 0) width)) (let ((type (specifier-type (if (zerop width) '(eql 0) - `(,(ecase class (:unsigned 'unsigned-byte) - (:signed 'signed-byte)) + `(,(ecase signedp + ((nil) 'unsigned-byte) + ((t) 'signed-byte)) ,width))))) (labels ((reoptimize-node (node name) (setf (node-derived-type node) @@ -2876,7 +2927,7 @@ (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))) + (modular-fun (find-modular-version fun-name kind signedp width))) (when (and modular-fun (not (and (eq fun-name 'logand) (csubtypep @@ -2909,6 +2960,30 @@ did-something)) (cut-lvar lvar)))) +(defun best-modular-version (width signedp) + ;; 1. exact width-matched :untagged + ;; 2. >/>= width-matched :tagged + ;; 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)) + (twidths (modular-class-widths *tagged-modular-class*))) + (let ((exact (find (cons width signedp) uwidths :test #'equal))) + (when exact + (return-from best-modular-version (values width :untagged signedp)))) + (flet ((inexact-match (w) + (cond + ((eq signedp (cdr w)) (<= width (car w))) + ((eq signedp nil) (< width (car w)))))) + (let ((tgt (find-if #'inexact-match twidths))) + (when tgt + (return-from best-modular-version + (values (car tgt) :tagged (cdr tgt))))) + (let ((ugt (find-if #'inexact-match uwidths))) + (when ugt + (return-from best-modular-version + (values (car ugt) :untagged (cdr ugt)))))))) + (defoptimizer (logand optimizer) ((x y) node) (let ((result-type (single-value-type (node-derived-type node)))) (when (numeric-type-p result-type) @@ -2918,13 +2993,14 @@ (numberp high) (>= low 0)) (let ((width (integer-length high))) - (when (some (lambda (x) (<= width x)) - (modular-class-widths *unsigned-modular-class*)) - ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). - (cut-to-width x :unsigned width) - (cut-to-width y :unsigned width) - nil ; After fixing above, replace with T. - ))))))) + (multiple-value-bind (w kind signedp) + (best-modular-version width nil) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). + (cut-to-width x kind width signedp) + (cut-to-width y kind width signedp) + 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)))) @@ -2933,12 +3009,13 @@ (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. - ))))))) + (multiple-value-bind (w kind) + (best-modular-version width t) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T). + (cut-to-width x kind width t) + nil ; After fixing above, replace with T. + )))))))) ;;; miscellanous numeric transforms @@ -3315,10 +3392,6 @@ (def eq) (def char=)) -;;; True if EQL comparisons involving type can be simplified to EQ. -(defun eq-comparable-type-p (type) - (csubtypep type (specifier-type '(or fixnum (not number))))) - ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also ;;; try to convert to a type-specific predicate or EQ: ;;; -- If both args are characters, convert to CHAR=. This is better than @@ -3913,7 +3986,7 @@ (eq (first (second good-cons-type)) 'member)) `(,(second (second good-cons-type)) ,@(unconsify-type (caddr good-cons-type)))))) - (coerceable-p (c-type) + (coerceable-p (part) ;; Can the value be coerced to the given type? Coerce is ;; complicated, so we don't handle every possible case ;; here---just the most common and easiest cases: @@ -3935,13 +4008,14 @@ ;; the requested type, because (by assumption) COMPLEX ;; (and other difficult types like (COMPLEX INTEGER) ;; aren't specialized types. - (let ((coerced-type c-type)) - (or (and (subtypep coerced-type 'float) - (csubtypep value-type (specifier-type 'real))) - (and (subtypep coerced-type - '(or (complex single-float) - (complex double-float))) - (csubtypep value-type (specifier-type 'number)))))) + (let ((coerced-type (careful-specifier-type part))) + (when coerced-type + (or (and (csubtypep coerced-type (specifier-type 'float)) + (csubtypep value-type (specifier-type 'real))) + (and (csubtypep coerced-type + (specifier-type `(or (complex single-float) + (complex double-float)))) + (csubtypep value-type (specifier-type 'number))))))) (process-types (type) ;; FIXME: This needs some work because we should be able ;; to derive the resulting type better than just the @@ -4134,4 +4208,3 @@ (policy-quality-name-p (lvar-value quality-name))) (give-up-ir1-transform)) '(%policy-quality policy quality-name)) -