tests/compiler-2.impure.lisp

   1 (load "compiler-test-util.lisp")
   2
   3 (defun compiles-with-warning (lambda)
   4   (assert (nth-value 2 (checked-compile lambda :allow-warnings t))))
   5
   6 (defstruct (a-test-structure-foo
   7             (:constructor make-a-foo-1)
   8             (:constructor make-a-foo-2 (b &optional a)))
   9   (a 0 :type symbol)
  10   (b nil :type integer))
  11
  12 (with-test (:name :improperly-initialized-slot-warns)
  13   ;; should warn because B's default is NIL, not an integer.
  14   (compiles-with-warning '(lambda () (make-a-foo-1 :a 'what)))
  15   ;; should warn because A's default is 0
  16   (compiles-with-warning '(lambda () (make-a-foo-2 3))))
  17
  18 (with-test (:name (inline structure :ctor :no declaim))
  19   (assert (ctu:ir1-named-calls '(lambda () (make-a-foo-1 :a 'wat :b 3))))
  20   (assert (not (ctu:ir1-named-calls
  21                             '(lambda ()
  22                                (declare (inline make-a-foo-1))
  23                                (make-a-foo-1 :a 'wat :b 3))))))
  24
  25 (defstruct %instance-ref-eq (n 0))
  26
  27 (with-test (:name :%instance-ref-eq-immediately-used)
  28   (checked-compile-and-assert
  29    ()
  30    `(lambda (s)
  31       (let ((n (%instance-ref-eq-n s)))
  32         (incf (%instance-ref-eq-n s))
  33         (eql n 0)))
  34    (((make-%instance-ref-eq)) t)))
  35
  36 (with-test (:name :%instance-ref-eq-load-immediate)
  37   (checked-compile-and-assert
  38    ()
  39    `(lambda (s)
  40       (eql (%instance-ref-eq-n s)
  41            most-positive-fixnum))
  42    (((make-%instance-ref-eq :n most-positive-fixnum)) t)
  43    (((make-%instance-ref-eq :n -1)) nil))
  44   (checked-compile-and-assert
  45    ()
  46    `(lambda (s)
  47       (eql (%instance-ref-eq-n s)
  48            (1- (expt 2 31))))
  49    (((make-%instance-ref-eq :n (1- (expt 2 31)))) t)
  50    (((make-%instance-ref-eq :n -1)) nil)))
  51
  52 (declaim (inline make-mystruct))
  53 (macrolet ((def-mystruct () `(defstruct mystruct a b c)))
  54   (def-mystruct)) ; MAKE-MYSTRUCT captures a lexenv (rather pointlessly)
  55
  56 ;;; Assert that throwaway code in compiled macrolets does not go in immobile space
  57 #+immobile-code
  58 (with-test (:name :macrolet-not-immobile-space :serial t
  59             :skipped-on :interpreter)
  60   (labels ((count-code-objects ()
  61              (length (sb-vm::list-allocated-objects
  62                       :immobile
  63                       :test (lambda (x)
  64                               (and (sb-kernel:code-component-p x)
  65                                    (/= (sb-kernel:generation-of x)
  66                                        sb-vm:+pseudo-static-generation+))))))
  67            (test (lambda)
  68              (sb-sys:without-gcing
  69               (let* ((start-count (count-code-objects))
  70                      (result
  71                        (let ((sb-c::*compile-to-memory-space* :immobile))
  72                          (compile nil lambda)))
  73                      (end-count (count-code-objects)))
  74                 (assert (= end-count (1+ start-count)))
  75                 result))))
  76     (sb-ext:gc :full t)
  77     ;; Test 1: simple macrolet
  78     (test '(lambda (x) (macrolet ((baz (arg) `(- ,arg))) (list (baz x)))))
  79     ;; Test 2: inline a function that captured a macrolet
  80     (test '(lambda (x) (make-mystruct :a x)))))
  81
  82 (with-test (:name (reduce :type-deriver :wild-array-upgraded-type))
  83   (checked-compile-and-assert
  84    ()
  85    `(lambda (x) (declare (type vector x)) (reduce #'+ x))
  86    ((#(1 2 3)) 6)
  87    (((make-array 3 :element-type '(unsigned-byte 8) :initial-contents '(4 5 6))) 15)))
  88
  89 ;;; We do not want functions closing over top level bindings to retain
  90 ;;; load-time code in the component when not necessary.
  91 (with-test (:name :top-level-closure-separate-component
  92             :fails-on :sbcl)
  93   (ctu:file-compile
  94    `((let ((x (random 10)))
  95        (defun top-level-closure-1 ()
  96          x)
  97        (setq x 4)))
  98    :load t)
  99   ;; Check there's no top level code hanging out.
 100   (assert (= 1 (sb-kernel::code-n-entries (sb-kernel::fun-code-header (sb-kernel::%closure-fun #'top-level-closure-1)))))
 101   (assert (= (top-level-closure-1) 4)))
 102
 103 (with-test (:name :top-level-closure-separate-component.2
 104             :fails-on :sbcl)
 105   (ctu:file-compile
 106    `((let ((x (random 10)))
 107        (flet ((bar () x))
 108          (defun top-level-closure-2 ()
 109            #'bar))
 110        (setq x 4)))
 111    :load t)
 112   ;; Check there's no top level code hanging out. (We expect to only
 113   ;; have (FLET BAR) and TOP-LEVEL-CLOSURE-2 present.)
 114   (assert (= 2 (sb-kernel::code-n-entries (sb-kernel::fun-code-header (sb-kernel::%closure-fun #'top-level-closure-2)))))
 115   (assert (= (funcall (top-level-closure-2)) 4)))
 116
 117 (with-test (:name :dead-code-dfo-puking)
 118   (ctu:file-compile
 119    `((defun dead-code-puke-1 ()
 120        (let ((bar (read)))
 121          (labels ((emplace (thing)
 122                     (print thing))
 123                   (visit (thing)
 124                     (case thing
 125                       (0 (visit-code thing))
 126                       (1 (visit-code thing))
 127                       (2 (visit thing))
 128                       (3 (visit thing))))
 129                   (visit-code (thing)
 130                     (when (read)
 131                       (return-from visit-code))
 132                     (print bar)
 133                     (case thing
 134                       (1 (visit thing))
 135                       (2 (visit thing))
 136                       (3 (map nil #'visit (list thing thing))))))
 137            (emplace nil)))))
 138    :load t)
 139   ;; EMPLACE will have been LET-converted. VISIT and VISIT-CODE should
 140   ;; have been separated out or simply deleted.
 141   (assert (= 1 (sb-kernel::code-n-entries (sb-kernel::fun-code-header #'dead-code-puke-1)))))
 142
 143 (with-test (:name :top-level-closure-is-dx)
 144   (ctu:file-compile
 145    `((eval-when (:compile-toplevel :load-toplevel :execute)
 146        (defstruct (precondition-tag (:constructor nil))
 147          (%bits0 0)
 148          (%bits1 0)))
 149
 150      (defvar *pt-hash-set* 0)
 151
 152      (defmacro bit-op (operation destination source)
 153        `(setf (precondition-tag-%bits0 ,destination)
 154               (,operation (precondition-tag-%bits0 ,destination) (precondition-tag-%bits0 ,source))
 155               (precondition-tag-%bits1 ,destination)
 156               (,operation (precondition-tag-%bits1 ,destination) (precondition-tag-%bits1 ,source))))
 157
 158      (declaim (inline tags-logandc2))
 159      (defun tags-logandc2 (a b)
 160        (let ((result (copy-precondition-tag a)))
 161          (bit-op logandc2 result b)
 162          result))
 163
 164      (declaim (ftype (function)))
 165      (declaim (inline mock-get-canonical-obj))
 166      (defun mock-get-canonical-obj (pt)
 167        (flet ((compute-it () (copy-precondition-tag pt)))
 168          (declare (dynamic-extent #'compute-it))
 169          (our-hash-table-lookup *pt-hash-set* pt #'compute-it)))
 170
 171      (declaim (sb-ext:freeze-type precondition-tag))
 172      (declaim (inline tags-logior))
 173      (defun tags-logior (a b)
 174        (if (read)
 175            (let ((result (copy-structure a)))
 176              (bit-op logior result b)
 177              (mock-get-canonical-obj result))
 178            (let ((result (copy-precondition-tag a)))
 179              (bit-op logior result b)
 180              result)))
 181
 182      (defvar +z+
 183        (tags-logandc2 (read)
 184                       (tags-logior (tags-logior (read)
 185                                                 (read))
 186                                    (read)))))))
 187
 188 (with-test (:name :top-level-closure-fun-arg-substitution)
 189   (ctu:file-compile
 190    `((let ((x (let ((y (random 8)))
 191                  (lambda ()
 192                    y))))
 193         (defun top-level-closure-fun-arg-substitution ()
 194           (funcall x))))
 195    :load t)
 196   (assert (<= 0 (top-level-closure-fun-arg-substitution) 8)))
 197
 198 (with-test (:name :top-level-closure-fun-arg-substitution.2)
 199   (ctu:file-compile
 200    `((let ((x (let ((y (random 8)))
 201                  (lambda ()
 202                    y))))
 203        (print x)
 204        (defun top-level-closure-fun-arg-substitution ()
 205          (funcall x)
 206          (funcall x))))
 207    :load t)
 208   (assert (<= 0 (top-level-closure-fun-arg-substitution) 8)))
 209
 210 (with-test (:name :top-level-closure-dead-component-reference)
 211   (ctu:file-compile
 212    `((declaim (inline top-level-closure-dead-component-reference))
 213      (defun top-level-closure-dead-component-reference (control &rest arguments)
 214        (with-standard-io-syntax
 215          (apply #'format nil (string control) arguments)))
 216      ((lambda ()
 217         (top-level-closure-dead-component-reference :keyword "~a" 2)
 218         (top-level-closure-dead-component-reference :keyword "~a" 2))))
 219    :load t))
 220
 221 (with-test (:name :top-level-closure-zombie-reference)
 222   (ctu:file-compile
 223    `((declaim (inline top-level-closure-zombie-reference))
 224
 225      (defun top-level-closure-zombie-reference ()
 226        (multiple-value-bind (g190 param) (#.(gensym))
 227          (unwind-protect (#.(gensym) g190)
 228            (#.(gensym) g190 param))))
 229
 230      (print (top-level-closure-zombie-reference)))))
 231
 232 (with-test (:name :top-level-closure-type-errors)
 233   (let (warnings)
 234     (handler-bind ((warning (lambda (c) (push c warnings))))
 235       (ctu:file-compile
 236        `((let ((x (random 1d0)))
 237            (defun test ()
 238              (car x))))))
 239     (assert (typep (car warnings) 'sb-int:type-warning))))
 240
 241 (with-test (:name :top-level-closure-substituted)
 242   (ctu:file-compile
 243    `((let (c (j 0))
 244        (defun test ()
 245          (let ((m c))
 246            (lambda () (values m (incf j)))))))))
 247
 248