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 (defun compiles-with-warning (lambda)
  29   (assert (nth-value 2 (checked-compile lambda :allow-warnings t))))
  30
  31 (with-test (:name (ldb :recognize-local-macros))
  32   ;; Should not call %LDB
  33   (assert (not (ctu:find-named-callees
  34                 (checked-compile
  35                  '(lambda (x)
  36                    (declare (optimize speed))
  37                    (macrolet ((b () '(byte 2 2)))
  38                      (ldb (b) (the fixnum x)))))))))
  39
  40 (with-test (:name (dpb :eval-order :lp-1458190))
  41   (sb-int:collect ((calls))
  42     (flet ((f (new old)
  43              (dpb (progn (calls 'eval-new) new)
  44                   (progn (calls 'eval-byte) (byte 10 10))
  45                   (progn (calls 'eval-old) old))))
  46       (f 20 0)
  47       (assert (equal (calls)
  48                      '(eval-new eval-byte eval-old))))))
  49
  50 ;; Best practice treats TRULY-THE as a special operator, not a macro,
  51 ;; in a context such as (DPB X (TRULY-THE SB-KERNEL:BYTE-SPECIFIER ...) Y).
  52 ;; DPB used to expand its second argument using MACROEXPAND and lose
  53 ;; the nuance of TRULY-THE. Strictly speaking, byte-specifier is not a
  54 ;; type specifier that users are supposed to know about, so portable code
  55 ;; should not care, but this might affect internal code.
  56 (with-test (:name (dpb :inner-macro))
  57   (flet ((source-xform (sexpr)
  58            (funcall (sb-int:info :function :source-transform (car sexpr))
  59                     sexpr (sb-kernel:make-null-lexenv))))
  60     (assert (equal-mod-gensyms
  61              (source-xform
  62               '(dpb (new) (truly-the sb-kernel:byte-specifier bspec) (old)))
  63              '(let ((new (new))
  64                     (byte (truly-the sb-kernel:byte-specifier bspec)))
  65                (sb-kernel:%dpb new (byte-size byte) (byte-position byte)
  66                                (old)))))))
  67
  68 (with-test (:name :inline-satisfies-predicate)
  69   ;; If we remove the indirections in these functions,
  70   ;; this test should visibly break so that we can write a new test
  71   ;; that asserts that inlining F works in (THE (SATISFIES F) obj).
  72   (assert (equal (sb-ext:typexpand 'sb-impl::function-name)
  73                  '(satisfies sb-int:legal-fun-name-p)))
  74   (let ((f (checked-compile '(lambda (x) (the sb-impl::function-name x)))))
  75     (assert (equal (list (symbol-function 'sb-int:valid-function-name-p))
  76                    (ctu:find-named-callees f))))
  77   (let ((f (checked-compile '(lambda (x)
  78                                (declare (notinline sb-int:legal-fun-name-p))
  79                                (the sb-impl::function-name x)))))
  80     (assert (equal (list (symbol-function 'sb-int:legal-fun-name-p))
  81                    (ctu:find-named-callees f)))))
  82
  83 (with-test (:name (make-array :untestable-type :no-warning))
  84   (checked-compile `(lambda () (make-array '(2 2)
  85                                            :element-type `(satisfies foofa)))))
  86
  87 (with-test (:name (make-array nil :no-warning))
  88   (checked-compile '(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   ;; should warn because B's default is NIL, not an integer.
 104   (compiles-with-warning '(lambda () (make-a-foo-1 :a 'what)))
 105   ;; should warn because A's default is 0
 106   (compiles-with-warning '(lambda () (make-a-foo-2 3))))
 107
 108 (with-test (:name (inline structure :ctor :no declaim))
 109   (let ((f (checked-compile '(lambda ()
 110                                (make-a-foo-1 :a 'wat :b 3)))))
 111     (assert (ctu:find-named-callees f)))
 112   (let ((f (checked-compile '(lambda ()
 113                                (declare (inline make-a-foo-1))
 114                                (make-a-foo-1 :a 'wat :b 3)))))
 115     (assert (not (ctu:find-named-callees f)))))
 116
 117 (with-test (:name :internal-name-p :skipped-on :sb-xref-for-internals)
 118   (assert (sb-c::internal-name-p 'sb-int:neq)))
 119
 120 (with-test (:name (:coerce-callable-to-fun :note))
 121   (flet ((try (form what)
 122            (multiple-value-bind (fun failure-p warnings style-warnings notes)
 123                (checked-compile `(lambda (x)
 124                                   (declare (optimize speed))
 125                                   (funcall ,form)))
 126              (declare (ignore fun failure-p warnings style-warnings))
 127              (assert (search (format nil "~A is not known to be" what)
 128                              (princ-to-string (first notes)))))))
 129
 130     (try '(eval `(work-with ,x)) "callable expression")
 131     (try 'x "X")
 132     ;; For this I'd accept either Z or X in the message.
 133     (try '(progn (let ((z x)) (identity z))) "X")))
 134
 135 (with-test (:name (princ-to-string :unflushable))
 136   ;; Ordinary we'll flush it
 137   (let ((f (checked-compile '(lambda (x) (princ-to-string x) x))))
 138     (assert (not (ctu:find-named-callees f :name 'princ-to-string))))
 139   ;; But in high safety it should be called for effect
 140   (let ((f (checked-compile '(lambda (x)
 141                                (declare (optimize safety)) (princ-to-string x) x))))
 142     (assert (ctu:find-named-callees f :name 'princ-to-string))))
 143
 144 (with-test (:name :space-bounds-no-consing
 145                   :skipped-on :interpreter)
 146   ;; Asking for the size of a heap space should not cost anything!
 147   (ctu:assert-no-consing (sb-vm::%space-bounds :static))
 148   (ctu:assert-no-consing (sb-vm::space-bytes :static)))
 149
 150 (with-test (:name (sb-vm::map-allocated-objects :no-consing)
 151                   :fails-on :cheneygc
 152                   :skipped-on :interpreter)
 153   (let ((n 0))
 154     (sb-int:dx-flet ((f (obj type size)
 155                        (declare (ignore obj type size))
 156                        (incf n)))
 157       (ctu:assert-no-consing
 158        (sb-vm::map-allocated-objects #'f :dynamic)
 159        5))))
 160
 161 (with-test (:name :pack-varints-as-bignum)
 162   (dotimes (i 500) ; do some random testing this many times
 163     (let* ((random-numbers (loop repeat (+ (random 20) 3)
 164                                  collect (1+ (random 4000))))
 165            (test-list (sort (delete-duplicates random-numbers) #'<))
 166            (packed-int (sb-c::pack-code-fixup-locs test-list))
 167            (result (make-array 1 :element-type 'sb-ext:word)))
 168       ;; The packer intrinsically self-checks the packing
 169       ;; so we don't need to assert anything about that.
 170       (sb-sys:with-pinned-objects (packed-int result)
 171         ;; Now exercise the C unpacker.
 172         ;; This hack of allocating 4 longs is terrible, but whatever.
 173         (let ((unpacker (make-alien long 4))
 174               (prev-loc 0))
 175           (alien-funcall (extern-alien "varint_unpacker_init"
 176                                        (function void (* long) unsigned))
 177                          unpacker
 178                          (sb-kernel:get-lisp-obj-address packed-int))
 179           (sb-int:collect ((unpacked))
 180             (loop
 181              (let ((status
 182                     (alien-funcall
 183                      (extern-alien "varint_unpack"
 184                                    (function int (* long) system-area-pointer))
 185                      unpacker (sb-sys:vector-sap result))))
 186                (let ((val (aref result 0)))
 187                  ;; status of 0 is EOF, val = 0 means a decoded value was 0,
 188                  ;; which can't happen, so it's effectively EOF.
 189                  (when (or (eql status 0) (eql val 0)) (return))
 190                  (let ((loc (+ prev-loc val)))
 191                    (unpacked loc)
 192                    (setq prev-loc loc)))))
 193             (assert (equal (unpacked) test-list))))))))
 194
 195 (with-test (:name (symbol-value symbol-global-value :quoted-constant))
 196   (let ((f (checked-compile '(lambda () (symbol-value 'char-code-limit)))))
 197     (assert (not (ctu:find-code-constants f :type 'symbol))))
 198   (let ((f (checked-compile '(lambda () (symbol-global-value 'char-code-limit)))))
 199     (assert (not (ctu:find-code-constants f :type 'symbol)))))
 200
 201 (with-test (:name (:set symbol-value :of defglobal))
 202   (let ((s 'sb-c::*recognized-declarations*))
 203     (assert (eq (sb-int:info :variable :kind s) :global)) ; verify precondition
 204     (let ((f (checked-compile `(lambda () (setf (symbol-value ',s) nil)))))
 205       ;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE>
 206       (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))))
 207
 208 (with-test (:name :layout-constants
 209                   :skipped-on (not (and :x86-64 :immobile-space)))
 210   (let ((addr-of-pathname-layout
 211          (write-to-string
 212           (sb-kernel:get-lisp-obj-address (sb-kernel:find-layout 'pathname))
 213           :base 16 :radix t))
 214         (count 0))
 215     ;; The constant should appear in two CMP instructions
 216     (dolist (line (split-string
 217                    (with-output-to-string (s)
 218                      (let ((sb-disassem:*disassem-location-column-width* 0))
 219                        (disassemble 'pathnamep :stream s)))
 220                    #\newline))
 221       (when (and (search "CMP" line) (search addr-of-pathname-layout line))
 222         (incf count)))
 223     (assert (= count 2))))
 224
 225 (with-test (:name :set-symbol-value-imm :skipped-on (not :x86-64))
 226   (let (success)
 227     (dolist (line (split-string
 228                    (with-output-to-string (s)
 229                      (let ((sb-disassem:*disassem-location-column-width* 0))
 230                        (disassemble '(lambda () (setq *print-base* 8)) :stream s)))
 231                    #\newline))
 232       (when (and #+sb-thread (search "MOV QWORD PTR [R" line)
 233                  #-sb-thread (search "MOV QWORD PTR [" line)
 234                  (search (format nil ", ~D" (ash 8 sb-vm:n-fixnum-tag-bits)) line))
 235         (setq success t)))
 236     (assert success)))
 237
 238 (with-test (:name :linkage-table-bogosity :skipped-on (not :sb-dynamic-core))
 239   (let ((strings (map 'list (lambda (x) (if (consp x) (car x) x))
 240                       #+sb-dynamic-core sb-vm::+required-foreign-symbols+
 241                       #-sb-dynamic-core '())))
 242     (assert (= (length (remove-duplicates strings :test 'string=))
 243                (length strings)))))
 244
 245 (with-test (:name (:no style-warning :for inline :cl-fun))
 246   (checked-compile '(lambda (x)
 247                       (declare (optimize (speed 3)) (inline length)
 248                       (muffle-conditions compiler-note))
 249                       (length x))))
 250
 251 (with-test (:name :deleted-return-use)
 252   (checked-compile-and-assert ()
 253       `(lambda ()
 254          (block nil
 255            (return 345)
 256            (let ((a (catch 'x)))
 257              (flet ((%f (a &optional b)
 258                       a))
 259                (%f 0 (%f 123))))))
 260     (() 345)))
 261
 262 (with-test (:name :shift-right-transform-nil-type)
 263   (checked-compile-and-assert (:optimize nil)
 264       `(lambda (b c)
 265          (declare (type (integer -10 -6) c)
 266                   (optimize (debug 2)))
 267          (catch 'c
 268            (flet ((f1 (a &optional (b (shiftf b 0)) c d)
 269                     (declare (ignore a b c d))
 270                     (throw 'c 780)))
 271              (flet ((f2 (a b)
 272                       (f1 a b 0)))
 273                (ash
 274                 (f1 (if t
 275                         c
 276                         (f1 (f2 1 0) 0))
 277                     b)
 278                 (+ c))))))
 279       ((-3 -7) 780)))
 280
 281 (with-test (:name :move-lvar-result-through-unused-cast)
 282   (checked-compile-and-assert (:optimize nil)
 283       `(lambda ()
 284          (declare (optimize (debug 0)))
 285          (labels ((f (a b)
 286                     a b)
 287                   (x ()
 288                     (apply #'f (list 2 3))))
 289            (declare (notinline f))
 290            (the integer (x)))
 291          132)
 292     (() 132)))
 293
 294 (with-test (:name (:type-conflict funcall :external-lambda))
 295   (compiles-with-warning `(lambda ()
 296                             (let ((x (lambda (x) (declare (fixnum x)) x)))
 297                               (funcall x 'a)))))
 298
 299 (with-test (:name (:type-conflict :callable :external-lambda))
 300   (compiles-with-warning `(lambda ()
 301                             (let ((x (lambda (x) (declare (fixnum x)) x)))
 302                               (find-if x "abca")))))
 303
 304 (with-test (:name (:type-conflict map :result-type))
 305   (compiles-with-warning `(lambda (str)
 306                             (map 'string (lambda (x) (declare (ignore x)) nil)
 307                                  str))))
 308
 309 (with-test (:name (:type-conflict :by-name))
 310   (compiles-with-warning `(lambda (str)
 311                             (map 'string 'evenp str))))
 312
 313 (with-test (:name (:type-conflict :callable :reporting))
 314   (multiple-value-bind (fun failure-p warnings)
 315       (checked-compile '(lambda (x) (map-into (make-string 10) #'evenp x))
 316                        :allow-warnings 'warning)
 317     (declare (ignore fun))
 318     (assert failure-p)
 319     (assert (= (length warnings) 1))
 320     (search "Derived type of EVENP is"
 321             (princ-to-string (first warnings)))))
 322
 323 (with-test (:name (:type-conflict string :union-type))
 324   (compiles-with-warning `(lambda (x)
 325                             (find-if #'evenp (the string x)))))
 326
 327 (with-test (:name (:type-conflict map-into :let))
 328   (compiles-with-warning `(lambda (z)
 329                             (let ((x "abc"))
 330                               (map-into z #'evenp x)))))
 331
 332 (with-test (:name (:type-conflict map-into :result))
 333   (compiles-with-warning `(lambda (z)
 334                             (map-into (make-string 10) #'evenp z))))
 335
 336 (with-test (:name (:type-conflict complement))
 337   (assert (nth-value 3
 338                      (checked-compile
 339                       `(lambda (z)
 340                          (find z "l" :test (complement #'=)))
 341                       :allow-style-warnings t))))
 342
 343 (with-test (:name :type-across-hairy-lambda-transforms)
 344   (assert (subtypep (sb-kernel:%simple-fun-type
 345                      (checked-compile `(lambda (x) (find 1 (the vector x)))))
 346                     '(function * (values (or (integer 1 1) null) &optional)))))
 347
 348 (with-test (:name :lea-type-derivation)
 349   (checked-compile-and-assert ()
 350       `(lambda (b)
 351          (declare ((integer -3755795408964870057 -3391381516052960895)
 352                    b))
 353          (ldb (byte 22 10) (* b 9)))
 354     ((-3391381516052980893) 2826685)))
 355
 356 (with-test (:name (:unused &optional :and &key))
 357   (checked-compile-and-assert (:allow-style-warnings t)
 358       `(lambda (&optional x &key)
 359          (declare (ignore x))
 360          10)
 361     (() 10)))
 362
 363 (with-test (:name (:unknown values :coercion))
 364   (checked-compile-and-assert ()
 365       `(lambda (a)
 366          (declare (notinline values typep))
 367          (the integer (values a 2305843009213693946 a -207)))
 368     ((123) (values 123 2305843009213693946 123 -207))))
 369
 370 (with-test (:name :deleted-block-during-generate-type-checks)
 371   (checked-compile-and-assert (:allow-warnings t)
 372       `(lambda (a b)
 373          (declare (notinline min ash conjugate oddp >=))
 374          (if (and (or t (>= a)) (oddp 0))
 375              (prog2 0
 376                  0
 377                (labels ((f (a b c &key)
 378                           (declare (ignore a b c))
 379                           6965670824543402))
 380                  (f a 0 b)))
 381              (conjugate
 382               (dotimes (i 0 0)
 383                 (catch 'c
 384                   (ash
 385                    (the integer
 386                         (ignore-errors
 387                           (ignore-errors (throw 'c 1))))
 388                    (min a)))))))
 389     ((1 2) 0)))
 390
 391 (with-test (:name :block-delete-twice)
 392   (checked-compile-and-assert ()
 393       `(lambda ()
 394          (declare (notinline >=))
 395          (block nil
 396            (lambda (x &key (key (if (>= 0 1)
 397                                     (return (catch 'ct5 0)))))
 398              (declare (ignore key))
 399              x)))
 400     (() 123 :test (lambda (values expected)
 401                     (equal (multiple-value-list
 402                             (funcall (first values) (first expected)))
 403                            expected)))))
 404
 405 (with-test (:name :dead-lvars-and-stack-analysis)
 406   (checked-compile-and-assert ()
 407     `(lambda (b)
 408        (catch 'ct2
 409          (block b5
 410            (return-from b5
 411              (multiple-value-prog1 19
 412                (if (or b t)
 413                    (return-from b5 333)))))))
 414     ((11) 333)))
 415
 416 (with-test (:name :mv-call-more-values)
 417   (checked-compile-and-assert ()
 418     `(lambda (z)
 419        (multiple-value-call (lambda (&optional x y &rest args)
 420                               (declare (ignore args))
 421                               (+ y x))
 422          2 (truncate z 30)))
 423     ((2345) 80)))
 424
 425 (with-test (:name :unused-casts-at-ir2-convert)
 426   (checked-compile-and-assert ()
 427     `(lambda ()
 428        (unwind-protect 123
 429          (the integer
 430               (labels ((%f (x &key)
 431                          (declare (ignore x))
 432                          (svref #(46 32) 0)))
 433                 (unwind-protect (%f (%f 0)))))))
 434     (() 123)))
 435
 436 (with-test (:name :cmov-constants-different-primitive-type)
 437   (checked-compile-and-assert ()
 438     `(lambda (b)
 439        (case b
 440          ((2030) 4611686018427387908)
 441          ((572) b)
 442          (t 0)))
 443     ((572) 572)
 444     ((123) 0)
 445     ((2030) 4611686018427387908)))
 446
 447 (with-test (:name :mv-bind-skipping-vars-on-reoptimize)
 448   (checked-compile-and-assert ()
 449     `(lambda ()
 450        (let (lv1)
 451          (apply (lambda (&rest args)
 452                   (declare (ignore args)))
 453                 0
 454                 (list 3 lv1))
 455          (setf lv1 10)))
 456     (() 10)))
 457
 458 (with-test (:name :transform-on-a-nil-arg)
 459   (checked-compile-and-assert ()
 460    `(lambda ()
 461       (block nil
 462         (logtest
 463          (multiple-value-prog1
 464              (unwind-protect (return 32))
 465            (catch 'tag (return 33)))
 466          1)
 467         34))
 468    (() 32)))
 469
 470 (with-test (:name :nesteted-dx-deleted-uses)
 471   (checked-compile-and-assert ()
 472     `(lambda (a)
 473        (block b2
 474          (let* ((v1 (make-array nil :initial-element
 475                                 (let ((a a))
 476                                   (return-from b2 a)))))
 477            (declare (dynamic-extent v1))
 478            (aref v1))))
 479     ((342) 342)))
 480
 481 (with-test (:name :deleted-during-locall-analyze-fun-1)
 482   (checked-compile-and-assert (:allow-warnings t)
 483     `(lambda ()
 484        (flet ((a ()))
 485          (a 1)
 486          (a 2)))
 487     (() (condition 'program-error))))
 488
 489 (with-test (:name :delete-return-without-flush-dest)
 490   (assert (eql
 491            (catch 'c
 492              (funcall (checked-compile
 493                        '(lambda ()
 494                          (labels ((%f () 40))
 495                            (multiple-value-prog1 *
 496                              (throw 'c (%f))
 497                              (%f)
 498                              30))))))
 499            40)))
 500
 501 (with-test (:name :let-conversion-inside-deleted-lambda.1)
 502   (checked-compile-and-assert ()
 503     `(lambda ()
 504        (block nil
 505          (catch 'c)
 506          (flet ((f (x &key)
 507                   (when x
 508                     (progv '(*) '(0)
 509                       (return)))))
 510            (f (return 123))
 511            (f 0))))
 512     (() 123)))
 513
 514 (with-test (:name :let-conversion-inside-deleted-lambda.2)
 515   (checked-compile-and-assert ()
 516     `(lambda ()
 517        (block nil
 518          (block nil
 519            (lambda () (return)))
 520          (labels ((l () (l))
 521                   (%f (a &key)
 522                     (l)
 523                     (return a)))
 524            (%f (return 321))
 525            (%f 1))))
 526     (() 321)))
 527
 528 (with-test (:name :unconvert-tail-calls)
 529   (checked-compile-and-assert ()
 530     `(lambda ()
 531        (block nil
 532          (labels ((f (&optional (a (return))
 533                                 (b (if t (return)))
 534                                 c
 535                       &rest args)
 536                     (declare (ignore a b c args))
 537                     (return 0)))
 538            (let (x)
 539              (equal 10 (f 0 3))
 540              (f 123 0 0)
 541              (f 0)
 542              x))))
 543     (() 0)))
 544
 545 (with-test (:name :deleting-exits-with-multiple-users)
 546   (checked-compile-and-assert ()
 547     `(lambda (a b)
 548        (block nil
 549          (multiple-value-prog1 b
 550            (tagbody (return (multiple-value-prog1 3
 551                               (if a (go z)))) z))))
 552     ((nil :good) 3)
 553     ((t :good) :good)))
 554
 555 (with-test (:name :merge-tail-sets-deleted-functional)
 556   (checked-compile-and-assert ()
 557     `(lambda (a)
 558        (block nil
 559          (tagbody
 560             (go g549)
 561           g549
 562             (return-from nil
 563               (block b3
 564                 (let ((x (progn (lambda (&optional (x a)) x)
 565                                 (unwind-protect 10)
 566                                 (return-from b3 a))))
 567                   (unwind-protect x)))))))
 568     ((321) 321)))
 569
 570 (with-test (:name :interval-div-zero)
 571   (checked-compile-and-assert (:optimize :safe)
 572     `(lambda (x y)
 573        (truncate (the (integer 0 0) x)
 574                  (the (rational (1) (2)) y)))
 575    ((0 3/2) (values 0 0))))
 576
 577 (with-test (:name :float-remainders-rounding-errors)
 578   (loop for fun in '(ceiling truncate floor
 579                      fceiling ftruncate ffloor
 580                      round fround)
 581         do
 582         (assert (member (second
 583                          (third (sb-kernel:%simple-fun-type
 584                                  (checked-compile
 585                                   `(lambda (x)
 586                                      (nth-value 1 (,fun (the double-float x) 1/2)))))))
 587                         '(double-float real)))))
 588
 589 (with-test (:name :float-quotient-rounding-errors)
 590   (checked-compile-and-assert (:optimize :safe)
 591    `(lambda ()
 592       (floor -114658225103614 84619.58))
 593     (() (values -1354984705 8473228.0)))
 594   (checked-compile-and-assert (:optimize :safe)
 595    `(lambda ()
 596       (ceiling 114658225103614 84619.58))
 597     (() (values 1354984705 -8473228.0))))
 598
 599 (with-test (:name :complex-float-contagion)
 600   (checked-compile-and-assert ()
 601     `(lambda (p1)
 602        (declare (type (or double-float integer) p1))
 603        (complex p1 2.0))
 604     ((1d0) #c(1d0 2d0))))
 605
 606 (with-test (:name :equal-transform-member-types)
 607   (let* ((s1 "abc")
 608          (s2 (copy-seq s1)))
 609     (checked-compile-and-assert ()
 610       `(lambda (p1 p2)
 611          (declare (type (member ,s1) p1)
 612                   (type (member ,s2 #*10) p2))
 613          (equal p1 p2))
 614       ((s1 s2) t))))
 615
 616 (with-test (:name :equalp-transform-numeric-types)
 617   (checked-compile-and-assert ()
 618     `(lambda (p1 p2)
 619        (declare (type (or fixnum list) p1)
 620                 (type double-float p2))
 621        (equalp p1 p2))
 622     ((1 1d0) t)))
 623
 624 (with-test (:name :equalp-transform-zero-array)
 625   (checked-compile-and-assert ()
 626     `(lambda (a b)
 627        (declare (simple-string a)
 628                 (simple-bit-vector b))
 629        (equalp a b))
 630     (("" #*) t)))
 631
 632 (with-test (:name :fill-transform-returning-array-data)
 633   (let ((vector (make-array 10 :fill-pointer 2)))
 634     (checked-compile-and-assert ()
 635       `(lambda (v)
 636            (declare (type (vector t) v))
 637            (fill v nil))
 638       ((vector) vector))))
 639
 640 (with-test (:name :missing-error-context)
 641   (flet ((run ()
 642           (let ((string
 643                  (with-output-to-string (*error-output*)
 644                    (compile nil '(sb-int:named-lambda bob () (otherfun) 3)))))
 645             (assert (search "in: SB-INT:NAMED-LAMBDA BOB" string)))))
 646     (run)
 647     ;; Unrepeatability is confusing:
 648     ;; The first compiler invocation used to leave *last-format-string*
 649     ;; with a toplevel value, so the second would not print enough context
 650     ;; because the format control and args were the same.
 651     (run)))
 652
 653 (with-test (:name :cast-deletion-notes)
 654   (checked-compile-and-assert
 655       (:allow-notes nil)
 656       `(lambda (m)
 657          (setf m (list 1 2 3))
 658          (the simple-vector
 659               (coerce m 'vector)))
 660     ((nil) #(1 2 3) :test #'equalp)))
 661
 662 (with-test (:name :cast-deletion-notes.2)
 663   (multiple-value-bind (fun fail warn style notes)
 664       (checked-compile
 665        `(lambda (m)
 666           (setf m (list 1 2 3))
 667           (the simple-vector
 668                (if (vectorp m)
 669                    m
 670                    #(1)))))
 671     (declare (ignore fail warn style))
 672     (assert (equalp (funcall fun nil)
 673                     #(1)))
 674     (assert (= (length notes) 1))
 675     (assert (typep (car notes) 'code-deletion-note))))
 676
 677 (with-test (:name :array-call-type-deriver)
 678   (checked-compile-and-assert
 679       ()
 680       `(lambda (vector)
 681          (funcall (the (function (t t)) #'aref)
 682                   vector
 683                   0))
 684     (((vector 333)) 333)))
 685
 686 (with-test (:name :function-designator-cast-removal)
 687   (let ((fun (checked-compile
 688               `(lambda (vectors x)
 689                  (declare (list vectors x))
 690                  (map 'list #'svref vectors x)))))
 691     (assert (notany (lambda (c)
 692                       (typecase c
 693                         (sb-kernel:fdefn
 694                          (eq (sb-c::fdefn-name c) 'svref))
 695                         (function
 696                          (eq c #'svref))))
 697                     (ctu:find-code-constants fun)))
 698     (assert (equal (funcall fun '(#(44)) '(0)) '(44)))))
 699
 700 (with-test (:name :zombie-casts)
 701   (checked-compile-and-assert
 702       ()
 703       `(lambda ()
 704          (flet ((f (a b)
 705                   (declare (ignore a))
 706                   b))
 707            (multiple-value-call #'f
 708              (values (the integer (unwind-protect (f 10 20)))
 709                      322))))
 710     (() 322)))
 711
 712 (with-test (:name :zombie-casts.2)
 713   (let ((sb-c::*max-optimize-iterations* 1))
 714     (checked-compile-and-assert
 715         ()
 716         `(lambda (a b)
 717            (declare (type fixnum a b))
 718            (elt '(167992664 119771479)
 719                 (max 0
 720                      (catch 'ct2
 721                        (if (typep b '(integer -52))
 722                            a
 723                            0)))))
 724       ((1 2) 119771479))))
 725
 726
 727 (with-test (:name :find-dfo-on-deleted-lambda)
 728   (assert (= (funcall
 729               (funcall (checked-compile
 730                         `(lambda ()
 731                            (declare (notinline <))
 732                            (block nil
 733                              (lambda (&key (key
 734                                             (unwind-protect
 735                                                  (if (< 0)
 736                                                      34
 737                                                      (return (catch 'c))))))
 738                                key))))))
 739              34)))
 740
 741 (with-test (:name :ir1-ir2-dead-code-consistency)
 742   (checked-compile-and-assert
 743       ()
 744       `(lambda ()
 745          (loop for x below 2
 746                count (zerop (min x x x x x x x x x x))))
 747     (() 1)))
 748
 749 (with-test (:name :ir1-ir2-dead-code-consistency)
 750   (checked-compile-and-assert
 751       ()
 752       `(lambda ()
 753          (loop for x below 2
 754                count (zerop (min x x x x x x x x x x))))
 755     (() 1)))
 756
 757 (with-test (:name (setf svref :constant-modification))
 758   (assert
 759    (= (length (nth-value 2
 760                          (checked-compile
 761                           `(lambda (x)
 762                              (setf (svref #(a b c) 1) x))
 763                           :allow-warnings 'sb-int:constant-modified)))
 764             1)))
 765
 766 (with-test (:name (debug :constant-modification))
 767   (assert
 768    (= (length (nth-value 2
 769                          (checked-compile
 770                           `(lambda (x)
 771                              (declare (optimize (debug 2)))
 772                              (let ((m "abc"))
 773                                (delete x m)))
 774                           :allow-warnings 'sb-int:constant-modified)))
 775       1)))
 776
 777 (with-test (:name (debug :unused-tn-long-arglist))
 778   (checked-compile-and-assert
 779       ()
 780       `(lambda (n x)
 781          (declare (sb-vm:word n))
 782          (log (float n))
 783          (nth-value 33 (funcall x . #.(loop for i to 35 collect i))))
 784     ((10 (lambda (&rest args) (values-list args))) 33)))
 785
 786 (with-test (:name (debug :unused-tn-very-long-arglist))
 787   (checked-compile-and-assert
 788       ()
 789       `(lambda (n x)
 790          (declare (sb-vm:word n))
 791          (log (float n))
 792          (nth-value 33 (funcall x . #.(loop for i to 350 collect i))))
 793     ((10 (lambda (&rest args) (values-list args))) 33)))
 794
 795 (with-test (:name (dynamic-extent :recursive-local-functions))
 796   (checked-compile
 797    `(lambda ()
 798       (let ((s (labels ((%f () (%f)))
 799                  (%f))))
 800         (declare (dynamic-extent s))
 801         (car s)))))
 802
 803 (with-test (:name (:ctypep :hairy-types))
 804   (checked-compile
 805    `(lambda ()
 806       (the (cons (satisfies error)) '("a"))))
 807   (assert
 808    (nth-value 3
 809               (checked-compile
 810                `(lambda () (the (array abc) #()))
 811                :allow-style-warnings t))))
 812
 813 (with-test (:name (catch :evaluate-tag-before-%catch))
 814   (checked-compile-and-assert
 815       (:allow-style-warnings t)
 816       `(lambda (z)
 817          (catch (multiple-value-call #'+
 818                   (if z 1 (values 1 2)))
 819            :done))
 820     ((t) :done)
 821       ((nil) :done)))
 822
 823 (with-test (:name :fewer-cast-conversions)
 824   (multiple-value-bind (fun failed)
 825       (checked-compile
 826        `(lambda ()
 827           (let* ((v (cons 0 (catch 'ct (the integer nil)))))
 828             (declare (dynamic-extent v))
 829             (flet ((%f (x) x))
 830               (%f (cdr v)))))
 831        :allow-warnings t)
 832     (assert failed)
 833     (handler-bind ((error (lambda (c) c (throw 'ct 33))))
 834       (assert (= (funcall fun) 33)))))
 835
 836 (with-test (:name :constant-folding-with-callable-args)
 837   (checked-compile '(lambda () (count #'%f '(a)))
 838                    :allow-style-warnings t))
 839
 840 (with-test (:name :flushable-with-callable-args)
 841   (let ((fun (checked-compile '(lambda (y) (let ((x (count y '(1 2 3))))
 842                                              (declare (ignore x)))))))
 843     (assert (not (ctu:find-named-callees fun)))))
 844
 845 (with-test (:name (remove :count))
 846   (checked-compile-and-assert
 847    ()
 848    `(lambda (x)
 849       (remove x "aaa" :count 2))
 850    ((#\a) "a"))
 851   (checked-compile-and-assert
 852    ()
 853    `(lambda (x)
 854       (remove-if (lambda (y) (eql y x)) "aaa" :count 2))
 855    ((#\a) "a")))
 856
 857 (with-test (:name (:constant-fold :allow-other-keys))
 858   (checked-compile-and-assert
 859    ()
 860    `(lambda (x)
 861       (reduce #'+ '(1 2 3)  :allow-other-keys t :bad x))
 862    ((1) 6)))
 863
 864 (with-test (:name (:constant-fold :allow-other-keys.2))
 865   (checked-compile-and-assert
 866    ()
 867    `(lambda (x)
 868       (reduce #'+ '(1 2 3)  :allow-other-keys x))
 869    ((1) 6)))
 870
 871 (with-test (:name (:constant-fold :repeat-keys))
 872   (checked-compile-and-assert
 873    ()
 874    `(lambda (x)
 875       (member nil '(1 2 3) :key #'evenp :key x))
 876    ((1) '(1 2 3) :test #'equal)))
 877
 878
 879
 880 (with-test (:name :function-and-instance-primitive-type)
 881   (checked-compile-and-assert
 882       ()
 883       `(lambda (f)
 884          (declare (function f))
 885          (the standard-object f)
 886          (funcall f #'list t))
 887     ((#'documentation) (documentation #'list t))))
 888
 889 (with-test (:name :mv-call-safety-0)
 890   (checked-compile-and-assert
 891       ()
 892       `(lambda (a)
 893          (flet ((%f1 (x y) (+ x y)))
 894            (apply #'%f1 a (list 0))))
 895     ((3) 3)))
 896
 897 (with-test (:name :cast-type-check-external)
 898   (checked-compile-and-assert
 899       ()
 900       `(lambda (x)
 901          (declare (notinline +))
 902          (gcd
 903           (loop for lv2 below 1
 904                 count (logbitp 0
 905                                (if x
 906                                    (return x)
 907                                    1)))
 908           0))
 909     ((334) 334)))
 910
 911 (with-test (:name :flush-combination-non-fun-type)
 912   (checked-compile-and-assert
 913       ()
 914       `(lambda ()
 915          (rassoc-if-not #'values '((1 . a)) :allow-other-keys t)
 916          1)
 917     (() 1)))
 918
 919 (with-test (:name :symeval-nil)
 920   (checked-compile-and-assert
 921       ()
 922       `(lambda ()
 923          (sb-kernel:symeval nil))
 924     (() nil)))
 925
 926 (with-test (:name (:physenv-analyze :deleted-lambda))
 927   (checked-compile-and-assert
 928       ()
 929       `(lambda (log)
 930          (loop for str in nil
 931                for i from 0
 932                do
 933                (ignore-errors (format log ""))))
 934     ((t) nil)))
 935
 936 (with-test (:name (:ensure-lvar-fun-form :lvar-uses))
 937   (checked-compile-and-assert
 938       ()
 939       `(lambda (op) (funcall (case op (equal '=) (t '=)) 1 2))
 940     (('equal) nil)
 941     ((t) nil)))
 942
 943 (with-test (:name :substitute-let-funargs-during-find-initial-dfo)
 944   (checked-compile
 945    `(lambda ()
 946       (labels ((%r (f)
 947                  (loop)
 948                  (%r f)))
 949         (%r (lambda ()))))))
 950
 951 (with-test (:name :split-ir2-blocks-cmov)
 952   (checked-compile-and-assert
 953       ()
 954       `(lambda ()
 955          (let ((v (list 0)))
 956            (if (block nil
 957                  (eq v (cdr v)))
 958                1
 959                2)))
 960     (() 2)))
 961
 962 (with-test (:name :=-rational-complex-rational-fold)
 963   (let ((fun (checked-compile '(lambda (x)
 964                                 (declare ((complex integer) x))
 965                                 (= x 10))))
 966         (fun2 (checked-compile '(lambda (x)
 967                                 (declare ((complex rational) x))
 968                                 (= x 10d0)))))
 969     (assert (equal (sb-kernel:%simple-fun-type fun)
 970                    '(function ((complex integer)) (values null &optional))))
 971     (assert (not (funcall fun #C(10 10))))
 972     (assert (equal (sb-kernel:%simple-fun-type fun2)
 973                    '(function ((complex rational)) (values null &optional))))
 974     (assert (not (funcall fun2 #C(10 10))))))
 975
 976 (with-test (:name :find-type-deriver)
 977   (checked-compile-and-assert
 978       ()
 979       `(lambda (x)
 980          (find 1 x :key #'values))
 981     (('(1)) 1)))
 982
 983 (with-test (:name :tail-call-ltn-annotation)
 984   (checked-compile-and-assert
 985       ()
 986       `(lambda (x)
 987          (labels ((ff1 ()
 988                     (multiple-value-call #'print
 989                       (if x
 990                           (values t t)
 991                           nil))
 992                     (ff1)))
 993            (identity (ff1))))))
 994
 995 (with-test (:name (:substitute-lvar-uses :deleted-code-and-dx-lvars))
 996   (assert (nth-value 1
 997                      (checked-compile
 998                       `(lambda ()
 999                          (let ((v (values
1000                                    (the integer
1001                                         (flet ((%f5 (x) x))
1002                                           (%f5)))
1003                                    (unwind-protect 1))))
1004                            (declare (dynamic-extent v))
1005                            v))
1006                       :allow-warnings t))))
1007
1008 (with-test (:name (restart-case :declaration-processing))
1009   (checked-compile-and-assert
1010       ()
1011       `(lambda ()
1012          (restart-case (list)
1013            (my-restart (x) "foo" "bar" x)))
1014     (() ()))
1015   (checked-compile-and-assert
1016       ()
1017       `(lambda ()
1018          (restart-case (list)
1019            (my-restart () (declare))))
1020     (() ())))
1021
1022 (with-test (:name (handler-case :declaration-processing))
1023   (checked-compile-and-assert
1024       ()
1025       `(lambda ()
1026          (handler-case (list 1 2) (error (e) "foo" "bar" e)))
1027     (() '(1 2)))
1028   (assert (nth-value 1
1029                      (checked-compile
1030                       `(lambda ()
1031                          (handler-case (declare)))
1032                       :allow-failure t))))
1033
1034 (with-test (:name (:unconvert-tail-calls :deleted-call))
1035   (assert (nth-value 1
1036                      (checked-compile
1037                       '(lambda ()
1038                         (labels ((%f (&optional (x (* 2 nil (%f)))) x))
1039                           (%f)
1040                           (%f 1)))
1041                       :allow-warnings t))))