X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=869f6842cd2aea287da93aeacb3f3ac667aa22ff;hb=e73a30c901ab234291aefc9f1e73507650628892;hp=fe7f950a83785e3aae7953c280ccf18d2f32de46;hpb=80d37651bc4cba800bbf2ba38ea720d734fbae4a;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index fe7f950..869f684 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -65,10 +65,14 @@ (defun source-transform-cxr (form) (if (/= (length form) 2) (values nil t) - (let ((name (symbol-name (car form)))) - (do ((i (- (length name) 2) (1- i)) + (let* ((name (car form)) + (string (symbol-name + (etypecase name + (symbol name) + (leaf (leaf-source-name name)))))) + (do ((i (- (length string) 2) (1- i)) (res (cadr form) - `(,(ecase (char name i) + `(,(ecase (char string i) (#\A 'car) (#\D 'cdr)) ,res))) @@ -2121,7 +2125,8 @@ (values nil t t))) (defun logand-derive-type-aux (x y &optional same-leaf) - (declare (ignore same-leaf)) + (when same-leaf + (return-from logand-derive-type-aux x)) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (declare (ignore x-pos)) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) @@ -2153,7 +2158,8 @@ (specifier-type 'integer))))))) (defun logior-derive-type-aux (x y &optional same-leaf) - (declare (ignore same-leaf)) + (when same-leaf + (return-from logior-derive-type-aux x)) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) (cond @@ -2192,7 +2198,8 @@ (specifier-type 'integer)))))))) (defun logxor-derive-type-aux (x y &optional same-leaf) - (declare (ignore same-leaf)) + (when same-leaf + (return-from logxor-derive-type-aux (specifier-type '(eql 0)))) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) (cond @@ -2230,7 +2237,7 @@ (defoptimizer (logeqv derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) (lognot-derive-type-aux - (logxor-derive-type-aux x y same-leaf))) + (logxor-derive-type-aux x y same-leaf))) #'logeqv)) (defoptimizer (lognand derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) @@ -2242,25 +2249,34 @@ (lognot-derive-type-aux (logior-derive-type-aux x y same-leaf))) #'lognor)) +;;; FIXME: use SAME-LEAF instead of ignoring it. (defoptimizer (logandc1 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logand-derive-type-aux - (lognot-derive-type-aux x) y nil)) + (if same-leaf + (specifier-type '(eql 0)) + (logand-derive-type-aux + (lognot-derive-type-aux x) y nil))) #'logandc1)) (defoptimizer (logandc2 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logand-derive-type-aux - x (lognot-derive-type-aux y) nil)) + (if same-leaf + (specifier-type '(eql 0)) + (logand-derive-type-aux + x (lognot-derive-type-aux y) nil))) #'logandc2)) (defoptimizer (logorc1 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logior-derive-type-aux - (lognot-derive-type-aux x) y nil)) + (if same-leaf + (specifier-type '(eql -1)) + (logior-derive-type-aux + (lognot-derive-type-aux x) y nil))) #'logorc1)) (defoptimizer (logorc2 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (logior-derive-type-aux - x (lognot-derive-type-aux y) nil)) + (if same-leaf + (specifier-type '(eql -1)) + (logior-derive-type-aux + x (lognot-derive-type-aux y) nil))) #'logorc2)) ;;;; miscellaneous derive-type methods @@ -2518,8 +2534,12 @@ ;;; "goodness" means that the result will not increase (in the ;;; (unsigned-byte +infinity) sense). An ordinary modular function is ;;; replaced with the version, cutting its result to WIDTH or more -;;; bits. If we have changed anything, we need to flush old derived -;;; types, because they have nothing in common with the new code. +;;; bits. For most functions (e.g. for +) we cut all arguments; for +;;; others (e.g. for ASH) we have "optimizers", cutting only necessary +;;; arguments (maybe to a different width) and returning the name of a +;;; 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) (declare (type lvar lvar) (type (integer 0) width)) (labels ((reoptimize-node (node name) @@ -2533,29 +2553,35 @@ (cut-node (node &aux did-something) (when (and (not (block-delete-p (node-block node))) (combination-p node) - (fun-info-p (basic-combination-kind 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)) - (name (and (modular-fun-info-p modular-fun) - (modular-fun-info-name modular-fun)))) + (modular-fun (find-modular-version fun-name width))) (when (and modular-fun - (not (and (eq name 'logand) + (not (and (eq fun-name 'logand) (csubtypep (single-value-type (node-derived-type node)) - (specifier-type `(unsigned-byte ,width)))))) - (unless (eq modular-fun :good) - (setq did-something t) - (change-ref-leaf + (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)) - (dolist (arg (basic-combination-args node)) - (when (cut-lvar arg) - (setq did-something t))) - (when did-something - (reoptimize-node node fun-name)) - did-something)))) + (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) @@ -2602,22 +2628,22 @@ (give-up-ir1-transform "BOOLE code is not a constant.")) (let ((control (lvar-value op))) (case control - (#.boole-clr 0) - (#.boole-set -1) - (#.boole-1 'x) - (#.boole-2 'y) - (#.boole-c1 '(lognot x)) - (#.boole-c2 '(lognot y)) - (#.boole-and '(logand x y)) - (#.boole-ior '(logior x y)) - (#.boole-xor '(logxor x y)) - (#.boole-eqv '(logeqv x y)) - (#.boole-nand '(lognand x y)) - (#.boole-nor '(lognor x y)) - (#.boole-andc1 '(logandc1 x y)) - (#.boole-andc2 '(logandc2 x y)) - (#.boole-orc1 '(logorc1 x y)) - (#.boole-orc2 '(logorc2 x y)) + (#.sb!xc:boole-clr 0) + (#.sb!xc:boole-set -1) + (#.sb!xc:boole-1 'x) + (#.sb!xc:boole-2 'y) + (#.sb!xc:boole-c1 '(lognot x)) + (#.sb!xc:boole-c2 '(lognot y)) + (#.sb!xc:boole-and '(logand x y)) + (#.sb!xc:boole-ior '(logior x y)) + (#.sb!xc:boole-xor '(logxor x y)) + (#.sb!xc:boole-eqv '(logeqv x y)) + (#.sb!xc:boole-nand '(lognand x y)) + (#.sb!xc:boole-nor '(lognor x y)) + (#.sb!xc:boole-andc1 '(logandc1 x y)) + (#.sb!xc:boole-andc2 '(logandc2 x y)) + (#.sb!xc:boole-orc1 '(logorc1 x y)) + (#.sb!xc:boole-orc2 '(logorc2 x y)) (t (abort-ir1-transform "~S is an illegal control arg to BOOLE." control))))) @@ -3166,13 +3192,13 @@ (if (null rest) `(values (the real ,arg0)) `(let ((maxrest (max ,@rest))) - (if (> ,arg0 maxrest) ,arg0 maxrest))))) + (if (>= ,arg0 maxrest) ,arg0 maxrest))))) (define-source-transform min (arg0 &rest rest) (once-only ((arg0 arg0)) (if (null rest) `(values (the real ,arg0)) `(let ((minrest (min ,@rest))) - (if (< ,arg0 minrest) ,arg0 minrest))))) + (if (<= ,arg0 minrest) ,arg0 minrest))))) ;;;; converting N-arg arithmetic functions ;;;; @@ -3275,12 +3301,6 @@ ;;; for compile-time argument count checking. ;;; -;;; FIXME I: this is currently called from DEFTRANSFORMs, the vast -;;; majority of which are not going to transform the code, but instead -;;; are going to GIVE-UP-IR1-TRANSFORM unconditionally. It would be -;;; nice to make this explicit, maybe by implementing a new -;;; "optimizer" (say, DEFOPTIMIZER CONSISTENCY-CHECK). -;;; ;;; FIXME II: In some cases, type information could be correlated; for ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type ;;; of a corresponding argument is known and does not intersect the @@ -3297,18 +3317,15 @@ (let ((nargs (length args))) (cond ((< nargs min) - (compiler-warn "Too few arguments (~D) to ~S ~S: ~ - requires at least ~D." - nargs fun string min)) + (warn 'format-too-few-args-warning + :format-control + "Too few arguments (~D) to ~S ~S: requires at least ~D." + :format-arguments (list nargs fun string min))) ((> nargs max) - (;; to get warned about probably bogus code at - ;; cross-compile time. - #+sb-xc-host compiler-warn - ;; ANSI saith that too many arguments doesn't cause a - ;; run-time error. - #-sb-xc-host compiler-style-warn - "Too many arguments (~D) to ~S ~S: uses at most ~D." - nargs fun string max))))))) + (warn 'format-too-many-args-warning + :format-control + "Too many arguments (~D) to ~S ~S: uses at most ~D." + :format-arguments (list nargs fun string max)))))))) (defoptimizer (format optimizer) ((dest control &rest args)) (when (constant-lvar-p control) @@ -3381,18 +3398,19 @@ (let ((nargs (length args))) (cond ((< nargs (min min1 min2)) - (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~ - requires at least ~D." - nargs 'cerror y x (min min1 min2))) + (warn 'format-too-few-args-warning + :format-control + "Too few arguments (~D) to ~S ~S ~S: ~ + requires at least ~D." + :format-arguments + (list nargs 'cerror y x (min min1 min2)))) ((> nargs (max max1 max2)) - (;; to get warned about probably bogus code at - ;; cross-compile time. - #+sb-xc-host compiler-warn - ;; ANSI saith that too many arguments doesn't cause a - ;; run-time error. - #-sb-xc-host compiler-style-warn - "Too many arguments (~D) to ~S ~S ~S: uses at most ~D." - nargs 'cerror y x (max max1 max2))))))))))))) + (warn 'format-too-many-args-warning + :format-control + "Too many arguments (~D) to ~S ~S ~S: ~ + uses at most ~D." + :format-arguments + (list nargs 'cerror y x (max max1 max2)))))))))))))) (defoptimizer (coerce derive-type) ((value type)) (cond @@ -3573,7 +3591,17 @@ (t *universal-type*))))) +;;; Like CMU CL, we use HEAPSORT. However, other than that, this code +;;; isn't really related to the CMU CL code, since instead of trying +;;; to generalize the CMU CL code to allow START and END values, this +;;; code has been written from scratch following Chapter 7 of +;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. (define-source-transform sb!impl::sort-vector (vector start end predicate key) + ;; Like CMU CL, we use HEAPSORT. However, other than that, this code + ;; isn't really related to the CMU CL code, since instead of trying + ;; to generalize the CMU CL code to allow START and END values, this + ;; code has been written from scratch following Chapter 7 of + ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. `(macrolet ((%index (x) `(truly-the index ,x)) (%parent (i) `(ash ,i -1)) (%left (i) `(%index (ash ,i 1))) @@ -3607,15 +3635,16 @@ (%elt largest) i-elt i largest))))))))) (%sort-vector (keyfun &optional (vtype 'vector)) - `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting - ;; type inference to propagate all the way - ;; through this tangled mess of - ;; inlining. The TRULY-THE here works - ;; around that. -- WHN + `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had + ;; trouble getting type inference to + ;; propagate all the way through this + ;; tangled mess of inlining. The TRULY-THE + ;; here works around that. -- WHN (%elt (i) `(aref (truly-the ,',vtype ,',',vector) (%index (+ (%index ,i) start-1))))) - (let ((start-1 (1- ,',start)) ; Heaps prefer 1-based addressing. + (let (;; Heaps prefer 1-based addressing. + (start-1 (1- ,',start)) (current-heap-size (- ,',end ,',start)) (keyfun ,keyfun)) (declare (type (integer -1 #.(1- most-positive-fixnum))