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