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