Silence notes about being specialised EQ templates on x86oids
[sbcl.git] / 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)))))