X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fcompiler.impure.lisp;h=2502ae2d49e1c0a8abb19bb5038f4beede76010b;hb=b025fdbef7236941a6389fe6fa9d9903d2a5cab7;hp=1246cdbc8a43dfa65c97732c7d57312876d9a79b;hpb=d59fb3b0953c8d14427b60f949a0e567a8b79fe0;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 1246cdb..2502ae2 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -15,6 +15,9 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(when (eq sb-ext:*evaluator-mode* :interpret)
+  (sb-ext:quit :unix-status 104))
+
 (load "test-util.lisp")
 (load "assertoid.lisp")
 (use-package "TEST-UTIL")
@@ -1201,4 +1204,443 @@
         (setf (fill-pointer result) index)
         (coerce result 'string)))))
 
+;;; Callign thru constant symbols
+(require :sb-introspect)
+
+(declaim (inline target-fun))
+(defun target-fun (arg0 arg1)
+  (+ arg0 arg1))
+(declaim (notinline target-fun))
+
+(defun test-target-fun-called (fun res)
+  (assert (member #'target-fun
+                  (sb-introspect:find-function-callees #'caller-fun-1)))
+  (assert (equal (funcall fun) res)))
+
+(defun caller-fun-1 ()
+  (funcall 'target-fun 1 2))
+(test-target-fun-called #'caller-fun-1 3)
+
+(defun caller-fun-2 ()
+  (declare (inline target-fun))
+  (apply 'target-fun 1 '(3)))
+(test-target-fun-called #'caller-fun-2 4)
+
+(defun caller-fun-3 ()
+  (flet ((target-fun (a b)
+           (- a b)))
+    (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4))))
+(test-target-fun-called #'caller-fun-3 (list -3 5))
+
+;;; Reported by NIIMI Satoshi
+;;; Subject: [Sbcl-devel] compilation error with optimization
+;;; Date: Sun, 09 Apr 2006 17:36:05 +0900
+(defun test-minimal-debug-info-for-unstored-but-used-parameter (n a)
+  (declare (optimize (speed 3)
+                     (debug 1)))
+  (if (= n 0)
+      0
+      (test-minimal-debug-info-for-unstored-but-used-parameter (1- n) a)))
+
+;;; &KEY arguments with non-constant defaults.
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
+(defstruct tricky-defaults
+  (fun #'identity :type function)
+  (num (opaque-identity 3) :type fixnum))
+(macrolet ((frob (form expected-expected-type)
+             `(handler-case ,form
+               (type-error (c) (assert (eq (type-error-expected-type c)
+                                           ',expected-expected-type)))
+               (:no-error (&rest vals) (error "~S returned values: ~S" ',form vals)))))
+  (frob (make-tricky-defaults :fun 3) function)
+  (frob (make-tricky-defaults :num #'identity) fixnum))
+
+(let ((fun (compile nil '(lambda (&key (key (opaque-identity 3)))
+                          (declare (optimize safety) (type integer key))
+                          key))))
+  (assert (= (funcall fun) 3))
+  (assert (= (funcall fun :key 17) 17))
+  (handler-case (funcall fun :key t)
+    (type-error (c) (assert (eq (type-error-expected-type c) 'integer)))
+    (:no-error (&rest vals) (error "no error"))))
+
+;;; Basic compiler-macro expansion
+(define-compiler-macro test-cmacro-0 () ''expanded)
+
+(assert (eq 'expanded (funcall (lambda () (test-cmacro-0)))))
+
+;;; FUNCALL forms in compiler macros, lambda-list parsing
+(define-compiler-macro test-cmacro-1
+    (&whole whole a &optional b &rest c &key d)
+  (list whole a b c d))
+
+(macrolet ((test (form a b c d)
+             `(let ((form ',form))
+                (destructuring-bind (whole a b c d)
+                    (funcall (compiler-macro-function 'test-cmacro-1) form nil)
+                  (assert (equal whole form))
+                  (assert (eql a ,a))
+                  (assert (eql b ,b))
+                  (assert (equal c ,c))
+                  (assert (eql d ,d))))) )
+  (test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3)
+  (test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13))
+
+;;; FUNCALL forms in compiler macros, expansions
+(define-compiler-macro test-cmacro-2 () ''ok)
+
+(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2)))))
+(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2)))))
+
+;;; Shadowing of compiler-macros by local functions
+(define-compiler-macro test-cmacro-3 () ''global)
+
+(defmacro find-cmacro-3 (&environment env)
+  (compiler-macro-function 'test-cmacro-3 env))
+
+(assert (funcall (lambda () (find-cmacro-3))))
+(assert (not (funcall (lambda () (flet ((test-cmacro-3 ()))
+                                   (find-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+                                         (test-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+                                         (funcall #'test-cmacro-3))))))
+(assert (eq 'global (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+                                          (funcall 'test-cmacro-3))))))
+
+;;; Local NOTINLINE & INLINE
+(defun test-cmacro-4 () 'fun)
+(define-compiler-macro test-cmacro-4 () ''macro)
+
+(assert (eq 'fun (funcall (lambda ()
+                            (declare (notinline test-cmacro-4))
+                            (test-cmacro-4)))))
+
+(assert (eq 'macro (funcall (lambda ()
+                              (declare (inline test-cmacro-4))
+                              (test-cmacro-4)))))
+
+;;; SETF function compiler macros
+(define-compiler-macro (setf test-cmacro-4) (&whole form value) ''ok)
+
+(assert (eq 'ok (funcall (lambda () (setf (test-cmacro-4) 'zot)))))
+(assert (eq 'ok (funcall (lambda () (funcall #'(setf test-cmacro-4) 'zot)))))
+
+;;; Step instrumentation breaking type-inference
+(handler-bind ((warning #'error))
+  (assert (= 42 (funcall (compile nil '(lambda (v x)
+                                        (declare (optimize sb-c:insert-step-conditions))
+                                        (if (typep (the function x) 'fixnum)
+                                            (svref v (the function x))
+                                            (funcall x))))
+                         nil (constantly 42)))))
+
+;;; bug 368: array type intersections in the compiler
+(defstruct e368)
+(defstruct i368)
+(defstruct g368
+  (i368s (make-array 0 :fill-pointer t) :type (or (vector i368) null)))
+(defstruct s368
+  (g368 (error "missing :G368") :type g368 :read-only t))
+(declaim (ftype (function (fixnum (vector i368) e368) t) r368))
+(declaim (ftype (function (fixnum (vector e368)) t) h368))
+(defparameter *h368-was-called-p* nil)
+(defun nsu (vertices e368)
+  (let ((i368s (g368-i368s (make-g368))))
+    (let ((fuis (r368 0 i368s e368)))
+      (format t "~&FUIS=~S~%" fuis)
+      (or fuis (h368 0 i368s)))))
+(defun r368 (w x y)
+  (declare (ignore w x y))
+  nil)
+(defun h368 (w x)
+  (declare (ignore w x))
+  (setf *h368-was-called-p* t)
+  (make-s368 :g368 (make-g368)))
+(let ((nsu (nsu #() (make-e368))))
+  (format t "~&NSU returned ~S~%" nsu)
+  (format t "~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p*)
+  (assert (s368-p nsu))
+  (assert *h368-was-called-p*))
+
+;;; bug 367: array type intersections in the compiler
+(defstruct e367)
+(defstruct i367)
+(defstruct g367
+  (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null)))
+(defstruct s367
+  (g367 (error "missing :G367") :type g367 :read-only t))
+(declaim (ftype (function ((vector i367) e367) (or s367 null)) r367))
+(declaim (ftype (function ((vector e367)) (values)) h367))
+(defun frob-367 (v w)
+  (let ((x (g367-i367s (make-g367))))
+    (let* ((y (or (r367 x w)
+                  (h367 x)))
+           (z (s367-g367 y)))
+      (format t "~&Y=~S Z=~S~%" y z)
+      (g367-i367s z))))
+(defun r367 (x y) (declare (ignore x y)) nil)
+(defun h367 (x) (declare (ignore x)) (values))
+(multiple-value-bind (res err) (ignore-errors (frob-367 0 (make-e367)))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+
+(handler-case
+    (delete-file (compile-file "circ-tree-test.lisp"))
+  (storage-condition (e)
+    (error e)))
+
+;;; warnings due to step-insturmentation
+(defclass debug-test-class () ())
+(handler-case
+    (compile nil '(lambda ()
+                   (declare (optimize (debug 3)))
+                   (defmethod print-object ((x debug-test-class) s)
+                     (call-next-method))))
+  ((and (not style-warning) warning) (e)
+    (error e)))
+
+;;; program-error from bad lambda-list keyword
+(assert (eq :ok
+            (handler-case
+                (funcall (lambda (&whole x)
+                           (list &whole x)))
+              (program-error ()
+                :ok))))
+(assert (eq :ok
+            (handler-case
+                (let ((*evaluator-mode* :interpret))
+                  (funcall (eval '(lambda (&whole x)
+                                   (list &whole x)))))
+              (program-error ()
+                :ok))))
+
+;;; ignore &environment
+(handler-bind ((style-warning #'error))
+  (compile nil '(lambda ()
+                 (defmacro macro-ignore-env (&environment env)
+                   (declare (ignore env))
+                   :foo)))
+  (compile nil '(lambda ()
+                 (defmacro macro-no-env ()
+                   :foo))))
+
+(dolist (*evaluator-mode* '(:interpret :compile))
+  (disassemble (eval '(defun disassemble-source-form-bug (x y z)
+                       (declare (optimize debug))
+                       (list x y z)))))
+
+;;; long-standing bug in defaulting unknown values on the x86-64,
+;;; since changing the calling convention (test case by Christopher
+;;; Laux sbcl-help 30-06-2007)
+
+(defun default-values-bug-demo-sub ()
+  (format t "test")
+  nil)
+(compile 'default-values-bug-demo-sub)
+
+(defun default-values-bug-demo-main ()
+  (multiple-value-bind (a b c d e f g h)
+      (default-values-bug-demo-sub)
+    (if a (+ a b c d e f g h) t)))
+(compile 'default-values-bug-demo-main)
+
+(assert (default-values-bug-demo-main))
+
+;;; copy propagation bug reported by Paul Khuong
+
+(defun local-copy-prop-bug-with-move-arg (x)
+  (labels ((inner ()
+             (values 1 0)))
+    (if x
+        (inner)
+        (multiple-value-bind (a b)
+            (inner)
+          (values b a)))))
+
+(assert (equal '(0 1) (multiple-value-list (local-copy-prop-bug-with-move-arg nil))))
+(assert (equal '(1 0) (multiple-value-list (local-copy-prop-bug-with-move-arg t))))
+
+;;;; with-pinned-objects & unwind-protect, using all non-tail conventions
+
+(defun wpo-quux () (list 1 2 3))
+(defvar *wpo-quux* #'wpo-quux)
+
+(defun wpo-call ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (funcall *wpo-quux*)))))
+(assert (equal '(1 2 3) (wpo-call)))
+
+(defun wpo-multiple-call ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (funcall *wpo-quux*))))
+(assert (equal '(1 2 3) (wpo-multiple-call)))
+
+(defun wpo-call-named ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (wpo-quux)))))
+(assert (equal '(1 2 3) (wpo-call-named)))
+
+(defun wpo-multiple-call-named ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (wpo-quux))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-call-variable (&rest args)
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (apply *wpo-quux* args)))))
+(assert (equal '(1 2 3) (wpo-call-variable)))
+
+(defun wpo-multiple-call-variable (&rest args)
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (apply #'wpo-quux args))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-multiple-call-local ()
+  (flet ((quux ()
+           (wpo-quux)))
+    (unwind-protect
+         (sb-sys:with-pinned-objects (*wpo-quux*)
+           (quux)))))
+(assert (equal '(1 2 3) (wpo-multiple-call-local)))
+
+;;; bug 417: toplevel NIL confusing source path logic
+(handler-case
+    (delete-file (compile-file "bug-417.lisp"))
+  (sb-ext:code-deletion-note (e)
+    (error e)))
+
+;;; unknown values return convention getting disproportionate
+;;; amounts of values.
+(declaim (notinline one-value two-values))
+(defun one-value (x)
+  (not x))
+(defun two-values (x y)
+  (values y x))
+(defun wants-many-values (x y)
+  (multiple-value-bind (a b c d e f)
+      (one-value y)
+    (assert (and (eql (not y) a)
+                 (not (or b c d e f)))))
+  (multiple-value-bind (a b c d e f)
+      (two-values y x)
+    (assert (and (eql a x) (eql b y)
+                 (not (or c d e f)))))
+  (multiple-value-bind (a b c d e f g h i)
+      (one-value y)
+    (assert (and (eql (not y) a)
+                 (not (or b c d e f g h i)))))
+  (multiple-value-bind (a b c d e f g h i)
+      (two-values y x)
+    (assert (and (eql a x) (eql b y)
+                 (not (or c d e f g h i)))))
+  (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+      (one-value y)
+    (assert (and (eql (not y) a)
+                 (not (or b c d e f g h i j k l m n o p q r s)))))
+  (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+      (two-values y x)
+    (assert (and (eql a x) (eql b y)
+                 (not (or c d e f g h i j k l m n o p q r s))))))
+(wants-many-values 1 42)
+
+;;; constant coalescing
+
+(defun count-code-constants (x f)
+  (let ((code (sb-kernel:fun-code-header f))
+        (n 0))
+    (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+          do (when (equal x (sb-kernel:code-header-ref code i))
+               (incf n)))
+    n))
+
+(defvar *lambda*)
+
+(defun compile2 (lambda)
+  (let* ((lisp "compiler-impure-tmp.lisp")
+         (fasl (compile-file-pathname lisp)))
+    (unwind-protect
+         (progn
+           (with-open-file (f lisp :direction :output)
+             (prin1 `(setf *lambda* ,lambda) f))
+           (multiple-value-bind (fasl warn fail) (compile-file lisp)
+             (declare (ignore warn))
+             (when fail
+               (error "File-compiling ~S failed." lambda))
+             (let ((*lambda* nil))
+               (load fasl)
+               (values *lambda* (compile nil lambda)))))
+      (ignore-errors (delete-file lisp))
+      (ignore-errors (delete-file fasl)))))
+
+;; named and unnamed
+(defconstant +born-to-coalesce+ '.born-to-coalesce.)
+(multiple-value-bind (file-fun core-fun)
+    (compile2 '(lambda ()
+                (let ((x (cons +born-to-coalesce+ nil))
+                      (y (cons '.born-to-coalesce. nil)))
+                  (list x y))))
+  (assert (= 1 (count-code-constants '.born-to-coalesce. file-fun)))
+  (assert (= 1 (count-code-constants '.born-to-coalesce. core-fun))))
+
+;; some things must retain identity under COMPILE, but we want to coalesce them under COMPILE-FILE
+(defun assert-coalescing (constant)
+  (let ((value (copy-seq (symbol-value constant))))
+    (multiple-value-bind (file-fun core-fun)
+        (compile2 `(lambda ()
+                     (let ((x (cons ,constant nil))
+                           (y (cons ',value nil)))
+                       (list x y))))
+      (assert (= 1 (count-code-constants value file-fun)))
+      (assert (= 2 (count-code-constants value core-fun)))
+      (let* ((l (funcall file-fun))
+             (a (car (first l)))
+             (b (car (second l))))
+        (assert (and (equal value a)
+                     (equal a b)
+                     (eq a b))))
+      (let* ((l (funcall core-fun))
+             (a (car (first l)))
+             (b (car (second l))))
+        (assert (and (equal value a)
+                     (equal a b)
+                     (not (eq a b))))))))
+
+(defconstant +born-to-coalesce2+ "maybe coalesce me!")
+(assert-coalescing '+born-to-coalesce2+)
+
+(defconstant +born-to-coalesce3+ #*01101001011101110100011)
+(assert-coalescing '+born-to-coalesce3+)
+
+(defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010))
+(assert-coalescing '+born-to-coalesce4+)
+
+(defclass some-constant-thing () ())
+
+;;; correct handling of nested things loaded via SYMBOL-VALUE
+(defvar *sneaky-nested-thing* (list (make-instance 'some-constant-thing)))
+(defconstant +sneaky-nested-thing+ *sneaky-nested-thing*)
+(multiple-value-bind (file-fun core-fun) (compile2 '(lambda () +sneaky-nested-thing+))
+  (assert (eq *sneaky-nested-thing* (funcall file-fun)))
+  (assert (eq *sneaky-nested-thing* (funcall core-fun))))
+
+;;; catch constant modifications thru undefined variables
+(defun sneak-set-dont-set-me (x)
+  (ignore-errors (setq dont-set-me x)))
+(defconstant dont-set-me 42)
+(assert (not (sneak-set-dont-set-me 13)))
+(assert (= 42 dont-set-me))
+(defun sneak-set-dont-set-me2 (x)
+  (ignore-errors (setq dont-set-me2 x)))
+(defconstant dont-set-me2 (make-instance 'some-constant-thing))
+(assert (not (sneak-set-dont-set-me2 13)))
+(assert (typep dont-set-me2 'some-constant-thing))
+
 ;;; success