src/code/target-alieneval.lisp

   1 ;;;; This file contains parts of the ALIEN implementation that
   2 ;;;; are not part of the compiler.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!ALIEN")
  14
  15 (/show0 "target-alieneval.lisp 15")
  16 \f
  17 ;;;; alien variables
  18
  19 ;;; Make a string out of the symbol, converting all uppercase letters to
  20 ;;; lower case and hyphens into underscores.
  21 (eval-when (:compile-toplevel :load-toplevel :execute)
  22   (defun guess-alien-name-from-lisp-name (lisp-name)
  23     (declare (type symbol lisp-name))
  24     (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name)))))
  25
  26 ;;; The opposite of GUESS-ALIEN-NAME-FROM-LISP-NAME. Make a symbol out
  27 ;;; of the string, converting all lowercase letters to uppercase and
  28 ;;; underscores into hyphens.
  29 (eval-when (:compile-toplevel :load-toplevel :execute)
  30   (defun guess-lisp-name-from-alien-name (alien-name)
  31     (declare (type simple-string alien-name))
  32     (intern (nsubstitute #\- #\_ (string-upcase alien-name)))))
  33
  34 ;;; Extract the Lisp and alien names from NAME. If only one is given,
  35 ;;; guess the other.
  36 (eval-when (:compile-toplevel :load-toplevel :execute)
  37   (defun pick-lisp-and-alien-names (name)
  38     (flet ((oops ()
  39              (error "~@<~:IMalformed alien name. Acceptable formats are:~
  40                      ~:@_  (\"alien_name\" LISP-NAME)~
  41                      ~:@_  FOO-BAR                - equivalent to (\"foo_bar\" FOO-BAR)~
  42                      ~:@_  \"foo_bar\"              - equivalent to (\"foo_bar\" FOO-BAR)~:@>")))
  43       (etypecase name
  44        (string
  45         (values (guess-lisp-name-from-alien-name name)
  46                 (coerce name 'simple-string)))
  47        (symbol
  48         (values name (guess-alien-name-from-lisp-name name)))
  49        (list
  50         (unless (and (proper-list-of-length-p name 2)
  51                      (symbolp (second name))
  52                      (stringp (first name)))
  53           (oops))
  54         (values (second name) (coerce (first name) 'simple-string)))
  55        (t
  56         (oops))))))
  57
  58 (defmacro define-alien-variable (name type &environment env)
  59   #!+sb-doc
  60   "Define NAME as an external alien variable of type TYPE. NAME should
  61 be a list of a string holding the alien name and a symbol to use as
  62 the Lisp name. If NAME is just a symbol or string, then the other name
  63 is guessed from the one supplied."
  64   (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name)
  65     (with-auxiliary-alien-types env
  66       (let ((alien-type (parse-alien-type type env)))
  67         `(eval-when (:compile-toplevel :load-toplevel :execute)
  68            ,@(when *new-auxiliary-types*
  69                `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
  70            (%define-alien-variable ',lisp-name
  71                                    ',alien-name
  72                                    ',alien-type))))))
  73
  74 ;;; Do the actual work of DEFINE-ALIEN-VARIABLE.
  75 (eval-when (:compile-toplevel :load-toplevel :execute)
  76   (defun %define-alien-variable (lisp-name alien-name type)
  77     (setf (info :variable :kind lisp-name) :alien)
  78     (setf (info :variable :where-from lisp-name) :defined)
  79     (setf (info :variable :alien-info lisp-name)
  80           (make-heap-alien-info :type type
  81                                 :alien-name alien-name
  82                                 :datap t))))
  83
  84 (defun alien-value (symbol)
  85   #!+sb-doc
  86   "Returns the value of the alien variable bound to SYMBOL. Signals an
  87 error if SYMBOL is not bound to an alien variable, or if the alien
  88 variable is undefined."
  89   (%heap-alien (or (info :variable :alien-info symbol)
  90                    (error 'unbound-variable :name symbol))))
  91
  92 (defmacro extern-alien (name type &environment env)
  93   #!+sb-doc
  94   "Access the alien variable named NAME, assuming it is of type TYPE.
  95 This is SETFable."
  96   (let* ((alien-name (etypecase name
  97                        (symbol (guess-alien-name-from-lisp-name name))
  98                        (string name)))
  99          (alien-type (parse-alien-type type env))
 100          (datap (not (alien-fun-type-p alien-type))))
 101     `(%alien-value (foreign-symbol-sap ,alien-name ,datap) 0 ',alien-type)))
 102
 103 (defmacro with-alien (bindings &body body &environment env)
 104   #!+sb-doc
 105   "Establish some local alien variables. Each BINDING is of the form:
 106      VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
 107    ALLOCATION should be one of:
 108      :LOCAL (the default)
 109        The alien is allocated on the stack, and has dynamic extent.
 110      :EXTERN
 111        No alien is allocated, but VAR is established as a local name for
 112        the external alien given by EXTERNAL-NAME."
 113   ;; FIXME:
 114   ;;      :STATIC
 115   ;;        The alien is allocated on the heap, and has infinite extent. The alien
 116   ;;        is allocated at load time, so the same piece of memory is used each time
 117   ;;        this form executes.
 118   (/show "entering WITH-ALIEN" bindings)
 119   (with-auxiliary-alien-types env
 120     (dolist (binding (reverse bindings))
 121       (/show binding)
 122       (destructuring-bind
 123             (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
 124           binding
 125         (/show symbol type opt1 opt2)
 126         (let* ((alien-type (parse-alien-type type env))
 127                (datap (not (alien-fun-type-p alien-type))))
 128           (/show alien-type)
 129           (multiple-value-bind (allocation initial-value)
 130               (if opt2p
 131                   (values opt1 opt2)
 132                   (case opt1
 133                     (:extern
 134                      (values opt1 (guess-alien-name-from-lisp-name symbol)))
 135                     (:static
 136                      (values opt1 nil))
 137                     (t
 138                      (values :local opt1))))
 139             (/show allocation initial-value)
 140             (setf body
 141                   (ecase allocation
 142                     #+nil
 143                     (:static
 144                      (let ((sap
 145                             (make-symbol (concatenate 'string "SAP-FOR-"
 146                                                       (symbol-name symbol)))))
 147                        `((let ((,sap (load-time-value (%make-alien ...))))
 148                            (declare (type system-area-pointer ,sap))
 149                            (symbol-macrolet
 150                                ((,symbol (sap-alien ,sap ,type)))
 151                              ,@(when initial-value
 152                                  `((setq ,symbol ,initial-value)))
 153                              ,@body)))))
 154                     (:extern
 155                      (/show0 ":EXTERN case")
 156                      `((symbol-macrolet
 157                            ((,symbol
 158                               (%alien-value
 159                                (foreign-symbol-sap ,initial-value ,datap) 0 ,alien-type)))
 160                          ,@body)))
 161                     (:local
 162                      (/show0 ":LOCAL case")
 163                      (let* ((var (sb!xc:gensym "VAR"))
 164                             (initval (if initial-value (sb!xc:gensym "INITVAL")))
 165                             (info (make-local-alien-info :type alien-type))
 166                             (inner-body
 167                              `((note-local-alien-type ',info ,var)
 168                                (symbol-macrolet ((,symbol (local-alien ',info ,var)))
 169                                  ,@(when initial-value
 170                                      `((setq ,symbol ,initval)))
 171                                  ,@body)))
 172                             (body-forms
 173                              (if initial-value
 174                                  `((let ((,initval ,initial-value))
 175                                      ,@inner-body))
 176                                  inner-body)))
 177                        (/show var initval info)
 178                        #!+(or x86 x86-64)
 179                        `((let ((,var (make-local-alien ',info)))
 180                            ,@body-forms))
 181                        ;; FIXME: This version is less efficient then it needs to be, since
 182                        ;; it could just save and restore the number-stack pointer once,
 183                        ;; instead of doing multiple decrements if there are multiple bindings.
 184                        #!-(or x86 x86-64)
 185                        `((let (,var)
 186                            (unwind-protect
 187                                (progn
 188                                  (setf ,var (make-local-alien ',info))
 189                                  (let ((,var ,var))
 190                                    ,@body-forms))
 191                              (dispose-local-alien ',info ,var))))))))))))
 192     (/show "revised" body)
 193     (verify-local-auxiliaries-okay)
 194     (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
 195     `(symbol-macrolet ((&auxiliary-type-definitions&
 196                         ,(append *new-auxiliary-types*
 197                                  (auxiliary-type-definitions env))))
 198        #!+(or x86 x86-64)
 199        (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*))
 200          ,@body)
 201        #!-(or x86 x86-64)
 202        ,@body)))
 203 \f
 204 ;;;; runtime C values that don't correspond directly to Lisp types
 205
 206 ;;; Note: The DEFSTRUCT for ALIEN-VALUE lives in a separate file
 207 ;;; 'cause it has to be real early in the cold-load order.
 208 #!-sb-fluid (declaim (freeze-type alien-value))
 209 (def!method print-object ((value alien-value) stream)
 210   (print-unreadable-object (value stream)
 211     (format stream
 212             "~S ~S #X~8,'0X ~S ~S"
 213             'alien-value
 214             :sap (sap-int (alien-value-sap value))
 215             :type (unparse-alien-type (alien-value-type value)))))
 216
 217 #!-sb-fluid (declaim (inline null-alien))
 218 (defun null-alien (x)
 219   #!+sb-doc
 220   "Return true if X (which must be an ALIEN pointer) is null, false otherwise."
 221   (zerop (sap-int (alien-sap x))))
 222
 223 (defmacro sap-alien (sap type &environment env)
 224   #!+sb-doc
 225   "Convert the system area pointer SAP to an ALIEN of the specified TYPE (not
 226    evaluated.) TYPE must be pointer-like."
 227   (let ((alien-type (parse-alien-type type env)))
 228     (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer)
 229         `(%sap-alien ,sap ',alien-type)
 230         (error "cannot make an alien of type ~S out of a SAP" type))))
 231
 232 (defun %sap-alien (sap type)
 233   (declare (type system-area-pointer sap)
 234            (type alien-type type))
 235   (make-alien-value :sap sap :type type))
 236
 237 (defun alien-sap (alien)
 238   #!+sb-doc
 239   "Return a System-Area-Pointer pointing to Alien's data."
 240   (declare (type alien-value alien))
 241   (alien-value-sap alien))
 242 \f
 243 ;;;; allocation/deallocation of heap aliens
 244
 245 (defmacro make-alien (type &optional size &environment env)
 246   #!+sb-doc
 247   "Allocate an alien of type TYPE in foreign heap, and return an alien
 248 pointer to it. The allocated memory is not initialized, and may
 249 contain garbage. The memory is allocated using malloc(3), so it can be
 250 passed to foreign functions which use free(3), or released using
 251 FREE-ALIEN.
 252
 253 For alien stack allocation, see macro WITH-ALIEN.
 254
 255 The TYPE argument is not evaluated. If SIZE is supplied, how it is
 256 interpreted depends on TYPE:
 257
 258   * When TYPE is a foreign array type, an array of that type is
 259     allocated, and a pointer to it is returned. Note that you
 260     must use DEREF to first access the arrey through the pointer.
 261
 262     If supplied, SIZE is used as the first dimension for the array.
 263
 264   * When TYPE is any other foreign type, then an object for that
 265     type is allocated, and a pointer to it is returned. So
 266     (make-alien int) returns a (* int).
 267
 268     If SIZE is specified, then a block of that many objects is
 269     allocated, with the result pointing to the first one.
 270
 271 Examples:
 272
 273   (defvar *foo* (make-alien (array char 10)))
 274   (type-of *foo*)                 ; => (alien (* (array (signed 8) 10)))
 275   (setf (deref (deref foo) 0) 10) ; => 10
 276
 277   (make-alien char 12)            ; => (alien (* (signed 8)))
 278 "
 279   (let ((alien-type (if (alien-type-p type)
 280                         type
 281                         (parse-alien-type type env))))
 282     (multiple-value-bind (size-expr element-type)
 283         (if (alien-array-type-p alien-type)
 284             (let ((dims (alien-array-type-dimensions alien-type)))
 285               (cond
 286                 (size
 287                  (unless dims
 288                    (error
 289                     "cannot override the size of zero-dimensional arrays"))
 290                  (when (constantp size)
 291                    (setf alien-type (copy-alien-array-type alien-type))
 292                    (setf (alien-array-type-dimensions alien-type)
 293                          (cons (constant-form-value size) (cdr dims)))))
 294                 (dims
 295                  (setf size (car dims)))
 296                 (t
 297                  (setf size 1)))
 298               (values `(* ,size ,@(cdr dims))
 299                       (alien-array-type-element-type alien-type)))
 300             (values (or size 1) alien-type))
 301       (let ((bits (alien-type-bits element-type))
 302             (alignment (alien-type-alignment element-type)))
 303         (unless bits
 304           (error "The size of ~S is unknown."
 305                  (unparse-alien-type element-type)))
 306         (unless alignment
 307           (error "The alignment of ~S is unknown."
 308                  (unparse-alien-type element-type)))
 309         ;; This is the one place where the %SAP-ALIEN note is quite
 310         ;; undesirable, in most uses of MAKE-ALIEN the %SAP-ALIEN
 311         ;; cannot be optimized away.
 312         `(locally (declare (muffle-conditions compiler-note))
 313            ;; FIXME: Do we really need the ASH/+7 here after ALIGN-OFFSET?
 314            (%sap-alien (%make-alien (* ,(ash (+ 7 (align-offset bits alignment)) -3)
 315                                        (the index ,size-expr)))
 316                        ',(make-alien-pointer-type :to alien-type)))))))
 317
 318 (defun malloc-error (bytes errno)
 319   (error 'simple-storage-condition
 320          :format-control "~A: malloc() of ~S bytes failed."
 321          :format-arguments (list (strerror errno) bytes)))
 322
 323 ;;; Allocate a block of memory at least BITS bits long and return a
 324 ;;; system area pointer to it.
 325 #!-sb-fluid (declaim (inline %make-alien))
 326 (defun %make-alien (bytes)
 327   (declare (type index bytes)
 328            (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
 329   (let ((sap (alien-funcall (extern-alien "malloc"
 330                                           (function system-area-pointer size-t))
 331                             bytes)))
 332     (if (and (not (eql 0 bytes)) (eql 0 (sap-int sap)))
 333         (malloc-error bytes (get-errno))
 334         sap)))
 335
 336 #!-sb-fluid (declaim (inline free-alien))
 337 (defun free-alien (alien)
 338   #!+sb-doc
 339   "Dispose of the storage pointed to by ALIEN. The ALIEN must have been
 340 allocated by MAKE-ALIEN, MAKE-ALIEN-STRING or malloc(3)."
 341   (alien-funcall (extern-alien "free" (function (values) system-area-pointer))
 342                  (alien-sap alien))
 343   nil)
 344
 345 (declaim (type (sfunction * system-area-pointer) %make-alien-string))
 346 (defun %make-alien-string (string &key (start 0) end
 347                                        (external-format :default)
 348                                        (null-terminate t))
 349   ;; FIXME: This is slow. We want a function to get the length of the
 350   ;; encoded string so we can allocate the foreign memory first and
 351   ;; encode directly there.
 352   (let* ((octets (string-to-octets string
 353                                    :start start :end end
 354                                    :external-format external-format
 355                                    :null-terminate null-terminate))
 356          (count (length octets))
 357          (buf (%make-alien count)))
 358     (sb!kernel:copy-ub8-to-system-area octets 0 buf 0 count)
 359     buf))
 360
 361 (defun make-alien-string (string &rest rest
 362                                  &key (start 0) end
 363                                       (external-format :default)
 364                                       (null-terminate t))
 365   "Copy part of STRING delimited by START and END into freshly
 366 allocated foreign memory, freeable using free(3) or FREE-ALIEN.
 367 Returns the allocated string as a (* CHAR) alien, and the number of
 368 bytes allocated as secondary value.
 369
 370 The string is encoded using EXTERNAL-FORMAT. If NULL-TERMINATE is
 371 true (the default), the alien string is terminated by an additional
 372 null byte.
 373 "
 374   (declare (ignore start end external-format null-terminate))
 375   (multiple-value-bind (sap bytes)
 376       (apply #'%make-alien-string string rest)
 377     (values (%sap-alien sap (parse-alien-type '(* char) nil))
 378             bytes)))
 379
 380 (define-compiler-macro make-alien-string (&rest args)
 381   `(multiple-value-bind (sap bytes) (%make-alien-string ,@args)
 382      (values (%sap-alien sap ',(parse-alien-type '(* char) nil))
 383              bytes)))
 384 \f
 385 ;;;; the SLOT operator
 386
 387 ;;; Find the field named SLOT, or die trying.
 388 (defun slot-or-lose (type slot)
 389   (declare (type alien-record-type type)
 390            (type symbol slot))
 391   (or (find slot (alien-record-type-fields type)
 392             :key #'alien-record-field-name)
 393       (error "There is no slot named ~S in ~S." slot type)))
 394
 395 ;;; Extract the value from the named slot from the record ALIEN. If
 396 ;;; ALIEN is actually a pointer, then DEREF it first.
 397 (defun slot (alien slot)
 398   #!+sb-doc
 399   "Extract SLOT from the Alien STRUCT or UNION ALIEN. May be set with SETF."
 400   (declare (type alien-value alien)
 401            (type symbol slot)
 402            (optimize (inhibit-warnings 3)))
 403   (let ((type (alien-value-type alien)))
 404     (etypecase type
 405       (alien-pointer-type
 406        (slot (deref alien) slot))
 407       (alien-record-type
 408        (let ((field (slot-or-lose type slot)))
 409          (%alien-value (alien-value-sap alien)
 410                        (alien-record-field-offset field)
 411                        (alien-record-field-type field)))))))
 412
 413 ;;; Deposit the value in the specified slot of the record ALIEN. If
 414 ;;; the ALIEN is really a pointer, DEREF it first. The compiler uses
 415 ;;; this when it can't figure out anything better.
 416 (defun %set-slot (alien slot value)
 417   (declare (type alien-value alien)
 418            (type symbol slot)
 419            (optimize (inhibit-warnings 3)))
 420   (let ((type (alien-value-type alien)))
 421     (etypecase type
 422       (alien-pointer-type
 423        (%set-slot (deref alien) slot value))
 424       (alien-record-type
 425        (let ((field (slot-or-lose type slot)))
 426          (setf (%alien-value (alien-value-sap alien)
 427                              (alien-record-field-offset field)
 428                              (alien-record-field-type field))
 429                value))))))
 430
 431 ;;; Compute the address of the specified slot and return a pointer to it.
 432 (defun %slot-addr (alien slot)
 433   (declare (type alien-value alien)
 434            (type symbol slot)
 435            (optimize (inhibit-warnings 3)))
 436   (let ((type (alien-value-type alien)))
 437     (etypecase type
 438       (alien-pointer-type
 439        (%slot-addr (deref alien) slot))
 440       (alien-record-type
 441        (let* ((field (slot-or-lose type slot))
 442               (offset (alien-record-field-offset field))
 443               (field-type (alien-record-field-type field)))
 444          (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:n-byte-bits))
 445                      (make-alien-pointer-type :to field-type)))))))
 446 \f
 447 ;;;; the DEREF operator
 448
 449 ;;; This function does most of the work of the different DEREF
 450 ;;; methods. It returns two values: the type and the offset (in bits)
 451 ;;; of the referred-to alien.
 452 (defun deref-guts (alien indices)
 453   (declare (type alien-value alien)
 454            (type list indices)
 455            (values alien-type integer))
 456   (let ((type (alien-value-type alien)))
 457     (etypecase type
 458       (alien-pointer-type
 459        (when (cdr indices)
 460          (error "too many indices when DEREF'ing ~S: ~W"
 461                 type
 462                 (length indices)))
 463        (let ((element-type (alien-pointer-type-to type)))
 464          (values element-type
 465                  (if indices
 466                      (* (align-offset (alien-type-bits element-type)
 467                                       (alien-type-alignment element-type))
 468                         (car indices))
 469                      0))))
 470       (alien-array-type
 471        (unless (= (length indices) (length (alien-array-type-dimensions type)))
 472          (error "incorrect number of indices when DEREF'ing ~S: ~W"
 473                 type (length indices)))
 474        (labels ((frob (dims indices offset)
 475                   (if (null dims)
 476                       offset
 477                       (frob (cdr dims) (cdr indices)
 478                         (+ (if (zerop offset)
 479                                0
 480                                (* offset (car dims)))
 481                            (car indices))))))
 482          (let ((element-type (alien-array-type-element-type type)))
 483            (values element-type
 484                    (* (align-offset (alien-type-bits element-type)
 485                                     (alien-type-alignment element-type))
 486                       (frob (alien-array-type-dimensions type)
 487                         indices 0)))))))))
 488
 489 ;;; Dereference the alien and return the results.
 490 (defun deref (alien &rest indices)
 491   #!+sb-doc
 492   "De-reference an Alien pointer or array. If an array, the indices are used
 493    as the indices of the array element to access. If a pointer, one index can
 494    optionally be specified, giving the equivalent of C pointer arithmetic."
 495   (declare (type alien-value alien)
 496            (type list indices)
 497            (optimize (inhibit-warnings 3)))
 498   (multiple-value-bind (target-type offset) (deref-guts alien indices)
 499     (%alien-value (alien-value-sap alien)
 500                   offset
 501                   target-type)))
 502
 503 (defun %set-deref (alien value &rest indices)
 504   (declare (type alien-value alien)
 505            (type list indices)
 506            (optimize (inhibit-warnings 3)))
 507   (multiple-value-bind (target-type offset) (deref-guts alien indices)
 508     (setf (%alien-value (alien-value-sap alien)
 509                         offset
 510                         target-type)
 511           value)))
 512
 513 (defun %deref-addr (alien &rest indices)
 514   (declare (type alien-value alien)
 515            (type list indices)
 516            (optimize (inhibit-warnings 3)))
 517   (multiple-value-bind (target-type offset) (deref-guts alien indices)
 518     (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:n-byte-bits))
 519                 (make-alien-pointer-type :to target-type))))
 520 \f
 521 ;;;; accessing heap alien variables
 522
 523 (defun %heap-alien (info)
 524   (declare (type heap-alien-info info)
 525            (optimize (inhibit-warnings 3)))
 526   (%alien-value (heap-alien-info-sap info)
 527                 0
 528                 (heap-alien-info-type info)))
 529
 530 (defun %set-heap-alien (info value)
 531   (declare (type heap-alien-info info)
 532            (optimize (inhibit-warnings 3)))
 533   (setf (%alien-value (heap-alien-info-sap info)
 534                       0
 535                       (heap-alien-info-type info))
 536         value))
 537
 538 (defun %heap-alien-addr (info)
 539   (declare (type heap-alien-info info)
 540            (optimize (inhibit-warnings 3)))
 541   (%sap-alien (heap-alien-info-sap info)
 542               (make-alien-pointer-type :to (heap-alien-info-type info))))
 543 \f
 544 ;;;; accessing local aliens
 545
 546 (defun make-local-alien (info)
 547   (let* ((alien (eval `(make-alien ,(local-alien-info-type info))))
 548          (alien-sap (alien-sap alien)))
 549     (finalize
 550      alien
 551      (lambda ()
 552        (alien-funcall
 553         (extern-alien "free" (function (values) system-area-pointer))
 554         alien-sap))
 555      :dont-save t)
 556     alien))
 557
 558 (defun note-local-alien-type (info alien)
 559   (declare (ignore info alien))
 560   nil)
 561
 562 (defun local-alien (info alien)
 563   (declare (ignore info))
 564   (deref alien))
 565
 566 (defun %set-local-alien (info alien value)
 567   (declare (ignore info))
 568   (setf (deref alien) value))
 569
 570 (define-setf-expander local-alien (&whole whole info alien)
 571   (let ((value (gensym))
 572         (info-var (gensym))
 573         (alloc-tmp (gensym))
 574         (info (if (and (consp info)
 575                        (eq (car info) 'quote))
 576                   (second info)
 577                   (error "Something is wrong; local-alien-info not found: ~S"
 578                          whole))))
 579     (values nil
 580             nil
 581             (list value)
 582             `(if (%local-alien-forced-to-memory-p ',info)
 583                  (%set-local-alien ',info ,alien ,value)
 584                    (let* ((,info-var ',(local-alien-info-type info))
 585                           (,alloc-tmp (deport-alloc ,value ,info-var)))
 586                      (maybe-with-pinned-objects (,alloc-tmp) (,(local-alien-info-type info))
 587                        (setf ,alien (deport ,alloc-tmp ,info-var)))))
 588             whole)))
 589
 590 (defun %local-alien-forced-to-memory-p (info)
 591   (local-alien-info-force-to-memory-p info))
 592
 593 (defun %local-alien-addr (info alien)
 594   (declare (type local-alien-info info))
 595   (unless (local-alien-info-force-to-memory-p info)
 596     (error "~S isn't forced to memory. Something went wrong." alien))
 597   alien)
 598
 599 (defun dispose-local-alien (info alien)
 600   (declare (ignore info))
 601   (cancel-finalization alien)
 602   (free-alien alien))
 603 \f
 604 ;;;; the CAST macro
 605
 606 (defmacro cast (alien type &environment env)
 607   #!+sb-doc
 608   "Convert ALIEN to an Alien of the specified TYPE (not evaluated.)  Both types
 609    must be Alien array, pointer or function types."
 610   `(%cast ,alien ',(parse-alien-type type env)))
 611
 612 (defun %cast (alien target-type)
 613   (declare (type alien-value alien)
 614            (type alien-type target-type)
 615            (optimize (safety 2))
 616            (optimize (inhibit-warnings 3)))
 617   (if (or (alien-pointer-type-p target-type)
 618           (alien-array-type-p target-type)
 619           (alien-fun-type-p target-type))
 620       (let ((alien-type (alien-value-type alien)))
 621         (if (or (alien-pointer-type-p alien-type)
 622                 (alien-array-type-p alien-type)
 623                 (alien-fun-type-p alien-type))
 624             (naturalize (alien-value-sap alien) target-type)
 625             (error "~S cannot be casted." alien)))
 626       (error "cannot cast to alien type ~S" (unparse-alien-type target-type))))
 627 \f
 628 ;;;; the ALIEN-SIZE macro
 629
 630 (defmacro alien-size (type &optional (units :bits) &environment env)
 631   #!+sb-doc
 632   "Return the size of the alien type TYPE. UNITS specifies the units to
 633    use and can be either :BITS, :BYTES, or :WORDS."
 634   (let* ((alien-type (parse-alien-type type env))
 635          (bits (alien-type-bits alien-type)))
 636     (if bits
 637         (values (ceiling bits
 638                          (ecase units
 639                            (:bits 1)
 640                            (:bytes sb!vm:n-byte-bits)
 641                            (:words sb!vm:n-word-bits))))
 642         (error "unknown size for alien type ~S"
 643                (unparse-alien-type alien-type)))))
 644 \f
 645 ;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE
 646
 647 (defun coerce-to-interpreted-function (lambda-form)
 648   (let (#!+sb-eval
 649         (*evaluator-mode* :interpret))
 650     (coerce lambda-form 'function)))
 651
 652 (defun naturalize (alien type)
 653   (declare (type alien-type type))
 654   (funcall (coerce-to-interpreted-function (compute-naturalize-lambda type))
 655            alien type))
 656
 657 (defun deport (value type)
 658   (declare (type alien-type type))
 659   (funcall (coerce-to-interpreted-function (compute-deport-lambda type))
 660            value type))
 661
 662 (defun deport-alloc (value type)
 663   (declare (type alien-type type))
 664   (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type))
 665            value type))
 666
 667 (defun %alien-value (sap offset type)
 668   (declare (type system-area-pointer sap)
 669            (type unsigned-byte offset)
 670            (type alien-type type))
 671   (funcall (coerce-to-interpreted-function (compute-extract-lambda type))
 672            sap offset type))
 673
 674 (defun (setf %alien-value) (value sap offset type)
 675   (declare (type system-area-pointer sap)
 676            (type unsigned-byte offset)
 677            (type alien-type type))
 678   (funcall (coerce-to-interpreted-function (compute-deposit-lambda type))
 679            value sap offset type))
 680 \f
 681 ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
 682
 683 (defun alien-funcall (alien &rest args)
 684   #!+sb-doc
 685   "Call the foreign function ALIEN with the specified arguments. ALIEN's
 686    type specifies the argument and result types."
 687   (declare (type alien-value alien))
 688   (let ((type (alien-value-type alien)))
 689     (typecase type
 690       (alien-pointer-type
 691        (apply #'alien-funcall (deref alien) args))
 692       (alien-fun-type
 693        (unless (= (length (alien-fun-type-arg-types type))
 694                   (length args))
 695          (error "wrong number of arguments for ~S~%expected ~W, got ~W"
 696                 type
 697                 (length (alien-fun-type-arg-types type))
 698                 (length args)))
 699        (let ((stub (alien-fun-type-stub type)))
 700          (unless stub
 701            (setf stub
 702                  (let ((fun (sb!xc:gensym "FUN"))
 703                        (parms (make-gensym-list (length args))))
 704                    (compile nil
 705                             `(lambda (,fun ,@parms)
 706                                (declare (optimize (sb!c::insert-step-conditions 0)))
 707                                (declare (type (alien ,type) ,fun))
 708                                (alien-funcall ,fun ,@parms)))))
 709            (setf (alien-fun-type-stub type) stub))
 710          (apply stub alien args)))
 711       (t
 712        (error "~S is not an alien function." alien)))))
 713
 714 (defmacro define-alien-routine (name result-type
 715                                      &rest args
 716                                      &environment lexenv)
 717   #!+sb-doc
 718   "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}*
 719
 720   Define a foreign interface function for the routine with the specified NAME.
 721   Also automatically DECLAIM the FTYPE of the defined function.
 722
 723   NAME may be either a string, a symbol, or a list of the form (string symbol).
 724
 725   RETURN-TYPE is the alien type for the function return value. VOID may be
 726   used to specify a function with no result.
 727
 728   The remaining forms specify individual arguments that are passed to the
 729   routine. ARG-NAME is a symbol that names the argument, primarily for
 730   documentation. ARG-TYPE is the C type of the argument. STYLE specifies the
 731   way that the argument is passed.
 732
 733   :IN
 734         An :IN argument is simply passed by value. The value to be passed is
 735         obtained from argument(s) to the interface function. No values are
 736         returned for :In arguments. This is the default mode.
 737
 738   :OUT
 739         The specified argument type must be a pointer to a fixed sized object.
 740         A pointer to a preallocated object is passed to the routine, and the
 741         the object is accessed on return, with the value being returned from
 742         the interface function. :OUT and :IN-OUT cannot be used with pointers
 743         to arrays, records or functions.
 744
 745   :COPY
 746         This is similar to :IN, except that the argument values are stored
 747         on the stack, and a pointer to the object is passed instead of
 748         the value itself.
 749
 750   :IN-OUT
 751         This is a combination of :OUT and :COPY. A pointer to the argument is
 752         passed, with the object being initialized from the supplied argument
 753         and the return value being determined by accessing the object on
 754         return."
 755   (multiple-value-bind (lisp-name alien-name)
 756       (pick-lisp-and-alien-names name)
 757     (collect ((docs) (lisp-args) (lisp-arg-types)
 758               (lisp-result-types
 759                (cond ((eql result-type 'void)
 760                       ;; What values does a function return, if it
 761                       ;; returns no values? Exactly one - NIL. -- APD,
 762                       ;; 2003-03-02
 763                       (list 'null))
 764                      (t
 765                       ;; FIXME: Check for VALUES.
 766                       (list `(alien ,result-type)))))
 767               (arg-types) (alien-vars)
 768               (alien-args) (results))
 769       (dolist (arg args)
 770         (if (stringp arg)
 771             (docs arg)
 772             (destructuring-bind (name type &optional (style :in)) arg
 773               (unless (member style '(:in :copy :out :in-out))
 774                 (error "bogus argument style ~S in ~S" style arg))
 775               (when (and (member style '(:out :in-out))
 776                          (typep (parse-alien-type type lexenv)
 777                                 'alien-pointer-type))
 778                 (error "can't use :OUT or :IN-OUT on pointer-like type:~%  ~S"
 779                        type))
 780               (let (arg-type)
 781                 (cond ((eq style :in)
 782                        (setq arg-type type)
 783                        (alien-args name))
 784                       (t
 785                        (setq arg-type `(* ,type))
 786                        (if (eq style :out)
 787                            (alien-vars `(,name ,type))
 788                            (alien-vars `(,name ,type ,name)))
 789                        (alien-args `(addr ,name))))
 790                 (arg-types arg-type)
 791                 (unless (eq style :out)
 792                   (lisp-args name)
 793                   (lisp-arg-types t
 794                                   ;; FIXME: It should be something
 795                                   ;; like `(ALIEN ,ARG-TYPE), except
 796                                   ;; for we also accept SAPs where
 797                                   ;; pointers are required.
 798                                   )))
 799               (when (or (eq style :out) (eq style :in-out))
 800                 (results name)
 801                 (lisp-result-types `(alien ,type))))))
 802       `(progn
 803          ;; The theory behind this automatic DECLAIM is that (1) if
 804          ;; you're calling C, static typing is what you're doing
 805          ;; anyway, and (2) such a declamation can be (especially for
 806          ;; alien values) both messy to do by hand and very important
 807          ;; for performance of later code which uses the return value.
 808          (declaim (ftype (function ,(lisp-arg-types)
 809                                    (values ,@(lisp-result-types) &optional))
 810                          ,lisp-name))
 811          (defun ,lisp-name ,(lisp-args)
 812            ,@(docs)
 813            (with-alien
 814             ((,lisp-name (function ,result-type ,@(arg-types))
 815                          :extern ,alien-name)
 816              ,@(alien-vars))
 817              ,@(if (eq 'void result-type)
 818                    `((alien-funcall ,lisp-name ,@(alien-args))
 819                      (values nil ,@(results)))
 820                    `((values (alien-funcall ,lisp-name ,@(alien-args))
 821                              ,@(results))))))))))
 822 \f
 823 (defun alien-typep (object type)
 824   #!+sb-doc
 825   "Return T iff OBJECT is an alien of type TYPE."
 826   (let ((lisp-rep-type (compute-lisp-rep-type type)))
 827     (if lisp-rep-type
 828         (typep object lisp-rep-type)
 829         (and (alien-value-p object)
 830              (alien-subtype-p (alien-value-type object) type)))))
 831
 832 (defun alien-value-typep (object type)
 833   (when (alien-value-p object)
 834     (alien-subtype-p (alien-value-type object) type)))
 835
 836 ;;;; ALIEN CALLBACKS
 837 ;;;;
 838 ;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual.
 839
 840 (defvar *alien-callback-info* nil
 841   "Maps SAPs to corresponding CALLBACK-INFO structures: contains all the
 842 information we need to manipulate callbacks after their creation. Used for
 843 changing the lisp-side function they point to, invalidation, etc.")
 844
 845 (defstruct callback-info
 846   specifier
 847   function ; NULL if invalid
 848   wrapper
 849   index)
 850
 851 (defun callback-info-key (info)
 852   (cons (callback-info-specifier info) (callback-info-function info)))
 853
 854 (defun alien-callback-info (alien)
 855   (cdr (assoc (alien-sap alien) *alien-callback-info* :test #'sap=)))
 856
 857 (defvar *alien-callbacks* (make-hash-table :test #'equal)
 858   "Cache of existing callback SAPs, indexed with (SPECIFER . FUNCTION). Used for
 859 memoization: we don't create new callbacks if one pointing to the correct
 860 function with the same specifier already exists.")
 861
 862 (defvar *alien-callback-wrappers* (make-hash-table :test #'equal)
 863   "Cache of existing lisp weappers, indexed with SPECIFER. Used for memoization:
 864 we don't create new wrappers if one for the same specifier already exists.")
 865
 866 (defvar *alien-callback-trampolines* (make-array 32 :fill-pointer 0 :adjustable t)
 867   "Lisp trampoline store: assembler wrappers contain indexes to this, and
 868 ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
 869
 870 (defun %alien-callback-sap (specifier result-type argument-types function wrapper
 871                             &optional call-type)
 872   (declare #!-x86 (ignore call-type))
 873   (let ((key (list specifier function)))
 874     (or (gethash key *alien-callbacks*)
 875         (setf (gethash key *alien-callbacks*)
 876               (let* ((index (fill-pointer *alien-callback-trampolines*))
 877                      ;; Aside from the INDEX this is known at
 878                      ;; compile-time, which could be utilized by
 879                      ;; having the two-stage assembler tramp &
 880                      ;; wrapper mentioned in [1] above: only the
 881                      ;; per-function tramp would need assembler at
 882                      ;; runtime. Possibly we could even pregenerate
 883                      ;; the code and just patch the index in later.
 884                      (assembler-wrapper
 885                       (alien-callback-assembler-wrapper
 886                        index result-type argument-types
 887                        #!+x86
 888                        (if (eq call-type :stdcall)
 889                            (ceiling
 890                             (apply #'+
 891                                    (mapcar 'alien-type-word-aligned-bits
 892                                            argument-types))
 893                             8)
 894                            0))))
 895                 (vector-push-extend
 896                  (alien-callback-lisp-trampoline wrapper function)
 897                  *alien-callback-trampolines*)
 898                 ;; Assembler-wrapper is static, so sap-taking is safe.
 899                 (let ((sap (vector-sap assembler-wrapper)))
 900                   (push (cons sap (make-callback-info :specifier specifier
 901                                                       :function function
 902                                                       :wrapper wrapper
 903                                                       :index index))
 904                         *alien-callback-info*)
 905                   sap))))))
 906
 907 (defun alien-callback-lisp-trampoline (wrapper function)
 908   (declare (function wrapper) (optimize speed))
 909   (lambda (args-pointer result-pointer)
 910     (funcall wrapper args-pointer result-pointer function)))
 911
 912 (defun alien-callback-lisp-wrapper-lambda (specifier result-type argument-types env)
 913   (let* ((arguments (make-gensym-list (length argument-types)))
 914          (argument-names arguments)
 915          (argument-specs (cddr specifier)))
 916     `(lambda (args-pointer result-pointer function)
 917        ;; FIXME: the saps are not gc safe
 918        (let ((args-sap (int-sap
 919                         (sb!kernel:get-lisp-obj-address args-pointer)))
 920              (res-sap (int-sap
 921                        (sb!kernel:get-lisp-obj-address result-pointer))))
 922          (declare (ignorable args-sap res-sap))
 923          (with-alien
 924              ,(loop
 925                  with offset = 0
 926                  for spec in argument-specs
 927                  collect `(,(pop argument-names) ,spec
 928                             :local ,(alien-callback-accessor-form
 929                                      spec 'args-sap offset))
 930                  do (incf offset (alien-callback-argument-bytes spec env)))
 931            ,(flet ((store (spec real-type)
 932                           (if spec
 933                               `(setf (deref (sap-alien res-sap (* ,spec)))
 934                                      ,(if real-type
 935                                           `(the ,real-type
 936                                              (funcall function ,@arguments))
 937                                           `(funcall function ,@arguments)))
 938                               `(funcall function ,@arguments))))
 939                   (cond ((alien-void-type-p result-type)
 940                          (store nil nil))
 941                         ((alien-integer-type-p result-type)
 942                          ;; Integer types should be padded out to a full
 943                          ;; register width, to comply with most ABI calling
 944                          ;; conventions, but should be typechecked on the
 945                          ;; declared type width, hence the following:
 946                          (if (alien-integer-type-signed result-type)
 947                              (store `(signed
 948                                       ,(alien-type-word-aligned-bits result-type))
 949                                     `(signed-byte ,(alien-type-bits result-type)))
 950                              (store
 951                               `(unsigned
 952                                 ,(alien-type-word-aligned-bits result-type))
 953                               `(unsigned-byte ,(alien-type-bits result-type)))))
 954                         (t
 955                          (store (unparse-alien-type result-type) nil))))))
 956        (values))))
 957
 958 (defun invalid-alien-callback (&rest arguments)
 959   (declare (ignore arguments))
 960   (error "Invalid alien callback called."))
 961
 962
 963 (defun parse-callback-specification (result-type lambda-list)
 964   (values
 965    `(function ,result-type ,@(mapcar #'second lambda-list))
 966    (mapcar #'first lambda-list)))
 967
 968
 969 (defun parse-alien-ftype (specifier env)
 970   (destructuring-bind (function result-type &rest argument-types)
 971       specifier
 972     (aver (eq 'function function))
 973     (multiple-value-bind (bare-result-type calling-convention)
 974         (typecase result-type
 975           ((cons calling-convention *)
 976              (values (second result-type) (first result-type)))
 977           (t result-type))
 978       (values (let ((*values-type-okay* t))
 979                 (parse-alien-type bare-result-type env))
 980               (mapcar (lambda (spec)
 981                         (parse-alien-type spec env))
 982                       argument-types)
 983               calling-convention))))
 984
 985 (defun alien-void-type-p (type)
 986   (and (alien-values-type-p type) (not (alien-values-type-values type))))
 987
 988 (defun alien-type-word-aligned-bits (type)
 989   (align-offset (alien-type-bits type) sb!vm:n-word-bits))
 990
 991 (defun alien-callback-argument-bytes (spec env)
 992   (let ((type (parse-alien-type spec env)))
 993     (if (or (alien-integer-type-p type)
 994             (alien-float-type-p type)
 995             (alien-pointer-type-p type)
 996             (alien-system-area-pointer-type-p type))
 997         (ceiling (alien-type-word-aligned-bits type) sb!vm:n-byte-bits)
 998         (error "Unsupported callback argument type: ~A" type))))
 999
1000 (defun enter-alien-callback (index return arguments)
1001   (funcall (aref *alien-callback-trampolines* index)
1002            return
1003            arguments))
1004
1005 ;;; To ensure that callback wrapper functions continue working even
1006 ;;; if #'ENTER-ALIEN-CALLBACK moves in memory, access to it is indirected
1007 ;;; through the *ENTER-ALIEN-CALLBACK* static symbol. -- JES, 2006-01-01
1008 (defvar *enter-alien-callback* #'enter-alien-callback)
1009
1010 ;;;; interface (not public, yet) for alien callbacks
1011
1012 (defmacro alien-callback (specifier function &environment env)
1013   "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to
1014 an alien function as a pointer to the FUNCTION. If a callback for the given
1015 SPECIFIER and FUNCTION already exists, it is returned instead of consing a new
1016 one."
1017   ;; Pull out as much work as is convenient to macro-expansion time, specifically
1018   ;; everything that can be done given just the SPECIFIER and ENV.
1019   (multiple-value-bind (result-type argument-types call-type)
1020       (parse-alien-ftype specifier env)
1021     `(%sap-alien
1022       (%alien-callback-sap ',specifier ',result-type ',argument-types
1023                            ,function
1024                            (or (gethash ',specifier *alien-callback-wrappers*)
1025                                (setf (gethash ',specifier *alien-callback-wrappers*)
1026                                      (compile nil
1027                                               ',(alien-callback-lisp-wrapper-lambda
1028                                                  specifier result-type argument-types env))))
1029                            ,call-type)
1030       ',(parse-alien-type specifier env))))
1031
1032 (defun alien-callback-p (alien)
1033   "Returns true if the alien is associated with a lisp-side callback,
1034 and a secondary return value of true if the callback is still valid."
1035   (let ((info (alien-callback-info alien)))
1036     (when info
1037       (values t (and (callback-info-function info) t)))))
1038
1039 (defun alien-callback-function (alien)
1040   "Returns the lisp function designator associated with the callback."
1041   (let ((info (alien-callback-info alien)))
1042     (when info
1043       (callback-info-function info))))
1044
1045 (defun (setf alien-callback-function) (function alien)
1046   "Changes the lisp function designated by the callback."
1047   (let ((info (alien-callback-info alien)))
1048     (unless info
1049       (error "Not an alien callback: ~S" alien))
1050     ;; sap cache
1051     (let ((key (callback-info-key info)))
1052       (remhash key *alien-callbacks*)
1053       (setf (gethash key *alien-callbacks*) (alien-sap alien)))
1054     ;; trampoline
1055     (setf (aref *alien-callback-trampolines* (callback-info-index info))
1056           (alien-callback-lisp-trampoline (callback-info-wrapper info) function))
1057     ;; metadata
1058     (setf (callback-info-function info) function)
1059     function))
1060
1061 (defun invalidate-alien-callback (alien)
1062   "Invalidates the callback designated by the alien, if any, allowing the
1063 associated lisp function to be GC'd, and causing further calls to the same
1064 callback signal an error."
1065   (let ((info (alien-callback-info alien)))
1066     (when (and info (callback-info-function info))
1067       ;; sap cache
1068       (remhash (callback-info-key info) *alien-callbacks*)
1069       ;; trampoline
1070       (setf (aref *alien-callback-trampolines* (callback-info-index info))
1071             #'invalid-alien-callback)
1072       ;; metadata
1073       (setf (callback-info-function info) nil)
1074       t)))
1075
1076 ;;; FIXME: This call assembles a new callback for every closure,
1077 ;;; which sucks hugely. ...not that I can think of an obvious
1078 ;;; solution. Possibly maybe we could write a generalized closure
1079 ;;; callback analogous to closure_tramp, and share the actual wrapper?
1080 ;;;
1081 ;;; For lambdas that result in simple-funs we get the callback from
1082 ;;; the cache on subsequent calls.
1083 (defmacro alien-lambda (result-type typed-lambda-list &body forms)
1084   (multiple-value-bind (specifier lambda-list)
1085       (parse-callback-specification result-type typed-lambda-list)
1086     `(alien-callback ,specifier (lambda ,lambda-list ,@forms))))
1087
1088 ;;; FIXME: Should subsequent (SETF FDEFINITION) affect the callback or not?
1089 ;;; What about subsequent DEFINE-ALIEN-CALLBACKs? My guess is that changing
1090 ;;; the FDEFINITION should invalidate the callback, and redefining the
1091 ;;; callback should change existing callbacks to point to the new defintion.
1092 (defmacro define-alien-callback (name result-type typed-lambda-list &body forms)
1093   "Defines #'NAME as a function with the given body and lambda-list, and NAME as
1094 the alien callback for that function with the given alien type."
1095   (declare (symbol name))
1096   (multiple-value-bind (specifier lambda-list)
1097       (parse-callback-specification result-type typed-lambda-list)
1098     `(progn
1099        (defun ,name ,lambda-list ,@forms)
1100        (defparameter ,name (alien-callback ,specifier #',name)))))