tests/alien.impure.lisp

   1 ;;;; This file is for compiler tests which have side effects (e.g.
   2 ;;;; executing DEFUN) but which don't need any special side-effecting
   3 ;;;; environmental stuff (e.g. DECLAIM of particular optimization
   4 ;;;; settings). Similar tests which *do* expect special settings may
   5 ;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; While most of SBCL is derived from the CMU CL system, the test
  11 ;;;; files (like this one) were written from scratch after the fork
  12 ;;;; from CMU CL.
  13 ;;;;
  14 ;;;; This software is in the public domain and is provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  16 ;;;; more information.
  17
  18 (cl:in-package :cl-user)
  19
  20 ;;; In sbcl-0.6.10, Douglas Brebner reported that (SETF EXTERN-ALIEN)
  21 ;;; was messed up so badly that trying to execute expressions like
  22 ;;; this signalled an error.
  23 (setf (sb-alien:extern-alien "thread_control_stack_size" sb-alien:unsigned)
  24       (sb-alien:extern-alien "thread_control_stack_size" sb-alien:unsigned))
  25
  26 ;;; bug 133, fixed in 0.7.0.5: Somewhere in 0.pre7.*, C void returns
  27 ;;; were broken ("unable to use values types here") when
  28 ;;; auto-PROCLAIM-of-return-value was added to DEFINE-ALIEN-ROUTINE.
  29 (sb-alien:define-alien-routine ("free" free) void (ptr (* t) :in))
  30
  31 ;;; Types of alien functions were being incorrectly DECLAIMED when
  32 ;;; docstrings were included in the definition until sbcl-0.7.6.15.
  33 (sb-alien:define-alien-routine ("getenv" ftype-correctness) c-string
  34   "docstring"
  35   (name c-string))
  36
  37 (multiple-value-bind (function warningsp failurep)
  38     (compile nil '(lambda () (ftype-correctness)))
  39   (assert warningsp))
  40
  41 (multiple-value-bind (function warningsp failurep)
  42     (compile nil '(lambda () (ftype-correctness "FOO")))
  43   (assert (not warningsp)))
  44
  45 (multiple-value-bind (function warningsp failurep)
  46     (compile nil '(lambda () (ftype-correctness "FOO" "BAR")))
  47   (assert warningsp))
  48
  49 ;;; This used to break due to too eager auxiliary type twiddling in
  50 ;;; parse-alien-record-type.
  51 (defparameter *maybe* nil)
  52 (defun with-alien-test-for-struct-plus-funcall ()
  53   (with-alien ((x (struct bar (x unsigned) (y unsigned)))
  54                ;; bogus definition, but we just need the symbol
  55                (f (function int (* (struct bar))) :extern "printf"))
  56     (when *maybe*
  57       (alien-funcall f (addr x)))))
  58
  59 ;;; Mutually referent structures
  60 (define-alien-type struct.1 (struct struct.1 (x (* (struct struct.2))) (y int)))
  61 (define-alien-type struct.2 (struct struct.2 (x (* (struct struct.1))) (y int)))
  62 (let ((s1 (make-alien struct.1))
  63       (s2 (make-alien struct.2)))
  64   (setf (slot s1 'x) s2
  65         (slot s2 'x) s1
  66         (slot (slot s1 'x) 'y) 1
  67         (slot (slot s2 'x) 'y) 2)
  68   (assert (= 1 (slot (slot s1 'x) 'y)))
  69   (assert (= 2 (slot (slot s2 'x) 'y))))
  70
  71 ;;; "Alien bug" on sbcl-devel 2004-10-11 by Thomas F. Burdick caused
  72 ;;; by recursive struct definition.
  73 (let ((fname "alien-bug-2004-10-11.tmp.lisp"))
  74   (unwind-protect
  75        (progn
  76          (with-open-file (f fname :direction :output)
  77            (mapc (lambda (form) (print form f))
  78                  '((defpackage :alien-bug
  79                      (:use :cl :sb-alien))
  80                    (in-package :alien-bug)
  81                    (define-alien-type objc-class
  82                        (struct objc-class
  83                         (protocols
  84                          (* (struct protocol-list
  85                                     (list (array (* (struct objc-class))))))))))))
  86            (load fname)
  87            (load fname)
  88            (load (compile-file fname))
  89            (load (compile-file fname)))
  90     (delete-file (compile-file-pathname fname))
  91     (delete-file fname)))
  92
  93 ;;; enumerations with only one enum resulted in division-by-zero
  94 ;;; reported on sbcl-help 2004-11-16 by John Morrison
  95 (define-alien-type enum.1 (enum nil (:val0 0)))
  96
  97 (define-alien-type enum.2 (enum nil (zero 0) (one 1) (two 2) (three 3)
  98                                     (four 4) (five 5) (six 6) (seven 7)
  99                                     (eight 8) (nine 9)))
 100 (with-alien ((integer-array (array int 3)))
 101   (let ((enum-array (cast integer-array (array enum.2 3))))
 102     (setf (deref enum-array 0) 'three
 103           (deref enum-array 1) 'four)
 104     (setf (deref integer-array 2) (+ (deref integer-array 0)
 105                                      (deref integer-array 1)))
 106     (assert (eql (deref enum-array 2) 'seven))))
 107 ;; The code that is used for mapping from integers to symbols depends on the
 108 ;; `density' of the set of used integers, so test with a sparse set as well.
 109 (define-alien-type enum.3 (enum nil (zero 0) (one 1) (k-one 1001) (k-two 1002)))
 110 (with-alien ((integer-array (array int 3)))
 111   (let ((enum-array (cast integer-array (array enum.3 3))))
 112     (setf (deref enum-array 0) 'one
 113           (deref enum-array 1) 'k-one)
 114     (setf (deref integer-array 2) (+ (deref integer-array 0)
 115                                      (deref integer-array 1)))
 116     (assert (eql (deref enum-array 2) 'k-two))))
 117
 118 ;; enums used to allow values to be used only once
 119 ;; C enums allow for multiple tags to point to the same value
 120 (define-alien-type enum.4
 121     (enum nil (:key1 1) (:key2 2) (:keytwo 2)))
 122 (with-alien ((enum-array (array enum.4 3)))
 123   (setf (deref enum-array 0) :key1)
 124   (setf (deref enum-array 1) :key2)
 125   (setf (deref enum-array 2) :keytwo)
 126   (assert (and (eql (deref enum-array 1) (deref enum-array 2))
 127                (eql (deref enum-array 1) :key2))))
 128
 129 ;;; As reported by Baughn on #lisp, ALIEN-FUNCALL loops forever when
 130 ;;; compiled with (DEBUG 3).
 131 (sb-kernel::values-specifier-type-cache-clear)
 132 (proclaim '(optimize (debug 3)))
 133 (let ((f (compile nil '(lambda (v)
 134                         (sb-alien:alien-funcall (sb-alien:extern-alien "getenv"
 135                                                  (function (c-string) c-string))
 136                          v)))))
 137   (assert (typep (funcall f "HOME") '(or string null))))
 138
 139
 140 ;;; CLH: Test for non-standard alignment in alien structs
 141 ;;;
 142 (sb-alien:define-alien-type align-test-struct
 143     (sb-alien:union align-test-union
 144                     (s (sb-alien:struct nil
 145                                         (s1 sb-alien:unsigned-char)
 146                                         (c1 sb-alien:unsigned-char :alignment 16)
 147                                         (c2 sb-alien:unsigned-char :alignment 32)
 148                                         (c3 sb-alien:unsigned-char :alignment 32)
 149                                         (c4 sb-alien:unsigned-char :alignment 8)))
 150                     (u (sb-alien:array sb-alien:unsigned-char 16))))
 151
 152 (let ((a1 (sb-alien:make-alien align-test-struct)))
 153   (declare (type (sb-alien:alien (* align-test-struct)) a1))
 154   (setf (sb-alien:slot (sb-alien:slot a1 's) 's1) 1)
 155   (setf (sb-alien:slot (sb-alien:slot a1 's) 'c1) 21)
 156   (setf (sb-alien:slot (sb-alien:slot a1 's) 'c2) 41)
 157   (setf (sb-alien:slot (sb-alien:slot a1 's) 'c3) 61)
 158   (setf (sb-alien:slot (sb-alien:slot a1 's) 'c4) 81)
 159   (assert (equal '(1 21 41 61 81)
 160                  (list (sb-alien:deref (sb-alien:slot a1 'u) 0)
 161                        (sb-alien:deref (sb-alien:slot a1 'u) 2)
 162                        (sb-alien:deref (sb-alien:slot a1 'u) 4)
 163                        (sb-alien:deref (sb-alien:slot a1 'u) 8)
 164                        (sb-alien:deref (sb-alien:slot a1 'u) 9)))))
 165
 166 (handler-bind ((compiler-note (lambda (c)
 167                                 (error "bad note! ~A" c))))
 168   (funcall (compile nil '(lambda () (sb-alien:make-alien sb-alien:int)))))
 169
 170 ;;; Test case for unwinding an alien (Win32) exception frame
 171 ;;;
 172 ;;; The basic theory here is that failing to honor a win32
 173 ;;; exception frame during stack unwinding breaks the chain.
 174 ;;; "And if / You don't love me now / You will never love me
 175 ;;; again / I can still hear you saying / You would never break
 176 ;;; the chain."  If the chain is broken and another exception
 177 ;;; occurs (such as an error trap caused by an OBJECT-NOT-TYPE
 178 ;;; error), the system will kill our process.  No mercy, no
 179 ;;; appeal. So, to check that we have done our job properly, we
 180 ;;; need some way to put an exception frame on the stack and then
 181 ;;; unwind through it, then trigger another exception.  (FUNCALL
 182 ;;; 0) will suffice for the latter, and a simple test shows that
 183 ;;; CallWindowProc() establishes a frame and calls a function
 184 ;;; passed to it as an argument.
 185 #+win32
 186 (progn
 187   (load-shared-object "USER32")
 188   (assert
 189    (eq :ok
 190        (handler-case
 191            (tagbody
 192               (alien-funcall
 193                (extern-alien "CallWindowProcW"
 194                              (function unsigned-int
 195                                        (* (function int)) unsigned-int
 196                                        unsigned-int unsigned-int unsigned-int))
 197                (alien-sap
 198                 (sb-alien::alien-callback (function unsigned-int)
 199                                           #'(lambda () (go up))))
 200                0 0 0 0)
 201             up
 202               (funcall 0))
 203          (error ()
 204            :ok)))))
 205
 206 ;;; Unused local alien caused a compiler error
 207 (with-test (:name unused-local-alien)
 208   (let ((fun `(lambda ()
 209                 (sb-alien:with-alien ((alien1923 (array (sb-alien:unsigned 8) 72)))
 210                   (values)))))
 211     (assert (not (funcall (compile nil fun))))))
 212
 213 ;;; Non-local exit from WITH-ALIEN caused alien stack to be leaked.
 214 (defvar *sap-int*)
 215 (defun try-to-leak-alien-stack (x)
 216   (with-alien ((alien (array (sb-alien:unsigned 8) 72)))
 217     (let ((sap-int (sb-sys:sap-int (alien-sap alien))))
 218       (if *sap-int*
 219           (assert (= *sap-int* sap-int))
 220           (setf *sap-int* sap-int)))
 221     (when x
 222       (return-from try-to-leak-alien-stack 'going))
 223     (never)))
 224 (with-test (:name :nlx-causes-alien-stack-leak)
 225   (let ((*sap-int* nil))
 226     (loop repeat 1024
 227           do (try-to-leak-alien-stack t))))
 228
 229 ;;; bug 431
 230 (with-test (:name :alien-struct-redefinition)
 231   (eval '(progn
 232           (define-alien-type nil (struct mystruct (myshort short) (mychar char)))
 233           (with-alien ((myst (struct mystruct)))
 234             (with-alien ((mysh short (slot myst 'myshort)))
 235               (assert (integerp mysh))))))
 236   (let ((restarted 0))
 237     (handler-bind ((error (lambda (e)
 238                             (let ((cont (find-restart 'continue e)))
 239                               (when cont
 240                                 (incf restarted)
 241                                 (invoke-restart cont))))))
 242       (eval '(define-alien-type nil (struct mystruct (myint int) (mychar char)))))
 243     (assert (= 1 restarted)))
 244   (eval '(with-alien ((myst (struct mystruct)))
 245           (with-alien ((myin int (slot myst 'myint)))
 246             (assert (integerp myin))))))
 247
 248 ;;; void conflicted with derived type
 249 (declaim (inline bug-316075))
 250 (sb-alien:define-alien-routine bug-316075 void (result char :out))
 251 (with-test (:name bug-316075)
 252   (handler-bind ((warning #'error))
 253     (compile nil '(lambda () (multiple-value-list (bug-316075))))))
 254
 255
 256 ;;; Bug #316325: "return values of alien calls assumed truncated to
 257 ;;; correct width on x86"
 258 #+x86-64
 259 (sb-alien::define-alien-callback truncation-test (unsigned 64)
 260     ((foo (unsigned 64)))
 261   foo)
 262 #+x86
 263 (sb-alien::define-alien-callback truncation-test (unsigned 32)
 264     ((foo (unsigned 32)))
 265   foo)
 266
 267 (with-test (:name bug-316325 :skipped-on '(not (or :x86-64 :x86)))
 268   ;; This test works by defining a callback function that provides an
 269   ;; identity transform over a full-width machine word, then calling
 270   ;; it as if it returned a narrower type and checking to see if any
 271   ;; noise in the high bits of the result are properly ignored.
 272   (macrolet ((verify (type input output)
 273                `(with-alien ((fun (* (function ,type
 274                                                #+x86-64 (unsigned 64)
 275                                                #+x86 (unsigned 32)))
 276                                   :local (alien-sap truncation-test)))
 277                   (let ((result (alien-funcall fun ,input)))
 278                     (assert (= result ,output))))))
 279     #+x86-64
 280     (progn
 281       (verify (unsigned 64) #x8000000000000000 #x8000000000000000)
 282       (verify (signed 64)   #x8000000000000000 #x-8000000000000000)
 283       (verify (signed 64)   #x7fffffffffffffff #x7fffffffffffffff)
 284       (verify (unsigned 32) #x0000000180000042 #x80000042)
 285       (verify (signed 32)   #x0000000180000042 #x-7fffffbe)
 286       (verify (signed 32)   #xffffffff7fffffff #x7fffffff))
 287     #+x86
 288     (progn
 289       (verify (unsigned 32) #x80000042 #x80000042)
 290       (verify (signed 32)   #x80000042 #x-7fffffbe)
 291       (verify (signed 32)   #x7fffffff #x7fffffff))
 292     (verify (unsigned 16) #x00018042 #x8042)
 293     (verify (signed 16)   #x003f8042 #x-7fbe)
 294     (verify (signed 16)   #x003f7042 #x7042)))
 295
 296 (with-test (:name :bug-654485)
 297   ;; DEBUG 2 used to prevent let-conversion of the open-coded ALIEN-FUNCALL body,
 298   ;; which in turn led the dreaded %SAP-ALIEN note.
 299   (handler-case
 300       (compile nil
 301                `(lambda (program argv)
 302                   (declare (optimize (debug 2)))
 303                   (with-alien ((sys-execv1 (function int c-string (* c-string)) :extern
 304                                            "execv"))
 305                     (values (alien-funcall sys-execv1 program argv)))))
 306     (compiler-note (n)
 307       (error "bad note: ~A" n))))
 308
 309 (with-test (:name :bug-721087)
 310   (assert (typep nil '(alien c-string)))
 311   (assert (not (typep nil '(alien (c-string :not-null t)))))
 312   (assert (eq :ok
 313               (handler-case
 314                   (posix-getenv nil)
 315                 (type-error (e)
 316                   (when (and (null (type-error-datum e))
 317                              (equal (type-error-expected-type e)
 318                                     '(alien (c-string :not-null t))))
 319                     :ok))))))
 320
 321 (with-test (:name :make-alien-string)
 322   (let ((alien (sb-alien::make-alien-string "This comes from lisp!")))
 323     (gc :full t)
 324     (assert (equal "This comes from lisp!" (cast alien c-string)))
 325     (free-alien alien)))
 326
 327 (with-test (:name :malloc-failure)
 328   (assert (eq :enomem
 329               (handler-case
 330                   (loop repeat 128
 331                         collect (sb-alien:make-alien char (1- array-total-size-limit)))
 332                 (storage-condition ()
 333                   :enomem)))))
 334
 335 (with-test (:name :bug-985505)
 336   ;; Check that correct octets are reported for a c-string-decoding error.
 337   (assert
 338    (eq :unibyte
 339        (handler-case
 340            (let ((c-string (coerce #(70 111 195 182 0)
 341                                    '(vector (unsigned-byte 8)))))
 342              (sb-sys:with-pinned-objects (c-string)
 343                (sb-alien::c-string-to-string (sb-sys:vector-sap c-string)
 344                                              :ascii 'character)))
 345          (sb-int:c-string-decoding-error (e)
 346            (assert (equalp #(195) (sb-int:character-decoding-error-octets e)))
 347            :unibyte))))
 348   (assert
 349    (eq :multibyte-4
 350        (handler-case
 351            ;; KLUDGE, sort of.
 352            ;;
 353            ;; C-STRING decoding doesn't know how long the string is, and since this
 354            ;; looks like a 4-byte sequence, it will grab 4 octets off the end.
 355            ;;
 356            ;; So we pad the vector for safety's sake.
 357            (let ((c-string (coerce #(70 111 246 0 0 0)
 358                                    '(vector (unsigned-byte 8)))))
 359              (sb-sys:with-pinned-objects (c-string)
 360                (sb-alien::c-string-to-string (sb-sys:vector-sap c-string)
 361                                              :utf-8 'character)))
 362          (sb-int:c-string-decoding-error (e)
 363            (assert (equalp #(246 0 0 0)
 364                            (sb-int:character-decoding-error-octets e)))
 365            :multibyte-4))))
 366   (assert
 367    (eq :multibyte-2
 368        (handler-case
 369            (let ((c-string (coerce #(70 195 1 182 195 182 0) '(vector (unsigned-byte 8)))))
 370              (sb-sys:with-pinned-objects (c-string)
 371                (sb-alien::c-string-to-string (sb-sys:vector-sap c-string)
 372                                              :utf-8 'character)))
 373          (sb-int:c-string-decoding-error (e)
 374            (assert (equalp #(195 1)
 375                            (sb-int:character-decoding-error-octets e)))
 376            :multibyte-2)))))
 377
 378 (with-test (:name :stream-to-c-string-decoding-restart-leakage)
 379   ;; Restarts for stream decoding errors didn't use to be associated with
 380   ;; their conditions, so they could get confused with c-string decoding errors.
 381   (assert (eq :nesting-ok
 382               (catch 'out
 383                 (handler-bind ((sb-int:character-decoding-error
 384                                  (lambda (stream-condition)
 385                                    (handler-bind ((sb-int:character-decoding-error
 386                                                     (lambda (c-string-condition)
 387                                                       (throw 'out
 388                                                         (if (find-restart
 389                                                              'sb-impl::input-replacement
 390                                                              c-string-condition)
 391                                                             :bad-restart
 392                                                             :nesting-ok)))))
 393                                      (let ((c-string (coerce #(70 195 1 182 195 182 0)
 394                                                              '(vector (unsigned-byte 8)))))
 395                                        (sb-sys:with-pinned-objects (c-string)
 396                                          (sb-alien::c-string-to-string
 397                                           (sb-sys:vector-sap c-string)
 398                                           :utf-8 'character)))))))
 399                   (let ((namestring "alien.impure.tmp"))
 400                     (unwind-protect
 401                          (progn
 402                            (with-open-file (f namestring
 403                                               :element-type '(unsigned-byte 8)
 404                                               :direction :output
 405                                               :if-exists :supersede)
 406                              (dolist (b '(70 195 1 182 195 182 0))
 407                                (write-byte b f)))
 408                            (with-open-file (f namestring
 409                                               :external-format :utf-8)
 410                              (read-line f)))
 411                       (delete-file namestring))))))))
 412
 413 ;;; success