From: Alexey Dejneka Date: Tue, 26 Aug 2003 08:58:30 +0000 (+0000) Subject: 0.8.3.2: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b42068e9080417a073dcb709cdd2e0315599b3df;hp=2378b4fe567a8fea78b1e4915b9497d8c18ca92f;p=sbcl.git 0.8.3.2: * SB-SIMPLE-STREAMS: ... implement WRITE-SEQUENCE for single channel streams; ... fix bug in tests, causing random test failures; * add declarations to SCALE-EXPONENT; * remove obsolete type declarations in MIX; * change type inference for iteration-like variables: if interval type is successfuly derived, ignore other inferred information. --- diff --git a/BUGS b/BUGS index 84357b1..dc5f0b3 100644 --- a/BUGS +++ b/BUGS @@ -1106,6 +1106,16 @@ WORKAROUND: IGNORE/IGNORABLE declarations should be acceptable for symbol macros. +278: + a. + (defun foo () + (declare (optimize speed)) + (loop for i of-type (integer 0) from 0 by 2 below 10 + collect i)) + + uses generic arithmetic. + + b. For the example above, the compiler does not issue a note. DEFUNCT CATEGORIES OF BUGS IR1-#: diff --git a/NEWS b/NEWS index 27a9263..1cb34d0 100644 --- a/NEWS +++ b/NEWS @@ -2001,6 +2001,9 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: new array subtypes UNSIGNED-BYTE 7, 15, 29, and 31 mandated by obscure ANSI requirements +changes in sbcl-0.8.4 relative to sbcl-0.8.3: + * fixed compiler performance when processing loops with a step >1; + planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles down, it might impact TRACE. They both encapsulate functions, and diff --git a/contrib/sb-simple-streams/cl.lisp b/contrib/sb-simple-streams/cl.lisp index 0e00408..0df60ea 100644 --- a/contrib/sb-simple-streams/cl.lisp +++ b/contrib/sb-simple-streams/cl.lisp @@ -350,7 +350,7 @@ ;; single-channel-simple-stream (with-stream-class (single-channel-simple-stream stream) (let ((ptr (sm buffpos stream))) - (when (>= ptr (sm buffer-ptr stream)) + (when (>= ptr (sm buf-len stream)) (setf ptr (sc-flush-buffer stream t))) (add-stream-instance-flags stream :dirty) (setf (sm buffpos stream) (1+ ptr)) @@ -397,7 +397,31 @@ ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*))) ;; "write-vector" equivalent - (error "implement me") + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (with-stream-class (single-channel-simple-stream stream) + (loop with max-ptr = (sm buf-len stream) + with real-end = (or end (length seq)) + for src-pos = start then (+ src-pos count) + for src-rest = (- real-end src-pos) + while (> src-rest 0) ; FIXME: this is non-ANSI + for ptr = (let ((ptr (sm buffpos stream))) + (if (>= ptr max-ptr) + (sc-flush-buffer stream t) + ptr)) + for buf-rest = (- max-ptr ptr) + for count = (min buf-rest src-rest) + do (progn (add-stream-instance-flags stream :dirty) + (setf (sm buffpos stream) (+ ptr count)) + (buffer-copy seq src-pos (sm buffer stream) ptr count)))) + ;; dual-channel-simple-stream + (error "Implement me") + ;; string-simple-stream + (error 'simple-type-error + :datum stream + :expected-type 'stream + :format-control "Can't write-byte on string streams." + :format-arguments '())) )))) diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp index 010d0ab..0373f75 100644 --- a/contrib/sb-simple-streams/simple-stream-tests.lisp +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -16,13 +16,21 @@ (eval-when (:load-toplevel) (ensure-directories-exist *test-path*)) +;;; Non-destructive functional analog of REMF +(defun remove-key (key list) + (loop for (current-key val . rest) on list by #'cddr + until (eql current-key key) + collect current-key into result + collect val into result + finally (return (nconc result rest)))) + (defmacro with-test-file ((stream file &rest open-arguments &key (delete-afterwards t) initial-content &allow-other-keys) &body body) - (remf open-arguments :delete-afterwards) - (remf open-arguments :initial-content) + (setq open-arguments (remove-key :delete-afterwards open-arguments)) + (setq open-arguments (remove-key :initial-content open-arguments)) (if initial-content (let ((create-file-stream (gensym))) `(progn @@ -125,6 +133,48 @@ (string= content (read-line s)))) t) +(deftest write-read-large-sc-2 + (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)) + (stream (make-instance 'file-simple-stream + :filename file :direction :output + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-string length))) + (dotimes (i (length content)) + (setf (aref content i) (code-char (random 256)))) + (with-open-stream (s stream) + (write-string content s)) + (with-test-file (s file :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-string length))) + #+nil (read-sequence seq s) + #-nil (dotimes (i length) + (setf (char seq i) (read-char s))) + (string= content seq)))) + t) + +(deftest write-read-large-sc-3 + (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)) + (stream (make-instance 'file-simple-stream + :filename file :direction :output + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-array length :element-type '(unsigned-byte 8)))) + (dotimes (i (length content)) + (setf (aref content i) (random 256))) + (with-open-stream (s stream) + (write-sequence content s)) + (with-test-file (s file :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-array length :element-type '(unsigned-byte 8)))) + #+nil (read-sequence seq s) + #-nil (dotimes (i length) + (setf (aref seq i) (read-byte s))) + (equalp content seq)))) + t) + (deftest write-read-large-dc-1 ;; Do write and read with more data than the buffer will hold ;; (dual-channel simple-stream; we only have socket streams atm) @@ -152,7 +202,6 @@ ;;; file-position-2 fails ONLY when called with ;;; (asdf:oos 'asdf:test-op :sb-simple-streams) ;;; TODO: Find out why -#+nil (deftest file-position-2 ;; Test reading of file-position (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))) @@ -254,7 +303,3 @@ (read-line s))) "XooX" T) - - - - diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index cbe4cb4..71dbdd9 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1173,6 +1173,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "NOT-DUMPED-AT-ALL" "NUMERIC-CONTAGION" "NUMERIC-TYPE" "NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP" + "NUMERIC-TYPE-EQUAL" "NUMERIC-TYPE-FORMAT" "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P" "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR" diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index e0b7317..4e16fbb 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1503,11 +1503,15 @@ (!define-type-class number) +(declaim (inline numeric-type-equal)) +(defun numeric-type-equal (type1 type2) + (and (eq (numeric-type-class type1) (numeric-type-class type2)) + (eq (numeric-type-format type1) (numeric-type-format type2)) + (eq (numeric-type-complexp type1) (numeric-type-complexp type2)))) + (!define-type-method (number :simple-=) (type1 type2) (values - (and (eq (numeric-type-class type1) (numeric-type-class type2)) - (eq (numeric-type-format type1) (numeric-type-format type2)) - (eq (numeric-type-complexp type1) (numeric-type-complexp type2)) + (and (numeric-type-equal type1 type2) (equalp (numeric-type-low type1) (numeric-type-low type2)) (equalp (numeric-type-high type1) (numeric-type-high type2))) t)) diff --git a/src/code/print.lisp b/src/code/print.lisp index 68dffb6..7cd5d36 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1402,7 +1402,9 @@ (declare (ignore sig)) (if (= x 0.0e0) (values (float 0.0e0 original-x) 1) - (let* ((ex (round (* exponent (log 2e0 10)))) + (let* ((ex (locally (declare (optimize (safety 0))) + (the fixnum + (round (* exponent (log 2e0 10)))))) (x (if (minusp ex) (if (float-denormalized-p x) #!-long-float @@ -1419,7 +1421,9 @@ (z y (* y m)) (ex ex (1- ex))) ((>= z 0.1e0) - (values (float z original-x) ex)))))))))) + (values (float z original-x) ex)) + (declare (long-float m) (integer ex)))) + (declare (long-float d)))))))) (eval-when (:compile-toplevel :execute) (setf *read-default-float-format* 'single-float)) diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index 74e739b..571b9c1 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -63,12 +63,10 @@ ;; algorithms, but we're not pushing them hard enough here for them ;; to be cryptographically strong.) (let* ((xy (+ (* x 3) y))) - (declare (type (unsigned-byte 32) xy)) - (the (and fixnum unsigned-byte) - (logand most-positive-fixnum - (logxor 441516657 - xy - (the fixnum (ash xy -5))))))) + (logand most-positive-fixnum + (logxor 441516657 + xy + (ash xy -5))))) ;;;; hashing strings ;;;; diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index f31fb9c..ff627a5 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1273,20 +1273,22 @@ (and (ref-p first) (eq (ref-leaf first) var)))) :exit-if-null) - (step-type (continuation-type (second +-args)))) + (step-type (continuation-type (second +-args))) + (set-type (continuation-type (set-value set)))) (when (and (numeric-type-p initial-type) (numeric-type-p step-type) - (eq (numeric-type-class initial-type) - (numeric-type-class step-type)) - (eq (numeric-type-format initial-type) - (numeric-type-format step-type)) - (eq (numeric-type-complexp initial-type) - (numeric-type-complexp step-type))) + (numeric-type-equal initial-type step-type)) (multiple-value-bind (low high) (cond ((csubtypep step-type (specifier-type '(real 0 *))) - (values (numeric-type-low initial-type) nil)) + (values (numeric-type-low initial-type) + (when (and (numeric-type-p set-type) + (numeric-type-equal set-type initial-type)) + (numeric-type-high set-type)))) ((csubtypep step-type (specifier-type '(real * 0))) - (values nil (numeric-type-high initial-type))) + (values (when (and (numeric-type-p set-type) + (numeric-type-equal set-type initial-type)) + (numeric-type-low set-type)) + (numeric-type-high initial-type))) (t (values nil nil))) (modified-numeric-type initial-type @@ -1317,7 +1319,7 @@ (setf (node-reoptimize set) nil)))) (let ((res (res))) (awhen (maybe-infer-iteration-var-type var initial-type) - (setq res (type-intersection res it))) + (setq res it)) (propagate-to-refs var res))) (values)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 2f56497..fb6f0f7 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3677,5 +3677,5 @@ (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x))) (format t "/MESSAGE=~S~%" (continuation-value message)) (give-up-ir1-transform "not a real transform")) - (defun /report-continuation (&rest rest) - (declare (ignore rest)))) + (defun /report-continuation (x message) + (declare (ignore x message)))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 5066830..82b1e2b 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -491,3 +491,18 @@ (setf (aref x 4) 'b) x)))) #(a a a a b a a a a a)))) + +;;; this is not a check for a bug, but rather a test of compiler +;;; quality +(dolist (type '((integer 0 *) ; upper bound + (real (-1) *) + float ; class + (real * (-10)) ; lower bound + )) + (assert (nth-value + 1 (compile nil + `(lambda (n) + (declare (optimize (speed 3) (compilation-speed 0))) + (loop for i from 1 to (the (integer -17 10) n) by 2 + collect (when (> (random 10) 5) + (the ,type (- i 11))))))))) diff --git a/version.lisp-expr b/version.lisp-expr index 94b9c85..4fd277c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; with something arbitrary in the fourth field, is used for CVS ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS -"0.8.3.1" +"0.8.3.2"