tests/compiler-2.pure.lisp

   1 ;;;; various compiler tests without side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;;; This file of tests was added because the tests in 'compiler.pure.lisp'
  15 ;;;; are a total hodgepodge- there is often no hugely compelling reason for
  16 ;;;; their being tests of the compiler per se, such as whether
  17 ;;;; INPUT-ERROR-IN-COMPILED-FILE is a subclass of SERIOUS-CONDITION;
  18 ;;;; in addition to which it is near impossible to wade through the
  19 ;;;; ton of nameless, slow, and noisy tests.
  20
  21 ;;;; This file strives to do better on all fronts:
  22 ;;;; the tests should be fast, named, and not noisy.
  23
  24 (cl:in-package :cl-user)
  25
  26 (load "compiler-test-util.lisp")
  27
  28 (with-test (:name :ldb-recognize-local-macros)
  29   ;; Should not call %LDB
  30   (assert (not (ctu:find-named-callees
  31                 (compile nil
  32                          '(lambda (x)
  33                            (declare (optimize speed))
  34                            (macrolet ((b () '(byte 2 2)))
  35                              (ldb (b) (the fixnum x)))))))))
  36
  37 ;; lp#1458190
  38 (with-test (:name :dbp-eval-order)
  39   (sb-int:collect ((calls))
  40     (flet ((f (new old)
  41              (dpb (progn (calls 'eval-new) new)
  42                   (progn (calls 'eval-byte) (byte 10 10))
  43                   (progn (calls 'eval-old) old))))
  44       (f 20 0)
  45       (assert (equal (calls)
  46                      '(eval-new eval-byte eval-old))))))
  47
  48 ;; Best practice treats TRULY-THE as a special operator, not a macro,
  49 ;; in a context such as (DPB X (TRULY-THE SB-KERNEL:BYTE-SPECIFIER ...) Y).
  50 ;; DPB used to expand its second argument using MACROEXPAND and lose
  51 ;; the nuance of TRULY-THE. Strictly speaking, byte-specifier is not a
  52 ;; type specifier that users are supposed to know about, so portable code
  53 ;; should not care, but this might affect internal code.
  54 (with-test (:name :dpb-inner-macro)
  55   (flet ((source-xform (sexpr)
  56            (funcall (sb-int:info :function :source-transform (car sexpr))
  57                     sexpr (sb-kernel:make-null-lexenv))))
  58     (assert (equal-mod-gensyms
  59              (source-xform
  60               '(dpb (new) (truly-the sb-kernel:byte-specifier bspec) (old)))
  61              '(let ((new (new))
  62                     (byte (truly-the sb-kernel:byte-specifier bspec)))
  63                (sb-kernel:%dpb new (byte-size byte) (byte-position byte)
  64                                (old)))))))
  65
  66 (with-test (:name :inline-satisfies-predicate)
  67   ;; If we remove the indirections in these functions,
  68   ;; this test should visibly break so that we can write a new test
  69   ;; that asserts that inlining F works in (THE (SATISFIES F) obj).
  70   (assert (equal (sb-ext:typexpand 'sb-impl::function-name)
  71                  '(satisfies sb-int:legal-fun-name-p)))
  72   (let ((f (compile nil '(lambda (x) (the sb-impl::function-name x)))))
  73     (assert (equal (list (symbol-function 'sb-int:valid-function-name-p))
  74                    (ctu:find-named-callees f))))
  75   (let ((f (compile nil '(lambda (x)
  76                            (declare (notinline sb-int:legal-fun-name-p))
  77                            (the sb-impl::function-name x)))))
  78     (assert (equal (list (symbol-function 'sb-int:legal-fun-name-p))
  79                    (ctu:find-named-callees f)))))
  80
  81 (with-test (:name :make-array-untestable-type-no-warning)
  82   (assert-no-signal
  83    (compile nil `(lambda () (make-array '(2 2)
  84                                         :element-type `(satisfies foofa))))))
  85
  86 (with-test (:name :make-array-nil-no-warning)
  87   (assert-no-signal
  88    (compile nil '(lambda () (make-array '(2 2) :element-type nil)))))
  89
  90 (with-test (:name :nth-value-huge-n-works)
  91   (flet ((return-a-ton-of-values ()
  92            (values-list (loop for i below 5000 collect i))))
  93     (assert (= (nth-value 1 (return-a-ton-of-values)) 1))
  94     (assert (= (nth-value 4000 (return-a-ton-of-values)) 4000))))
  95
  96 (defstruct (a-test-structure-foo
  97             (:constructor make-a-foo-1)
  98             (:constructor make-a-foo-2 (b &optional a)))
  99   (a 0 :type symbol)
 100   (b nil :type integer))
 101
 102 (with-test (:name :improperly-initialized-slot-warns)
 103   (with-open-stream (*error-output* (make-broadcast-stream))
 104     (multiple-value-bind (f warn err)
 105         (compile nil '(lambda () (make-a-foo-1 :a 'what)))
 106       ;; should warn because B's default is NIL, not an integer.
 107       (assert (and f warn err)))
 108     (multiple-value-bind (f warn err)
 109         (compile nil '(lambda () (make-a-foo-2 3)))
 110       ;; should warn because A's default is 0
 111       (assert (and f warn err)))))
 112
 113 (with-test (:name :inline-structure-ctor-no-declaim)
 114   (let ((f (compile nil
 115                     '(lambda ()
 116                        (make-a-foo-1 :a 'wat :b 3)))))
 117     (assert (ctu:find-named-callees f)))
 118   (let ((f (compile nil
 119                     '(lambda ()
 120                        (declare (inline make-a-foo-1))
 121                        (make-a-foo-1 :a 'wat :b 3)))))
 122     (assert (not (ctu:find-named-callees f)))))
 123
 124 (with-test (:name :internal-name-p :skipped-on :sb-xref-for-internals)
 125   (assert (sb-c::internal-name-p 'sb-int:neq)))
 126
 127 (with-test (:name :coerce-callable-to-fun-note)
 128   (macrolet ((try (form what)
 129                `(assert
 130                  (search ,(format nil "~A is not known to be" what)
 131                          (with-output-to-string (*error-output*)
 132                            (compile nil '(lambda (x)
 133                                            (declare (optimize speed))
 134                                            (funcall ,form))))))))
 135
 136     (try (eval `(work-with ,x)) "callable expression")
 137     (try x "X")
 138     ;; For this I'd accept either Z or X in the message.
 139     (try (progn (let ((z x)) (identity z))) "X")))
 140
 141 (with-test (:name :princ-to-string-unflushable)
 142   ;; Ordinary we'll flush it
 143   (let ((f (compile nil '(lambda (x) (princ-to-string x) x))))
 144     (assert (not (ctu:find-named-callees f :name 'princ-to-string))))
 145   ;; But in high safety it should be called for effect
 146   (let ((f (compile nil '(lambda (x)
 147                            (declare (optimize safety)) (princ-to-string x) x))))
 148     (assert (ctu:find-named-callees f :name 'princ-to-string))))
 149
 150 (with-test (:name :space-bounds-no-consing
 151                   :skipped-on :interpreter)
 152   ;; Asking for the size of a heap space should not cost anything!
 153   (ctu:assert-no-consing (sb-vm::%space-bounds :static))
 154   (ctu:assert-no-consing (sb-vm::space-bytes :static)))
 155
 156 (with-test (:name :map-allocated-objects-no-consing
 157                   :skipped-on :interpreter
 158                   :fails-on :ppc)
 159   (let ((n 0))
 160     (sb-int:dx-flet ((f (obj type size)
 161                        (declare (ignore obj type size))
 162                        (incf n)))
 163       (ctu:assert-no-consing
 164        (sb-vm::map-allocated-objects #'f :dynamic)
 165        5))))
 166
 167 (with-test (:name :pack-varints-as-bignum)
 168   (dotimes (i 500) ; do some random testing this many times
 169     (let* ((random-numbers (loop repeat (+ (random 20) 3)
 170                                  collect (1+ (random 4000))))
 171            (test-list (sort (delete-duplicates random-numbers) #'<))
 172            (packed-int (sb-c::pack-code-fixup-locs test-list))
 173            (result (make-array 1 :element-type 'sb-ext:word)))
 174       ;; The packer intrinsically self-checks the packing
 175       ;; so we don't need to assert anything about that.
 176       (sb-sys:with-pinned-objects (packed-int result)
 177         ;; Now exercise the C unpacker.
 178         ;; This hack of allocating 4 longs is terrible, but whatever.
 179         (let ((unpacker (make-alien long 4))
 180               (prev-loc 0))
 181           (alien-funcall (extern-alien "varint_unpacker_init"
 182                                        (function void (* long) unsigned))
 183                          unpacker
 184                          (sb-kernel:get-lisp-obj-address packed-int))
 185           (sb-int:collect ((unpacked))
 186             (loop
 187              (let ((status
 188                     (alien-funcall
 189                      (extern-alien "varint_unpack"
 190                                    (function int (* long) system-area-pointer))
 191                      unpacker (sb-sys:vector-sap result))))
 192                (let ((val (aref result 0)))
 193                  ;; status of 0 is EOF, val = 0 means a decoded value was 0,
 194                  ;; which can't happen, so it's effectively EOF.
 195                  (when (or (eql status 0) (eql val 0)) (return))
 196                  (let ((loc (+ prev-loc val)))
 197                    (unpacked loc)
 198                    (setq prev-loc loc)))))
 199             (assert (equal (unpacked) test-list))))))))
 200
 201 (with-test (:name :symbol-value-quoted-constant)
 202   (let ((f (compile nil '(lambda () (symbol-value 'char-code-limit)))))
 203     (assert (not (ctu:find-code-constants f :type 'symbol))))
 204   (let ((f (compile nil '(lambda () (symbol-global-value 'char-code-limit)))))
 205     (assert (not (ctu:find-code-constants f :type 'symbol)))))
 206
 207 (with-test (:name :set-symbol-value-of-defglobal)
 208   (let ((s 'sb-c::*recognized-declarations*))
 209     (assert (eq (sb-int:info :variable :kind s) :global)) ; verify precondition
 210     (let ((f (compile nil `(lambda () (setf (symbol-value ',s) nil)))))
 211       ;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE>
 212       (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))))
 213
 214 (with-test (:name :layout-constants
 215                   :skipped-on '(not (and :x86-64 :immobile-space)))
 216   (let ((addr-of-pathname-layout
 217          (write-to-string
 218           (sb-kernel:get-lisp-obj-address (sb-kernel:find-layout 'pathname))))
 219         (count 0))
 220     ;; The constant should appear in two CMP instructions
 221     (dolist (line (split-string
 222                    (with-output-to-string (s)
 223                      (let ((sb-disassem:*disassem-location-column-width* 0))
 224                        (disassemble 'pathnamep :stream s)))
 225                    #\newline))
 226       (when (and (search "CMP" line) (search addr-of-pathname-layout line))
 227         (incf count)))
 228     (assert (= count 2))))