215067723)
13739018))
+\f
+;;;; Bugs in stack analysis
;;; bug 299 (reported by PFD)
(assert
(equal (funcall
(if (eval t) (eval '(values :a :b :c)) nil)
(catch 'foo (throw 'foo (values :x :y)))))))
'(:a :b :c :x :y)))
+;;; bug 298 (= MISC.183)
+(assert (zerop (funcall
+ (compile
+ nil
+ '(lambda (a b c)
+ (declare (type (integer -368154 377964) a))
+ (declare (type (integer 5044 14959) b))
+ (declare (type (integer -184859815 -8066427) c))
+ (declare (ignorable a b c))
+ (declare (optimize (speed 3)))
+ (declare (optimize (safety 1)))
+ (declare (optimize (debug 1)))
+ (block b7
+ (flet ((%f3 (f3-1 f3-2 f3-3) 0))
+ (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
+ 0 6000 -9000000)))
+(assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
+ '(1 2)))
+(let ((f (compile
+ nil
+ '(lambda (x)
+ (block foo
+ (multiple-value-call #'list
+ :a
+ (block bar
+ (return-from foo
+ (multiple-value-call #'list
+ :b
+ (block quux
+ (return-from bar
+ (catch 'baz
+ (if x
+ (return-from quux 1)
+ (throw 'baz 2))))))))))))))
+ (assert (equal (funcall f t) '(:b 1)))
+ (assert (equal (funcall f nil) '(:a 2))))
+
;;; MISC.185
(assert (equal
(funcall
:good
(values result1 result2))))
:good))
+
+;;; MISC.290
+(assert (zerop
+ (funcall
+ (compile
+ nil
+ '(lambda ()
+ (declare
+ (optimize (speed 3) (space 3) (safety 1)
+ (debug 2) (compilation-speed 0)))
+ (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
+
+;;; MISC.292
+(assert (zerop (funcall
+ (compile
+ nil
+ '(lambda (a b)
+ (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
+ (compilation-speed 2)))
+ (apply (constantly 0)
+ a
+ 0
+ (catch 'ct6
+ (apply (constantly 0)
+ 0
+ 0
+ (let* ((v1
+ (let ((*s7* 0))
+ b)))
+ 0)
+ 0
+ nil))
+ 0
+ nil)))
+ 1 2)))
+
+;;; misc.295
+(assert (eql
+ (funcall
+ (compile
+ nil
+ '(lambda ()
+ (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
+ (multiple-value-prog1
+ (the integer (catch 'ct8 (catch 'ct7 15867134)))
+ (catch 'ct1 (throw 'ct1 0))))))
+ 15867134))
+
+;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
+;;; could transform known-values LVAR to UVL
+(assert (zerop (funcall
+ (compile
+ nil
+ '(lambda (a b c)
+ (declare (notinline boole values denominator list))
+ (declare
+ (optimize (speed 2)
+ (space 0)
+ (safety 1)
+ (debug 0)
+ (compilation-speed 2)))
+ (catch 'ct6
+ (progv
+ '(*s8*)
+ (list 0)
+ (let ((v9 (ignore-errors (throw 'ct6 0))))
+ (denominator
+ (progv nil nil (values (boole boole-and 0 v9)))))))))
+ 1 2 3)))
+
+;;; non-continuous dead UVL blocks
+(defun non-continuous-stack-test (x)
+ (multiple-value-call #'list
+ (eval '(values 11 12))
+ (eval '(values 13 14))
+ (block ext
+ (return-from non-continuous-stack-test
+ (multiple-value-call #'list
+ (eval '(values :b1 :b2))
+ (eval '(values :b3 :b4))
+ (block int
+ (return-from ext
+ (multiple-value-call (eval #'values)
+ (eval '(values 1 2))
+ (eval '(values 3 4))
+ (block ext
+ (return-from int
+ (multiple-value-call (eval #'values)
+ (eval '(values :a1 :a2))
+ (eval '(values :a3 :a4))
+ (block int
+ (return-from ext
+ (multiple-value-call (eval #'values)
+ (eval '(values 5 6))
+ (eval '(values 7 8))
+ (if x
+ :ext
+ (return-from int :int))))))))))))))))
+(assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
+(assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
+
+;;; MISC.362: environment of UNWIND-PROTECTor is different from that
+;;; if ENTRY.
+(assert (equal (multiple-value-list (funcall
+ (compile
+ nil
+ '(lambda (b g h)
+ (declare (optimize (speed 3) (space 3) (safety 2)
+ (debug 2) (compilation-speed 3)))
+ (catch 'ct5
+ (unwind-protect
+ (labels ((%f15 (f15-1 f15-2 f15-3)
+ (rational (throw 'ct5 0))))
+ (%f15 0
+ (apply #'%f15
+ 0
+ h
+ (progn
+ (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
+ 0)
+ nil)
+ 0))
+ (common-lisp:handler-case 0)))))
+ 1 2 3))
+ '(0)))
+
+\f
;;; MISC.275
(assert
(zerop
(type (unsigned-byte 32) i))
(deref a i))))
(compiler-note () (error "The code is not optimized.")))
+
+(handler-case
+ (compile nil '(lambda (x)
+ (declare (type (integer -100 100) x))
+ (declare (optimize speed))
+ (declare (notinline identity))
+ (1+ (identity x))))
+ (compiler-note () (error "IDENTITY derive-type not applied.")))
+
+(assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
+
+;;; MISC.293 = easy variant of bug 303: repeated write to the same
+;;; LVAR; here the first write may be cleared before the second is
+;;; made.
+(assert
+ (zerop
+ (funcall
+ (compile
+ nil
+ '(lambda ()
+ (declare (notinline complex))
+ (declare (optimize (speed 1) (space 0) (safety 1)
+ (debug 3) (compilation-speed 3)))
+ (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
+ (complex (%f) 0)))))))
+
+;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
+(assert (zerop (funcall
+ (compile
+ nil
+ '(lambda (a c)
+ (declare (type (integer -1294746569 1640996137) a))
+ (declare (type (integer -807801310 3) c))
+ (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
+ (catch 'ct7
+ (if
+ (logbitp 0
+ (if (/= 0 a)
+ c
+ (ignore-errors
+ (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
+ 0 0))))
+ 391833530 -32785211)))
+
+;;; efficiency notes for ordinary code
+(macrolet ((frob (arglist &body body)
+ `(progn
+ (handler-case
+ (compile nil '(lambda ,arglist ,@body))
+ (sb-ext:compiler-note (e)
+ (error "bad compiler note for ~S:~% ~A" ',body e)))
+ (catch :got-note
+ (handler-case
+ (compile nil '(lambda ,arglist (declare (optimize speed))
+ ,@body))
+ (sb-ext:compiler-note (e) (throw :got-note nil)))
+ (error "missing compiler note for ~S" ',body)))))
+ (frob (x) (funcall x))
+ (frob (x y) (find x y))
+ (frob (x y) (find-if x y))
+ (frob (x y) (find-if-not x y))
+ (frob (x y) (position x y))
+ (frob (x y) (position-if x y))
+ (frob (x y) (position-if-not x y))
+ (frob (x) (aref x 0)))
+
+(macrolet ((frob (style-warn-p form)
+ (if style-warn-p
+ `(catch :got-style-warning
+ (handler-case
+ (eval ',form)
+ (style-warning (e) (throw :got-style-warning nil)))
+ (error "missing style-warning for ~S" ',form))
+ `(handler-case
+ (eval ',form)
+ (style-warning (e)
+ (error "bad style-warning for ~S: ~A" ',form e))))))
+ (frob t (lambda (x &optional y &key z) (list x y z)))
+ (frob nil (lambda (x &optional y z) (list x y z)))
+ (frob nil (lambda (x &key y z) (list x y z)))
+ (frob t (defgeneric #:foo (x &optional y &key z)))
+ (frob nil (defgeneric #:foo (x &optional y z)))
+ (frob nil (defgeneric #:foo (x &key y z)))
+ (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
+
+;;; this was a bug in the LOGXOR type deriver. The top form gave a
+;;; note, because the system failed to derive the fact that the return
+;;; from LOGXOR was small and negative, though the bottom one worked.
+(handler-bind ((sb-ext:compiler-note #'error))
+ (compile nil '(lambda ()
+ (declare (optimize speed (safety 0)))
+ (lambda (x y)
+ (declare (type (integer 3 6) x)
+ (type (integer -6 -3) y))
+ (+ (logxor x y) most-positive-fixnum)))))
+(handler-bind ((sb-ext:compiler-note #'error))
+ (compile nil '(lambda ()
+ (declare (optimize speed (safety 0)))
+ (lambda (x y)
+ (declare (type (integer 3 6) y)
+ (type (integer -6 -3) x))
+ (+ (logxor x y) most-positive-fixnum)))))
+
+;;; check that modular ash gives the right answer, to protect against
+;;; possible misunderstandings about the hardware shift instruction.
+(assert (zerop (funcall
+ (compile nil '(lambda (x y)
+ (declare (optimize speed)
+ (type (unsigned-byte 32) x y))
+ (logand #xffffffff (ash x y))))
+ 1 257)))
+
+;;; code instrumenting problems
+(compile nil
+ '(lambda ()
+ (declare (optimize (debug 3)))
+ (list (the integer (if nil 14 t)))))
+
+(compile nil
+ '(LAMBDA (A B C D)
+ (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
+ (DECLARE
+ (OPTIMIZE (SPEED 1)
+ (SPACE 1)
+ (SAFETY 1)
+ (DEBUG 3)
+ (COMPILATION-SPEED 0)))
+ (MASK-FIELD (BYTE 7 26)
+ (PROGN
+ (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
+ B))))
+
+(compile nil
+ '(lambda (buffer i end)
+ (declare (optimize (debug 3)))
+ (loop (when (not (eql 0 end)) (return)))
+ (let ((s (make-string end)))
+ (setf (schar s i) (schar buffer i))
+ s)))
+
+;;; check that constant string prefix and suffix don't cause the
+;;; compiler to emit code deletion notes.
+(handler-bind ((sb-ext:code-deletion-note #'error))
+ (compile nil '(lambda (s x)
+ (pprint-logical-block (s x :prefix "(")
+ (print x s))))
+ (compile nil '(lambda (s x)
+ (pprint-logical-block (s x :per-line-prefix ";")
+ (print x s))))
+ (compile nil '(lambda (s x)
+ (pprint-logical-block (s x :suffix ">")
+ (print x s)))))
+
+;;; MISC.427: loop analysis requires complete DFO structure
+(assert (eql 17 (funcall
+ (compile
+ nil
+ '(lambda (a)
+ (declare (notinline list reduce logior))
+ (declare (optimize (safety 2) (compilation-speed 1)
+ (speed 3) (space 2) (debug 2)))
+ (logior
+ (let* ((v5 (reduce #'+ (list 0 a))))
+ (declare (dynamic-extent v5))
+ v5))))
+ 17)))
projects / sbcl.git / blobdiff