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       (floor -302254842 50510.5))
 597     (() (eval '(floor -302254842 50510.5))))
 598   (checked-compile-and-assert (:optimize :safe)
 599    `(lambda ()
 600       (ceiling 114658225103614 84619.58))
 601     (() (values 1354984705 -8473228.0)))
 602   (checked-compile-and-assert (:optimize :safe)
 603    `(lambda ()
 604       (ceiling 285493348393 94189.93))
 605     (() (values 3031039 0.0))))
 606
 607 (with-test (:name :complex-float-contagion)
 608   (checked-compile-and-assert ()
 609     `(lambda (p1)
 610        (declare (type (or double-float integer) p1))
 611        (complex p1 2.0))
 612     ((1d0) #c(1d0 2d0))))
 613
 614 (with-test (:name :equal-transform-member-types)
 615   (let* ((s1 "abc")
 616          (s2 (copy-seq s1)))
 617     (checked-compile-and-assert ()
 618       `(lambda (p1 p2)
 619          (declare (type (member ,s1) p1)
 620                   (type (member ,s2 #*10) p2))
 621          (equal p1 p2))
 622       ((s1 s2) t))))
 623
 624 (with-test (:name :equalp-transform-numeric-types)
 625   (checked-compile-and-assert ()
 626     `(lambda (p1 p2)
 627        (declare (type (or fixnum list) p1)
 628                 (type double-float p2))
 629        (equalp p1 p2))
 630     ((1 1d0) t)))
 631
 632 (with-test (:name :equalp-transform-zero-array)
 633   (checked-compile-and-assert ()
 634     `(lambda (a b)
 635        (declare (simple-string a)
 636                 (simple-bit-vector b))
 637        (equalp a b))
 638     (("" #*) t)))
 639
 640 (with-test (:name :equalp-transform-zero-string)
 641   (checked-compile-and-assert
 642    ()
 643    `(lambda (a)
 644       (equalp "" a))
 645    ((#*) t)
 646    ((#()) t)))
 647
 648 (with-test (:name :fill-transform-returning-array-data)
 649   (let ((vector (make-array 10 :fill-pointer 2)))
 650     (checked-compile-and-assert ()
 651       `(lambda (v)
 652            (declare (type (vector t) v))
 653            (fill v nil))
 654       ((vector) vector))))
 655
 656 (with-test (:name :missing-error-context)
 657   (flet ((run ()
 658           (let ((string
 659                  (with-output-to-string (*error-output*)
 660                    (compile nil '(sb-int:named-lambda bob () (otherfun) 3)))))
 661             (assert (search "in: SB-INT:NAMED-LAMBDA BOB" string)))))
 662     (run)
 663     ;; Unrepeatability is confusing:
 664     ;; The first compiler invocation used to leave *last-format-string*
 665     ;; with a toplevel value, so the second would not print enough context
 666     ;; because the format control and args were the same.
 667     (run)))
 668
 669 (with-test (:name :cast-deletion-notes)
 670   (checked-compile-and-assert
 671       (:allow-notes nil)
 672       `(lambda (m)
 673          (setf m (list 1 2 3))
 674          (the simple-vector
 675               (coerce m 'vector)))
 676     ((nil) #(1 2 3) :test #'equalp)))
 677
 678 (with-test (:name :cast-deletion-notes.2)
 679   (multiple-value-bind (fun fail warn style notes)
 680       (checked-compile
 681        `(lambda (m)
 682           (setf m (list 1 2 3))
 683           (the simple-vector
 684                (if (vectorp m)
 685                    m
 686                    #(1)))))
 687     (declare (ignore fail warn style))
 688     (assert (equalp (funcall fun nil)
 689                     #(1)))
 690     (assert (= (length notes) 1))
 691     (assert (typep (car notes) 'code-deletion-note))))
 692
 693 (with-test (:name :array-call-type-deriver)
 694   (checked-compile-and-assert
 695       ()
 696       `(lambda (vector)
 697          (funcall (the (function (t t)) #'aref)
 698                   vector
 699                   0))
 700     (((vector 333)) 333)))
 701
 702 (with-test (:name :function-designator-cast-removal)
 703   (let ((fun (checked-compile
 704               `(lambda (vectors x)
 705                  (declare (list vectors x))
 706                  (map 'list #'svref vectors x)))))
 707     (assert (notany (lambda (c)
 708                       (typecase c
 709                         (sb-kernel:fdefn
 710                          (eq (sb-c::fdefn-name c) 'svref))
 711                         (function
 712                          (eq c #'svref))))
 713                     (ctu:find-code-constants fun)))
 714     (assert (equal (funcall fun '(#(44)) '(0)) '(44)))))
 715
 716 (with-test (:name :zombie-casts)
 717   (checked-compile-and-assert
 718       ()
 719       `(lambda ()
 720          (flet ((f (a b)
 721                   (declare (ignore a))
 722                   b))
 723            (multiple-value-call #'f
 724              (values (the integer (unwind-protect (f 10 20)))
 725                      322))))
 726     (() 322)))
 727
 728 (with-test (:name :zombie-casts.2)
 729   (let ((sb-c::*max-optimize-iterations* 1))
 730     (checked-compile-and-assert
 731         ()
 732         `(lambda (a b)
 733            (declare (type fixnum a b))
 734            (elt '(167992664 119771479)
 735                 (max 0
 736                      (catch 'ct2
 737                        (if (typep b '(integer -52))
 738                            a
 739                            0)))))
 740       ((1 2) 119771479))))
 741
 742
 743 (with-test (:name :find-dfo-on-deleted-lambda)
 744   (assert (= (funcall
 745               (funcall (checked-compile
 746                         `(lambda ()
 747                            (declare (notinline <))
 748                            (block nil
 749                              (lambda (&key (key
 750                                             (unwind-protect
 751                                                  (if (< 0)
 752                                                      34
 753                                                      (return (catch 'c))))))
 754                                key))))))
 755              34)))
 756
 757 (with-test (:name :ir1-ir2-dead-code-consistency)
 758   (checked-compile-and-assert
 759       ()
 760       `(lambda ()
 761          (loop for x below 2
 762                count (zerop (min x x x x x x x x x x))))
 763     (() 1)))
 764
 765 (with-test (:name :ir1-ir2-dead-code-consistency)
 766   (checked-compile-and-assert
 767       ()
 768       `(lambda ()
 769          (loop for x below 2
 770                count (zerop (min x x x x x x x x x x))))
 771     (() 1)))
 772
 773 (with-test (:name (setf svref :constant-modification))
 774   (assert
 775    (= (length (nth-value 2
 776                          (checked-compile
 777                           `(lambda (x)
 778                              (setf (svref #(a b c) 1) x))
 779                           :allow-warnings 'sb-int:constant-modified)))
 780             1)))
 781
 782 (with-test (:name (debug :constant-modification))
 783   (assert
 784    (= (length (nth-value 2
 785                          (checked-compile
 786                           `(lambda (x)
 787                              (declare (optimize (debug 2)))
 788                              (let ((m "abc"))
 789                                (delete x m)))
 790                           :allow-warnings 'sb-int:constant-modified)))
 791       1)))
 792
 793 (with-test (:name (debug :unused-tn-long-arglist))
 794   (checked-compile-and-assert
 795       ()
 796       `(lambda (n x)
 797          (declare (sb-vm:word n))
 798          (log (float n))
 799          (nth-value 33 (funcall x . #.(loop for i to 35 collect i))))
 800     ((10 (lambda (&rest args) (values-list args))) 33)))
 801
 802 (with-test (:name (debug :unused-tn-very-long-arglist))
 803   (checked-compile-and-assert
 804       ()
 805       `(lambda (n x)
 806          (declare (sb-vm:word n))
 807          (log (float n))
 808          (nth-value 33 (funcall x . #.(loop for i to 350 collect i))))
 809     ((10 (lambda (&rest args) (values-list args))) 33)))
 810
 811 (with-test (:name (dynamic-extent :recursive-local-functions))
 812   (checked-compile
 813    `(lambda ()
 814       (let ((s (labels ((%f () (%f)))
 815                  (%f))))
 816         (declare (dynamic-extent s))
 817         (car s)))))
 818
 819 (with-test (:name (:ctypep :hairy-types))
 820   (checked-compile
 821    `(lambda ()
 822       (the (cons (satisfies error)) '("a"))))
 823   (assert
 824    (nth-value 3
 825               (checked-compile
 826                `(lambda () (the (array abc) #()))
 827                :allow-style-warnings t))))
 828
 829 (with-test (:name (catch :evaluate-tag-before-%catch))
 830   (checked-compile-and-assert
 831       (:allow-style-warnings t)
 832       `(lambda (z)
 833          (catch (multiple-value-call #'+
 834                   (if z 1 (values 1 2)))
 835            :done))
 836     ((t) :done)
 837       ((nil) :done)))
 838
 839 (with-test (:name :fewer-cast-conversions)
 840   (multiple-value-bind (fun failed)
 841       (checked-compile
 842        `(lambda ()
 843           (let* ((v (cons 0 (catch 'ct (the integer nil)))))
 844             (declare (dynamic-extent v))
 845             (flet ((%f (x) x))
 846               (%f (cdr v)))))
 847        :allow-warnings t)
 848     (assert failed)
 849     (handler-bind ((error (lambda (c) c (throw 'ct 33))))
 850       (assert (= (funcall fun) 33)))))
 851
 852 (with-test (:name :constant-folding-with-callable-args)
 853   (checked-compile '(lambda () (count #'%f '(a)))
 854                    :allow-style-warnings t))
 855
 856 (with-test (:name :flushable-with-callable-args)
 857   (let ((fun (checked-compile '(lambda (y) (let ((x (count y '(1 2 3))))
 858                                              (declare (ignore x)))))))
 859     (assert (not (ctu:find-named-callees fun)))))
 860
 861 (with-test (:name (remove :count))
 862   (checked-compile-and-assert
 863    ()
 864    `(lambda (x)
 865       (remove x "aaa" :count 2))
 866    ((#\a) "a"))
 867   (checked-compile-and-assert
 868    ()
 869    `(lambda (x)
 870       (remove-if (lambda (y) (eql y x)) "aaa" :count 2))
 871    ((#\a) "a")))
 872
 873 (with-test (:name (:constant-fold :allow-other-keys))
 874   (checked-compile-and-assert
 875    ()
 876    `(lambda (x)
 877       (reduce #'+ '(1 2 3)  :allow-other-keys t :bad x))
 878    ((1) 6)))
 879
 880 (with-test (:name (:constant-fold :allow-other-keys.2))
 881   (checked-compile-and-assert
 882    ()
 883    `(lambda (x)
 884       (reduce #'+ '(1 2 3)  :allow-other-keys x))
 885    ((1) 6)))
 886
 887 (with-test (:name (:constant-fold :repeat-keys))
 888   (checked-compile-and-assert
 889    ()
 890    `(lambda (x)
 891       (member nil '(1 2 3) :key #'evenp :key x))
 892    ((1) '(1 2 3) :test #'equal)))
 893
 894
 895
 896 (with-test (:name :function-and-instance-primitive-type)
 897   (checked-compile-and-assert
 898       ()
 899       `(lambda (f)
 900          (declare (function f))
 901          (the standard-object f)
 902          (funcall f #'list t))
 903     ((#'documentation) (documentation #'list t))))
 904
 905 (with-test (:name :mv-call-safety-0)
 906   (checked-compile-and-assert
 907       ()
 908       `(lambda (a)
 909          (flet ((%f1 (x y) (+ x y)))
 910            (apply #'%f1 a (list 0))))
 911     ((3) 3)))
 912
 913 (with-test (:name :cast-type-check-external)
 914   (checked-compile-and-assert
 915       ()
 916       `(lambda (x)
 917          (declare (notinline +))
 918          (gcd
 919           (loop for lv2 below 1
 920                 count (logbitp 0
 921                                (if x
 922                                    (return x)
 923                                    1)))
 924           0))
 925     ((334) 334)))
 926
 927 (with-test (:name :flush-combination-non-fun-type)
 928   (checked-compile-and-assert
 929       ()
 930       `(lambda ()
 931          (rassoc-if-not #'values '((1 . a)) :allow-other-keys t)
 932          1)
 933     (() 1)))
 934
 935 (with-test (:name :symeval-nil)
 936   (checked-compile-and-assert
 937       ()
 938       `(lambda ()
 939          (sb-kernel:symeval nil))
 940     (() nil)))
 941
 942 (with-test (:name (:physenv-analyze :deleted-lambda))
 943   (checked-compile-and-assert
 944       ()
 945       `(lambda (log)
 946          (loop for str in nil
 947                for i from 0
 948                do
 949                (ignore-errors (format log ""))))
 950     ((t) nil)))
 951
 952 (with-test (:name (:ensure-lvar-fun-form :lvar-uses))
 953   (checked-compile-and-assert
 954       ()
 955       `(lambda (op) (funcall (case op (equal '=) (t '=)) 1 2))
 956     (('equal) nil)
 957     ((t) nil)))
 958
 959 (with-test (:name :substitute-let-funargs-during-find-initial-dfo)
 960   (checked-compile
 961    `(lambda ()
 962       (labels ((%r (f)
 963                  (loop)
 964                  (%r f)))
 965         (%r (lambda ()))))))
 966
 967 (with-test (:name :split-ir2-blocks-cmov)
 968   (checked-compile-and-assert
 969       ()
 970       `(lambda ()
 971          (let ((v (list 0)))
 972            (if (block nil
 973                  (eq v (cdr v)))
 974                1
 975                2)))
 976     (() 2)))
 977
 978 (with-test (:name :=-rational-complex-rational-fold)
 979   (let ((fun (checked-compile '(lambda (x)
 980                                 (declare ((complex integer) x))
 981                                 (= x 10))))
 982         (fun2 (checked-compile '(lambda (x)
 983                                 (declare ((complex rational) x))
 984                                 (= x 10d0)))))
 985     (assert (equal (sb-kernel:%simple-fun-type fun)
 986                    '(function ((complex integer)) (values null &optional))))
 987     (assert (not (funcall fun #C(10 10))))
 988     (assert (equal (sb-kernel:%simple-fun-type fun2)
 989                    '(function ((complex rational)) (values null &optional))))
 990     (assert (not (funcall fun2 #C(10 10))))))
 991
 992 (with-test (:name :find-type-deriver)
 993   (checked-compile-and-assert
 994       ()
 995       `(lambda (x)
 996          (find 1 x :key #'values))
 997     (('(1)) 1)))
 998
 999 (with-test (:name :tail-call-ltn-annotation)
1000   (checked-compile-and-assert
1001       ()
1002       `(lambda (x)
1003          (labels ((ff1 ()
1004                     (multiple-value-call #'print
1005                       (if x
1006                           (values t t)
1007                           nil))
1008                     (ff1)))
1009            (identity (ff1))))))
1010
1011 (with-test (:name (:substitute-lvar-uses :deleted-code-and-dx-lvars))
1012   (assert (nth-value 1
1013                      (checked-compile
1014                       `(lambda ()
1015                          (let ((v (values
1016                                    (the integer
1017                                         (flet ((%f5 (x) x))
1018                                           (%f5)))
1019                                    (unwind-protect 1))))
1020                            (declare (dynamic-extent v))
1021                            v))
1022                       :allow-warnings t))))
1023
1024 (with-test (:name (restart-case :declaration-processing))
1025   (checked-compile-and-assert
1026       ()
1027       `(lambda ()
1028          (restart-case (list)
1029            (my-restart (x) "foo" "bar" x)))
1030     (() ()))
1031   (checked-compile-and-assert
1032       ()
1033       `(lambda ()
1034          (restart-case (list)
1035            (my-restart () (declare))))
1036     (() ())))
1037
1038 (with-test (:name (handler-case :declaration-processing))
1039   (checked-compile-and-assert
1040       ()
1041       `(lambda ()
1042          (handler-case (list 1 2) (error (e) "foo" "bar" e)))
1043     (() '(1 2)))
1044   (assert (nth-value 1
1045                      (checked-compile
1046                       `(lambda ()
1047                          (handler-case (declare)))
1048                       :allow-failure t))))
1049
1050 (with-test (:name (:unconvert-tail-calls :deleted-call))
1051   (assert (nth-value 1
1052                      (checked-compile
1053                       '(lambda ()
1054                         (labels ((%f (&optional (x (* 2 nil (%f)))) x))
1055                           (%f)
1056                           (%f 1)))
1057                       :allow-warnings t))))
1058
1059 (with-test (:name (:equal-transform :nil-types))
1060   (assert (nth-value 1
1061                      (checked-compile
1062                       '(lambda ()
1063                         (loop for y below 3
1064                               count (or
1065                                      (not (or (>= y y) (equal y -787357528)))
1066                                      (the integer (or (>= y y) (equal y -787357528))))))
1067                       :allow-warnings t))))
1068
1069
1070
1071 (with-test (:name (:delete-recursive-optional))
1072   (checked-compile '(lambda (x)
1073                      (lambda ()
1074                        (labels ((f (&optional a) (values x a #'f))))))))
1075
1076 (with-test (:name (:combination-args-flow-cleanly-p :unused-result))
1077   (checked-compile-and-assert
1078       ()
1079       `(lambda ()
1080          (let ((v (flet ((%f (x)
1081                            (list x)
1082                            (list 1)))
1083                     (%f 2))))
1084            (declare (dynamic-extent v))
1085            (car v)))
1086     (() 1)))
1087
1088 (with-test (:name (:delete-ref :maintain-lambda-calls-or-closes))
1089   (checked-compile `(lambda (c y)
1090                       (labels ((f1 ()
1091                                  (if y
1092                                      (f3 2)))
1093                                (l () (loop))
1094                                (f2 ()
1095                                  (l)
1096                                  (f3 3))
1097                                (f3 (x)
1098                                  (f3 x))
1099                                (f4 ()
1100                                  (f1)
1101                                  (f2)))
1102                         (f4)
1103                         c))))
1104
1105 (with-test (:name (the :nil-type))
1106   (checked-compile
1107    `(lambda ()
1108       (flet ((f () (the nil 0)))
1109         (oddp (f))))))
1110
1111 (with-test (:name :concatenate-transform-hairy-type)
1112   (checked-compile
1113       '(lambda (x)
1114         (concatenate '(and string (satisfies eval)) x))))
1115
1116 (with-test (:name :make-array-transform-deletion-notes)
1117   (checked-compile
1118    `(lambda (vector)
1119       (let* ((length (length vector))
1120              (new (make-array length :adjustable t
1121                                      :fill-pointer length)))
1122         new))
1123    :allow-notes nil))
1124
1125 (with-test (:name :ltn-analyze-cast-unlink)
1126   (assert (nth-value 1 (checked-compile
1127                         `(lambda (n)
1128                            (* 2 n)
1129                            (let ((p (make-array n :element-type 'double-float)))
1130                              (dotimes (i n)
1131                                (setf (aref p i)
1132                                      (ignore-errors i)))))
1133                         :allow-warnings t))))
1134
1135 (with-test (:name :call-type-validation)
1136   (checked-compile
1137    `(lambda ()
1138       (funcall (the (or cons function) *debugger-hook*)))))
1139
1140 (with-test (:name :setf-schar-hairy-types)
1141   (checked-compile-and-assert
1142       ()
1143       `(lambda (s v)
1144          (setf (schar (the (satisfies eval) s) 0) v)
1145          s)
1146     (((copy-seq "abc") #\m) "mbc" :test #'equal)))
1147
1148 (with-test (:name :check-function-designator-cast-key-lambda-var)
1149   (checked-compile-and-assert
1150       (:optimize '(:speed 3 :space 0))
1151       `(lambda (p1 p4)
1152          (declare (vector p1)
1153                   ((member ,#'car "x" cdr) p4))
1154          (stable-sort p1 #'<= :key p4))
1155     (((vector '(2) '(3) '(1)) #'car) #((1) (2) (3)) :test #'equalp)))
1156
1157 (with-test (:name :replace-zero-elements)
1158   (checked-compile-and-assert
1159       ()
1160       '(lambda (x)
1161         (declare ((simple-vector 2) x))
1162         (replace x x :start1 2))
1163     (((vector 1 2)) #(1 2) :test #'equalp))
1164   (checked-compile-and-assert
1165       ()
1166       '(lambda (x)
1167         (replace x x :start1 2))
1168     (((vector 1 2)) #(1 2) :test #'equalp)))