(flet ((time-it (lambda want)
(gc :full t) ; let's keep GCs coming from other code out...
(let* ((start (get-internal-run-time))
- (fun (compile nil lambda))
+ (fun (dotimes (internal-time-resolution-too-low-workaround
+ #+win32 10
+ #-win32 0
+ (compile nil lambda))
+ (compile nil lambda)))
(end (get-internal-run-time))
(got (funcall fun)))
(unless (eql want got)
(with-test (:name :multiple-args-to-function)
(let ((form `(flet ((foo (&optional (x 13)) x))
(funcall (function foo 42))))
- (*evaluator-mode* :interpret))
+ #+sb-eval (*evaluator-mode* :interpret))
+ #+sb-eval
(assert (eq :error
(handler-case (eval form)
(error () :error))))
,@(loop for i from 27 to 32
collect (expt 2 i)))))))
(assert (every #'plusp (funcall f #'list)))))
+
+(with-test (:name (:malformed-ignore :lp-1000239))
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function . a)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function a b)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (a)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignorable (a b)))))
+ sb-int:compiled-program-error))
+
+(with-test (:name :malformed-type-declaraions)
+ (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
+
+(with-test (:name :compiled-program-error-escaped-source)
+ (assert
+ (handler-case
+ (funcall (compile nil `(lambda () (lambda ("foo")))))
+ (sb-int:compiled-program-error (e)
+ (let ((source (read-from-string (sb-kernel::program-error-source e))))
+ (equal source '#'(lambda ("foo"))))))))
+
+(with-test (:name :escape-analysis-for-nlxs)
+ (flet ((test (check lambda &rest args)
+ (let* ((cell-note nil)
+ (fun (handler-bind ((compiler-note
+ (lambda (note)
+ (when (search
+ "Allocating a value-cell at runtime for"
+ (princ-to-string note))
+ (setf cell-note t)))))
+ (compile nil lambda))))
+ (assert (eql check cell-note))
+ (if check
+ (assert
+ (eq :ok
+ (handler-case
+ (dolist (arg args nil)
+ (setf fun (funcall fun arg)))
+ (sb-int:simple-control-error (e)
+ (when (equal
+ (simple-condition-format-control e)
+ "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
+ :ok)))))
+ (ctu:assert-no-consing (apply fun args))))))
+ (test nil `(lambda (x)
+ (declare (optimize speed))
+ (block out
+ (flet ((ex () (return-from out 'out!)))
+ (typecase x
+ (cons (or (car x) (ex)))
+ (t (ex)))))) :foo)
+ (test t `(lambda (x)
+ (declare (optimize speed))
+ (funcall
+ (block nasty
+ (flet ((oops () (return-from nasty t)))
+ #'oops)))) t)
+ (test t `(lambda (r)
+ (declare (optimize speed))
+ (block out
+ (flet ((ex () (return-from out r)))
+ (lambda (x)
+ (typecase x
+ (cons (or (car x) (ex)))
+ (t (ex))))))) t t)
+ (test t `(lambda (x)
+ (declare (optimize speed))
+ (flet ((eh (x)
+ (flet ((meh () (return-from eh 'meh)))
+ (lambda ()
+ (typecase x
+ (cons (or (car x) (meh)))
+ (t (meh)))))))
+ (funcall (eh x)))) t t)))
+
+(with-test (:name (:bug-1050768 :symptom))
+ ;; Used to signal an error.
+ (compile nil
+ `(lambda (string position)
+ (char string position)
+ (array-in-bounds-p string (1+ position)))))
+
+(with-test (:name (:bug-1050768 :cause))
+ (let ((types `((string string)
+ ((or (simple-array character 24) (vector t 24))
+ (or (simple-array character 24) (vector t))))))
+ (dolist (pair types)
+ (destructuring-bind (orig conservative) pair
+ (assert sb-c::(type= (specifier-type cl-user::conservative)
+ (conservative-type (specifier-type cl-user::orig))))))))
+
+(with-test (:name (:smodular64 :wrong-width))
+ (let ((fun (compile nil
+ '(lambda (x)
+ (declare (type (signed-byte 64) x))
+ (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
+ (assert (= (funcall fun 10038) -7033717698976955535))))
+
+(with-test (:name (:smodular32 :wrong-width))
+ (let ((fun (compile nil '(lambda (x)
+ (declare (type (signed-byte 31) x))
+ (sb-c::mask-signed-field 31 (- x 1055131947))))))
+ (assert (= (funcall fun 10038) -1055121909))))
+
+(with-test (:name :first-open-coded)
+ (let ((fun (compile nil `(lambda (x) (first x)))))
+ (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :second-open-coded)
+ (let ((fun (compile nil `(lambda (x) (second x)))))
+ (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :svref-of-symbol-macro)
+ (compile nil `(lambda (x)
+ (symbol-macrolet ((sv x))
+ (values (svref sv 0) (setf (svref sv 0) 99))))))
+
+;; The compiler used to update the receiving LVAR's type too
+;; aggressively when converting a large constant to a smaller
+;; (potentially signed) one, causing other branches to be
+;; inferred as dead.
+(with-test (:name :modular-cut-constant-to-width)
+ (let ((test (compile nil
+ `(lambda (x)
+ (logand 254
+ (case x
+ ((3) x)
+ ((2 2 0 -2 -1 2) 9223372036854775803)
+ (t 358458651)))))))
+ (assert (= (funcall test -10470605025) 26))))
+
+(with-test (:name :append-type-derivation)
+ (let ((test-cases
+ '((lambda () (append 10)) (integer 10 10)
+ (lambda () (append nil 10)) (integer 10 10)
+ (lambda (x) (append x 10)) t
+ (lambda (x) (append x (cons 1 2))) cons
+ (lambda (x y) (append x (cons 1 2) y)) cons
+ (lambda (x y) (nconc x (the list y) x)) t
+ (lambda (x y) (print (length y)) (append x y)) sequence)))
+ (loop for (function result-type) on test-cases by #'cddr
+ do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type
+ (compile nil function))))
+ result-type)))))
+
+(with-test (:name :bug-504121)
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g)
+ (funcall p1 g))))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-missing))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &optional x)
+ (funcall p1 g))))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-superfluous))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &optional x)
+ (funcall p1 g))
+ #\1 2 3))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-odd))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &key x)
+ (funcall p1 g))
+ #\1 :x))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-unknown))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &key x)
+ (funcall p1 g))
+ #\1 :y 2))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name :bug-1181684)
+ (compile nil `(lambda ()
+ (let ((hash #xD13CCD13))
+ (setf hash (logand most-positive-word
+ (ash hash 5)))))))
+
+(with-test (:name (local-&optional-recursive-inline :bug-1180992))
+ (compile nil
+ `(lambda ()
+ (labels ((called (&optional a))
+ (recursed (&optional b)
+ (called)
+ (recursed)))
+ (declare (inline recursed called))
+ (recursed)))))
+
+(with-test (:name :constant-fold-logtest)
+ (assert (equal (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (declare (type (mod 1024) x)
+ (optimize speed))
+ (logtest x 2048))))
+ '(function ((unsigned-byte 10)) (values null &optional)))))
projects / sbcl.git / blobdiff