tests/compiler-slow.pure.lisp

   1 (with-test (:name (compile eval the type-error))
   2   (checked-compile-and-assert (:optimize :safe)
   3       '(lambda (v)
   4         (list (the fixnum (the (real 0) (eval v)))))
   5     ((0.1) (condition 'type-error))
   6     ((-1)  (condition 'type-error))))
   7
   8 (defun pick-acceptable-default (specifier)
   9   (let ((parse (sb-kernel:specifier-type specifier)))
  10     ; (format t "~&testcase: ~s~%" specifier)
  11     (typecase parse
  12       (sb-kernel:character-set-type #\a)
  13       (sb-kernel:numeric-type
  14        (cond ((eq (sb-kernel:numeric-type-class parse) 'float)
  15               (ecase (sb-kernel:numeric-type-complexp parse)
  16                 (:real
  17                  (ecase (sb-kernel:numeric-type-format parse)
  18                    (single-float 1009f0)
  19                    (double-float pi)))
  20                 (:complex
  21                  (ecase (sb-kernel:numeric-type-format parse)
  22                    (single-float #c(101f0 -1f0))
  23                    (double-float #c(2d0 3.5d0))))))
  24              (t
  25               1)))
  26       (t
  27        (cond ((equal specifier '(or (eql 1.0d0) (eql 10.0d0))) ; KLUDGE
  28               1.0d0)
  29              ((equal specifier '(member 1 2 10))
  30               2)
  31              ((equal specifier '(complex (member 10.0 20.0)))
  32               (complex 10.0 10.0))
  33              (t
  34               'whatever))))))
  35
  36 (with-test (:name :array-type-predicates)
  37   (dolist (et (list* '(integer -1 200) '(integer -256 1)
  38                      '(integer 0 128)
  39                      '(integer 0 (128))
  40                      '(double-float 0d0 (1d0))
  41                      '(single-float (0s0) (1s0))
  42                      '(or (eql 1d0) (eql 10d0))
  43                      '(member 1 2 10)
  44                      '(complex (member 10 20))
  45                      '(complex (member 10d0 20d0))
  46                      '(complex (member 10s0 20s0))
  47                      '(or integer double-float)
  48                      '(mod 1)
  49                      '(member #\a #\b)
  50                      '(eql #\a)
  51                      #+sb-unicode 'extended-char
  52                      #+sb-unicode '(eql #\cyrillic_small_letter_yu)
  53                      (map 'list 'sb-vm:saetp-specifier
  54                           sb-vm:*specialized-array-element-type-properties*)))
  55     (when et
  56       (let* ((v (make-array 3 :element-type et
  57                             ;; Pick an initial element because of the (ELT ,v 0)
  58                               :initial-element (pick-acceptable-default et))))
  59         (checked-compile-and-assert ()
  60             `(lambda ()
  61                (list (if (typep ,v '(simple-array ,et (*)))
  62                          :good
  63                          ',et)
  64                      (if (typep (elt ,v 0) '(simple-array ,et (*)))
  65                          ',et
  66                          :good)))
  67           (() '(:good :good)))))))
  68
  69 (with-test (:name (compile equal equalp :transforms))
  70   (let* ((s "foo")
  71          (bit-vector #*11001100)
  72          (values `(nil 1 2 "test"
  73                        ;; Floats duplicated here to ensure we get newly created instances
  74                        (read-from-string "1.1") (read-from-string "1.2d0")
  75                        (read-from-string "1.1") (read-from-string "1.2d0")
  76                        1.1 1.2d0 '("foo" "bar" "test")
  77                        #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
  78                        ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
  79                        ,(make-hash-table) #\a #\b #\A #\C
  80                        ,(make-random-state) 1/2 2/3)))
  81
  82     (dolist (predicate '(equal equalp))
  83       ;; Test all permutations of different types
  84       (loop for x in values
  85          do (loop for y in values
  86                do (checked-compile-and-assert (:optimize nil)
  87                       `(lambda (x y)
  88                          (,predicate (the ,(type-of x) x)
  89                                      (the ,(type-of y) y)))
  90                     ((x y) (funcall predicate x y)))))
  91       (checked-compile-and-assert ()
  92           `(lambda (x y)
  93              (,predicate (the (cons (or simple-bit-vector simple-base-string))
  94                               x)
  95                          (the (cons (or (and bit-vector (not simple-array))
  96                                         (simple-array character (*))))
  97                               y)))
  98         (((list (string 'list)) (list "LIST")) t)))))
  99
 100 (with-test (:name (sb-c::mask-signed-field :randomized))
 101   (let (result)
 102     (dotimes (i 1000)
 103       (let* ((ool (checked-compile '(lambda (s i)
 104                                      (sb-c::mask-signed-field s i))))
 105              (size (random (* sb-vm:n-word-bits 2)))
 106              (constant (checked-compile `(lambda (i)
 107                                            (sb-c::mask-signed-field ,size i))))
 108              (arg (- (random (* most-positive-fixnum 8)) (* most-positive-fixnum 4)))
 109              (declared (checked-compile `(lambda (i)
 110                                            (declare (type (integer ,(- (abs arg)) ,(abs arg)) i))
 111                                            (sb-c::mask-signed-field ,size i))))
 112              (ool-answer (funcall ool size arg))
 113              (constant-answer (funcall constant arg))
 114              (declared-answer (funcall declared arg)))
 115         (unless (= ool-answer constant-answer declared-answer)
 116           (push (list size arg ool-answer constant-answer declared-answer) result))))
 117     (assert (null result))))
 118
 119 (with-test (:name (multiple-value-call :type-checking-rest))
 120   (checked-compile-and-assert (:allow-warnings t
 121                                :optimize :safe)
 122       `(lambda (list)
 123          (multiple-value-call
 124              (lambda (&optional a &rest r)
 125                (declare ((satisfies eval) r)
 126                         (ignore r))
 127                (list a))
 128            (values-list list)))
 129     (('(1 list 2)) '(1))
 130     (('(1)) (condition 'type-error))))
 131
 132 (with-test (:name (multiple-value-call :type-checking-rest.2))
 133   (checked-compile-and-assert (:allow-warnings t
 134                                :optimize :safe)
 135       `(lambda (list)
 136          (multiple-value-call
 137              (lambda (&optional a &rest r)
 138                (declare (null r)
 139                         (ignore r))
 140                (list a))
 141            (values-list list)))
 142     (('(1 list 2)) (condition 'type-error))
 143     (('(1)) '(1))))
 144
 145 (with-test (:name (multiple-value-call :type-checking-rest :type-derivation))
 146   (checked-compile-and-assert (:allow-warnings t
 147                                :optimize :safe)
 148       `(lambda (list)
 149          (multiple-value-call
 150              (lambda (&optional a &rest r)
 151                (declare (cons r)
 152                         (ignore r))
 153                (list a))
 154            (values-list list)))
 155     (('(1 2)) '(1))
 156     (('(1)) (condition 'type-error))))
 157
 158 (declaim (maybe-inline inline-recursive))
 159 (defun inline-recursive (x)
 160   (declare (muffle-conditions compiler-note
 161                               style-warning))
 162   (if (zerop x)
 163       x
 164       (inline-recursive (1- x))))
 165 (declaim (inline inline-recursive))
 166
 167 (with-test (:name :reanalyze-functionals-when-inlining)
 168   (checked-compile-and-assert
 169    ()
 170    `(lambda (x)
 171       (inline-recursive x)
 172       (inline-recursive x))
 173     ((5) 0)))
 174
 175 (with-test (:name :interval-div-zero)
 176   (checked-compile-and-assert (:optimize :safe)
 177     `(lambda (x y)
 178        (truncate (the (integer 0 0) x)
 179                  (the (rational (1) (2)) y)))
 180    ((0 3/2) (values 0 0))))
 181
 182 (with-test (:name :float-quotient-rounding-errors
 183             :skipped-on :x86) ;; x87 has different precision loss
 184   (checked-compile-and-assert (:optimize :safe)
 185    `(lambda ()
 186       (floor -114658225103614 84619.58))
 187     (() (values -1354984705 8473228.0)))
 188   (checked-compile-and-assert (:optimize :safe)
 189    `(lambda ()
 190       (floor -302254842 50510.5))
 191     (() (eval '(floor -302254842 50510.5))))
 192   (checked-compile-and-assert (:optimize :safe)
 193    `(lambda ()
 194       (ceiling 114658225103614 84619.58))
 195     (() (values 1354984705 -8473228.0)))
 196   (checked-compile-and-assert (:optimize :safe)
 197    `(lambda ()
 198       (ceiling 285493348393 94189.93))
 199    (() (values 3031039 0.0))))
 200
 201 (with-test (:name :check-function-designator-cast-key-lambda-var)
 202   (checked-compile-and-assert
 203       (:optimize '(:speed 3 :space 0))
 204       `(lambda (p1 p4)
 205          (declare (vector p1)
 206                   ((member ,#'car "x" cdr) p4))
 207          (stable-sort p1 #'<= :key p4))
 208     (((vector '(2) '(3) '(1)) #'car) #((1) (2) (3)) :test #'equalp)))
 209
 210 (with-test (:name :functional-may-escape-p
 211             ;; INVALID-UNWIND-ERROR crashes fatally on ppc32. Not sure as of when.
 212             :broken-on :ppc)
 213   (checked-compile-and-assert
 214       (:optimize :safe)
 215       '(lambda ()
 216         (let (x)
 217           (block nil
 218             (flet ((x () (let (*)
 219                            (return 33))))
 220               (setf x #'x)))
 221           (funcall x)))
 222     (() (condition 'control-error))))
 223
 224 (with-test (:name :lvar-fun-type-on-literal-funs)
 225   (checked-compile-and-assert
 226    ()
 227    `(lambda (p)
 228       (declare (type (or null string) p))
 229       (locally (declare (optimize (space 0)))
 230         (stable-sort p ,#'string<)))
 231    (((copy-seq "acb")) "abc" :test #'equal)))
 232
 233 (with-test (:name :ir2-optimize-jumps-multiway-branch-if-eq-delete-branch)
 234   (checked-compile-and-assert
 235       ()
 236       `(lambda (a)
 237          (declare (type (integer -345 1) a))
 238          (case (ldb (byte 24 5) a)
 239            ((4 47 61 17 10 39) 1)
 240            ((2 7 55) A)
 241            ((42 48 16 33 40 20) A)
 242            ((60 54 28) 3)
 243            ((15 1 44 29 57 41 52) 32771)
 244            ((46 64 3 18 36 49 37) 1)
 245            (t A)))
 246     ((-5) -5)))