1 ;;;; the part of the Alien implementation which is needed at
2 ;;;; cross-compilation time
4 ;;;; This software is part of the SBCL system. See the README file for
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.
13 (in-package "SB!ALIEN")
15 (/show0
"host-alieneval.lisp 15")
17 ;;;; utility functions
19 (defun align-offset (offset alignment
)
20 (let ((extra (rem offset alignment
)))
21 (if (zerop extra
) offset
(+ offset
(- alignment extra
)))))
23 (defun guess-alignment (bits)
24 (cond ((null bits
) nil
)
25 #!-
(or (and x86
(not win32
)) (and ppc darwin
)) ((> bits
32) 64)
31 ;;;; ALIEN-TYPE-INFO stuff
33 ;;; We define a keyword "BOA" constructor so that we can reference the
34 ;;; slot names in init forms.
35 (defmacro define-alien-type-class
((name &key include include-args
) &rest slots
)
36 (let ((defstruct-name (symbolicate "ALIEN-" name
"-TYPE")))
37 (multiple-value-bind (include include-defstruct overrides
)
40 (values nil
'alien-type nil
))
44 (alien-type-class-defstruct-name
45 (alien-type-class-or-lose include
))
50 (alien-type-class-defstruct-name
51 (alien-type-class-or-lose (car include
)))
54 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
55 (create-alien-type-class-if-necessary ',name
',defstruct-name
56 ',(or include
'root
)))
57 (def!struct
(,defstruct-name
58 (:include
,include-defstruct
62 ,(symbolicate "MAKE-" defstruct-name
)
63 (&key class bits alignment
65 (if (atom x
) x
(car x
)))
69 &aux
(alignment (or alignment
(guess-alignment bits
))))))
72 (defmacro define-alien-type-method
((class method
) lambda-list
&rest body
)
73 (let ((defun-name (symbolicate class
"-" method
"-METHOD")))
75 (defun ,defun-name
,lambda-list
77 (setf (,(method-slot method
) (alien-type-class-or-lose ',class
))
80 ;;;; type parsing and unparsing
82 ;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and
83 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
84 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
86 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
87 (defun auxiliary-type-definitions (env)
88 (multiple-value-bind (result expanded-p
)
89 (%macroexpand
'&auxiliary-type-definitions
& env
)
92 ;; This is like having the global symbol-macro definition be
93 ;; NIL, but global symbol-macros make me vaguely queasy, so
94 ;; I do it this way instead.
97 ;;; Parse TYPE as an alien type specifier and return the resultant
98 ;;; ALIEN-TYPE structure.
99 (defun parse-alien-type (type env
)
100 (declare (type sb
!kernel
:lexenv-designator env
))
102 (let ((translator (info :alien-type
:translator
(car type
))))
104 (error "unknown alien type: ~S" type
))
105 (funcall translator type env
))
106 (ecase (info :alien-type
:kind type
)
108 (let ((translator (info :alien-type
:translator type
)))
110 (error "no translator for primitive alien type ~S" type
))
111 (funcall translator
(list type
) env
)))
113 (or (info :alien-type
:definition type
)
114 (error "no definition for alien type ~S" type
)))
116 (error "unknown alien type: ~S" type
)))))
118 (defun auxiliary-alien-type (kind name env
)
119 (declare (type sb
!kernel
:lexenv-designator env
))
120 (flet ((aux-defn-matches (x)
121 (and (eq (first x
) kind
) (eq (second x
) name
))))
122 (let ((in-auxiliaries
123 (or (find-if #'aux-defn-matches
*new-auxiliary-types
*)
124 (find-if #'aux-defn-matches
(auxiliary-type-definitions env
)))))
126 (values (third in-auxiliaries
) t
)
127 (info :alien-type kind name
)))))
129 (defun (setf auxiliary-alien-type
) (new-value kind name env
)
130 (declare (type sb
!kernel
:lexenv-designator env
))
131 (flet ((aux-defn-matches (x)
132 (and (eq (first x
) kind
) (eq (second x
) name
))))
133 (when (find-if #'aux-defn-matches
*new-auxiliary-types
*)
134 (error "attempt to multiply define ~A ~S" kind name
))
135 (when (find-if #'aux-defn-matches
(auxiliary-type-definitions env
))
136 (error "attempt to shadow definition of ~A ~S" kind name
)))
137 (push (list kind name new-value
) *new-auxiliary-types
*)
140 (defun verify-local-auxiliaries-okay ()
141 (dolist (info *new-auxiliary-types
*)
142 (destructuring-bind (kind name defn
) info
143 (declare (ignore defn
))
144 (when (info :alien-type kind name
)
145 (error "attempt to shadow definition of ~A ~S" kind name
)))))
147 (defun unparse-alien-type (type)
149 "Convert the alien-type structure TYPE back into a list specification of
151 (declare (type alien-type type
))
152 (let ((*record-types-already-unparsed
* nil
))
153 (%unparse-alien-type type
)))
155 ;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we
156 ;;; need to recurse inside the binding of
157 ;;; *RECORD-TYPES-ALREADY-UNPARSED*.
158 (defun %unparse-alien-type
(type)
159 (invoke-alien-type-method :unparse type
))
161 ;;;; alien type defining stuff
163 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
164 (defun %define-alien-type-translator
(name translator
)
165 (setf (info :alien-type
:kind name
) :primitive
)
166 (setf (info :alien-type
:translator name
) translator
)
167 (clear-info :alien-type
:definition name
)
170 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
171 (defun %def-auxiliary-alien-types
(types source-location
)
173 ;; Clear up the type we're about to define from the toplevel
174 ;; *new-auxiliary-types* (local scopes take care of themselves).
175 ;; Unless this is done we never actually get back the full type
176 ;; from INFO, since the *new-auxiliary-types* have precendence.
177 (setf *new-auxiliary-types
*
178 (remove info
*new-auxiliary-types
*
180 (and (eq (first a
) (first b
))
181 (eq (second a
) (second b
))))))
182 (destructuring-bind (kind name defn
) info
183 (let ((old (info :alien-type kind name
)))
184 (unless (or (null old
) (alien-type-= old defn
))
185 (warn "redefining ~A ~S to be:~% ~S,~%was:~% ~S"
186 kind name defn old
)))
187 (setf (info :alien-type kind name
) defn
188 (info :source-location
:alien-type name
) source-location
))))
190 (defun %define-alien-type
(name new
)
191 (ecase (info :alien-type
:kind name
)
193 (error "~S is a built-in alien type." name
))
195 (let ((old (info :alien-type
:definition name
)))
196 (unless (or (null old
) (alien-type-= new old
))
197 (warn "redefining ~S to be:~% ~S,~%was~% ~S"
199 (unparse-alien-type new
)
200 (unparse-alien-type old
)))))
202 (setf (info :alien-type
:definition name
) new
)
203 (setf (info :alien-type
:kind name
) :defined
)
206 ;;;; the root alien type
208 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
209 (create-alien-type-class-if-necessary 'root
'alien-type nil
))
211 (def!method print-object
((type alien-type
) stream
)
212 (print-unreadable-object (type stream
:type t
)
213 ;; Kludge to avoid printing #'(SIGNED 64) instead of (FUNCTION (SIGNED 64))
214 ;; for a 0-argument function. This is only a problem with alien types
215 ;; because ordinary FUNCTION type specifiers are 3-lists.
216 (let ((sb!pretty
:*pprint-quote-with-syntactic-sugar
* nil
))
217 ;; forward-reference of this special variable unfortunately
218 (declare (special sb
!pretty
:*pprint-quote-with-syntactic-sugar
*))
219 (prin1 (unparse-alien-type type
) stream
))))
223 (define-alien-type-class (system-area-pointer))
225 (define-alien-type-translator system-area-pointer
()
226 (make-alien-system-area-pointer-type
227 :bits sb
!vm
:n-machine-word-bits
))
229 (define-alien-type-method (system-area-pointer :unparse
) (type)
230 (declare (ignore type
))
231 'system-area-pointer
)
233 (define-alien-type-method (system-area-pointer :lisp-rep
) (type)
234 (declare (ignore type
))
235 'system-area-pointer
)
237 (define-alien-type-method (system-area-pointer :alien-rep
) (type context
)
238 (declare (ignore type context
))
239 'system-area-pointer
)
241 (define-alien-type-method (system-area-pointer :naturalize-gen
) (type alien
)
242 (declare (ignore type
))
245 (define-alien-type-method (system-area-pointer :deport-gen
) (type object
)
246 (declare (ignore type
))
247 (/noshow
"doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object
)
250 (define-alien-type-method (system-area-pointer :extract-gen
) (type sap offset
)
251 (declare (ignore type
))
252 `(sap-ref-sap ,sap
(/ ,offset sb
!vm
:n-byte-bits
)))
254 ;;;; the ALIEN-VALUE type
256 (define-alien-type-class (alien-value :include system-area-pointer
))
258 (define-alien-type-method (alien-value :lisp-rep
) (type)
259 (declare (ignore type
))
262 (define-alien-type-method (alien-value :naturalize-gen
) (type alien
)
263 `(%sap-alien
,alien
',type
))
265 (define-alien-type-method (alien-value :deport-gen
) (type value
)
266 (declare (ignore type
))
267 (/noshow
"doing alien type method ALIEN-VALUE :DEPORT-GEN" value
)
270 ;;; HEAP-ALIEN-INFO -- defstruct.
272 (def!method print-object
((info heap-alien-info
) stream
)
273 (print-unreadable-object (info stream
:type t
)
274 (funcall (formatter "~S ~S~@[ (data)~]")
276 (heap-alien-info-alien-name info
)
277 (unparse-alien-type (heap-alien-info-type info
))
278 (heap-alien-info-datap info
))))
280 ;;; The form to evaluate to produce the SAP pointing to where in the heap
282 (defun heap-alien-info-sap-form (info)
283 `(foreign-symbol-sap ,(heap-alien-info-alien-name info
)
284 ,(heap-alien-info-datap info
)))
286 #-sb-xc-host
; No FOREIGN-SYMBOL-SAP
287 (defun heap-alien-info-sap (info)
288 (foreign-symbol-sap (heap-alien-info-alien-name info
)
289 (heap-alien-info-datap info
)))
291 ;;;; Interfaces to the different methods
293 (defun alien-type-= (type1 type2
)
295 "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
297 (and (eq (alien-type-class type1
)
298 (alien-type-class type2
))
299 (invoke-alien-type-method :type
= type1 type2
))))
301 (defun alien-subtype-p (type1 type2
)
303 "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the
304 only supported subtype relationships are is that any pointer type is a
305 subtype of (* t), and any array type first dimension will match
306 (array <eltype> nil ...). Otherwise, the two types have to be
309 (invoke-alien-type-method :subtypep type1 type2
)))
311 (defun compute-naturalize-lambda (type)
312 `(lambda (alien ignore
)
313 (declare (ignore ignore
))
314 ,(invoke-alien-type-method :naturalize-gen type
'alien
)))
316 (defun compute-deport-lambda (type)
317 (declare (type alien-type type
))
318 (/noshow
"entering COMPUTE-DEPORT-LAMBDA" type
)
319 (multiple-value-bind (form value-type
)
320 (invoke-alien-type-method :deport-gen type
'value
)
321 `(lambda (value ignore
)
322 (declare (type ,(or value-type
323 (compute-lisp-rep-type type
)
329 (defun compute-deport-alloc-lambda (type)
330 `(lambda (value ignore
)
331 (declare (ignore ignore
))
332 ,(invoke-alien-type-method :deport-alloc-gen type
'value
)))
334 (defun compute-extract-lambda (type)
335 `(lambda (sap offset ignore
)
336 (declare (type system-area-pointer sap
)
337 (type unsigned-byte offset
)
339 (naturalize ,(invoke-alien-type-method :extract-gen type
'sap
'offset
)
342 (defun compute-deposit-lambda (type)
343 (declare (type alien-type type
))
344 `(lambda (value sap offset ignore
)
345 (declare (type system-area-pointer sap
)
346 (type unsigned-byte offset
)
348 (let ((alloc-tmp (deport-alloc value
',type
)))
349 (maybe-with-pinned-objects (alloc-tmp) (,type
)
350 (let ((value (deport alloc-tmp
',type
)))
351 ,(invoke-alien-type-method :deposit-gen type
'sap
'offset
'value
)
352 ;; Note: the reason we don't just return the pre-deported value
353 ;; is because that would inhibit any (deport (naturalize ...))
354 ;; optimizations that might have otherwise happen. Re-naturalizing
355 ;; the value might cause extra consing, but is flushable, so probably
356 ;; results in better code.
357 (naturalize value
',type
))))))
359 (defun compute-lisp-rep-type (type)
360 (invoke-alien-type-method :lisp-rep type
))
362 ;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function
363 ;;; return values). See the :ALIEN-REP method for INTEGER for
365 (defun compute-alien-rep-type (type &optional
(context :normal
))
366 (invoke-alien-type-method :alien-rep type context
))
370 (define-alien-type-method (root :unparse
) (type)
371 `(<unknown-alien-type
> ,(type-of type
)))
373 (define-alien-type-method (root :type
=) (type1 type2
)
374 (declare (ignore type1 type2
))
377 (define-alien-type-method (root :subtypep
) (type1 type2
)
378 (alien-type-= type1 type2
))
380 (define-alien-type-method (root :lisp-rep
) (type)
381 (declare (ignore type
))
384 (define-alien-type-method (root :alien-rep
) (type context
)
385 (declare (ignore type context
))
388 (define-alien-type-method (root :naturalize-gen
) (type alien
)
389 (declare (ignore alien
))
390 (error "cannot represent ~S typed aliens" type
))
392 (define-alien-type-method (root :deport-gen
) (type object
)
393 (declare (ignore object
))
394 (error "cannot represent ~S typed aliens" type
))
396 (define-alien-type-method (root :deport-alloc-gen
) (type object
)
397 (declare (ignore type
))
400 (define-alien-type-method (root :deport-pin-p
) (type)
401 (declare (ignore type
))
402 ;; Override this method to return T for classes which take a SAP to a
403 ;; GCable lisp object when deporting.
406 (define-alien-type-method (root :extract-gen
) (type sap offset
)
407 (declare (ignore sap offset
))
408 (error "cannot represent ~S typed aliens" type
))
410 (define-alien-type-method (root :deposit-gen
) (type sap offset value
)
411 `(setf ,(invoke-alien-type-method :extract-gen type sap offset
) ,value
))
413 (define-alien-type-method (root :arg-tn
) (type state
)
414 (declare (ignore state
))
415 (error "Aliens of type ~S cannot be passed as arguments to CALL-OUT."
416 (unparse-alien-type type
)))
418 (define-alien-type-method (root :result-tn
) (type state
)
419 (declare (ignore state
))
420 (error "Aliens of type ~S cannot be returned from CALL-OUT."
421 (unparse-alien-type type
)))
423 ;;;; the INTEGER type
425 (define-alien-type-class (integer)
426 (signed t
:type
(member t nil
)))
428 (define-alien-type-translator signed
(&optional
(bits sb
!vm
:n-word-bits
))
429 (make-alien-integer-type :bits bits
))
431 (define-alien-type-translator integer
(&optional
(bits sb
!vm
:n-word-bits
))
432 (make-alien-integer-type :bits bits
))
434 (define-alien-type-translator unsigned
(&optional
(bits sb
!vm
:n-word-bits
))
435 (make-alien-integer-type :bits bits
:signed nil
))
437 (define-alien-type-method (integer :unparse
) (type)
438 (list (if (alien-integer-type-signed type
) 'signed
'unsigned
)
439 (alien-integer-type-bits type
)))
441 (define-alien-type-method (integer :type
=) (type1 type2
)
442 (and (eq (alien-integer-type-signed type1
)
443 (alien-integer-type-signed type2
))
444 (= (alien-integer-type-bits type1
)
445 (alien-integer-type-bits type2
))))
447 (define-alien-type-method (integer :lisp-rep
) (type)
448 (list (if (alien-integer-type-signed type
) 'signed-byte
'unsigned-byte
)
449 (alien-integer-type-bits type
)))
451 (define-alien-type-method (integer :alien-rep
) (type context
)
452 ;; When returning integer values that are narrower than a machine
453 ;; register from a function, some platforms leave the higher bits of
454 ;; the register uninitialized. On those platforms, we use an
455 ;; alien-rep of the full register width when checking for purposes
456 ;; of return values and override the naturalize method to perform
457 ;; the sign extension (in compiler/target/c-call.lisp).
459 ((:normal
#!-
(or alpha x86 x86-64
) :result
)
460 (list (if (alien-integer-type-signed type
) 'signed-byte
'unsigned-byte
)
461 (alien-integer-type-bits type
)))
462 #!+(or alpha x86 x86-64
)
464 (list (if (alien-integer-type-signed type
) 'signed-byte
'unsigned-byte
)
465 (max (alien-integer-type-bits type
)
466 sb
!vm
:n-machine-word-bits
)))))
468 ;;; As per the comment in the :ALIEN-REP method above, this is defined
469 ;;; elsewhere for alpha and x86oids.
470 #!-
(or alpha x86 x86-64
)
471 (define-alien-type-method (integer :naturalize-gen
) (type alien
)
472 (declare (ignore type
))
475 (define-alien-type-method (integer :deport-gen
) (type value
)
476 (declare (ignore type
))
479 (define-alien-type-method (integer :extract-gen
) (type sap offset
)
480 (declare (type alien-integer-type type
))
482 (if (alien-integer-type-signed type
)
483 (case (alien-integer-type-bits type
)
484 (8 'signed-sap-ref-8
)
485 (16 'signed-sap-ref-16
)
486 (32 'signed-sap-ref-32
)
487 (64 'signed-sap-ref-64
))
488 (case (alien-integer-type-bits type
)
494 `(,ref-fun
,sap
(/ ,offset sb
!vm
:n-byte-bits
))
495 (error "cannot extract ~W-bit integers"
496 (alien-integer-type-bits type
)))))
498 ;;;; the BOOLEAN type
500 (define-alien-type-class (boolean :include integer
:include-args
(signed)))
502 ;;; FIXME: Check to make sure that we aren't attaching user-readable
503 ;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
504 (define-alien-type-translator boolean
(&optional
(bits sb
!vm
:n-word-bits
))
505 (make-alien-boolean-type :bits bits
:signed nil
))
507 (define-alien-type-method (boolean :unparse
) (type)
508 `(boolean ,(alien-boolean-type-bits type
)))
510 (define-alien-type-method (boolean :lisp-rep
) (type)
511 (declare (ignore type
))
514 (define-alien-type-method (boolean :naturalize-gen
) (type alien
)
515 (let ((bits (alien-boolean-type-bits type
)))
516 (if (= bits sb
!vm
:n-word-bits
)
517 `(not (zerop ,alien
))
518 `(logtest ,alien
,(ldb (byte bits
0) -
1)))))
520 (define-alien-type-method (boolean :deport-gen
) (type value
)
521 (declare (ignore type
))
526 (define-alien-type-class (enum :include
(integer (bits 32))
527 :include-args
(signed))
528 name
; name of this enum (if any)
529 from
; alist from symbols to integers
530 to
; alist or vector from integers to symbols
531 kind
; kind of from mapping, :VECTOR or :ALIST
532 offset
) ; offset to add to value for :VECTOR from mapping
534 (define-alien-type-translator enum
(&whole
539 (let ((result (parse-enum name mappings
)))
541 (multiple-value-bind (old old-p
)
542 (auxiliary-alien-type :enum name env
)
544 (unless (alien-type-= result old
)
545 (cerror "Continue, clobbering the old definition"
546 "Incompatible alien enum type definition: ~S" name
)
547 (setf (alien-enum-type-from old
) (alien-enum-type-from result
)
548 (alien-enum-type-to old
) (alien-enum-type-to result
)
549 (alien-enum-type-kind old
) (alien-enum-type-kind result
)
550 (alien-enum-type-offset old
) (alien-enum-type-offset result
)
551 (alien-enum-type-signed old
) (alien-enum-type-signed result
)))
554 (setf (auxiliary-alien-type :enum name env
) result
))))
557 (multiple-value-bind (result found
)
558 (auxiliary-alien-type :enum name env
)
560 (error "unknown enum type: ~S" name
))
563 (error "empty enum type: ~S" type
))))
565 (defun parse-enum (name elements
)
566 (when (null elements
)
567 (error "An enumeration must contain at least one element."))
572 (declare (list from-alist
))
573 (dolist (el elements
)
574 (multiple-value-bind (sym val
)
576 (values (first el
) (second el
))
577 (values el
(1+ prev
)))
579 (unless (symbolp sym
)
580 (error "The enumeration element ~S is not a symbol." sym
))
581 (unless (integerp val
)
582 (error "The element value ~S is not an integer." val
))
583 (unless (and max
(> max val
)) (setq max val
))
584 (unless (and min
(< min val
)) (setq min val
))
585 (when (rassoc val from-alist
)
586 (style-warn "The element value ~S is used more than once." val
))
587 (when (assoc sym from-alist
:test
#'eq
)
588 (error "The enumeration element ~S is used more than once." sym
))
589 (push (cons sym val
) from-alist
)))
590 (let* ((signed (minusp min
))
592 (1+ (max (integer-length min
)
593 (integer-length max
)))
594 (integer-length max
))))
595 (when (> min-bits
32)
596 (error "can't represent enums needing more than 32 bits"))
597 (setf from-alist
(sort from-alist
#'< :key
#'cdr
))
599 ;; If range is at least 20% dense, use vector mapping. Crossover
600 ;; point solely on basis of space would be 25%. Vector mapping
601 ;; is always faster, so give the benefit of the doubt.
602 ((< 0.2 (/ (float (length from-alist
)) (float (1+ (- max min
)))))
603 ;; If offset is small and ignorable, ignore it to save time.
604 (when (< 0 min
10) (setq min
0))
605 (let ((to (make-array (1+ (- max min
)))))
606 (dolist (el from-alist
)
607 (setf (svref to
(- (cdr el
) min
)) (car el
)))
608 (make-alien-enum-type :name name
:signed signed
609 :from from-alist
:to to
:kind
610 :vector
:offset
(- min
))))
612 (make-alien-enum-type :name name
:signed signed
614 :to
(mapcar (lambda (x) (cons (cdr x
) (car x
)))
618 (define-alien-type-method (enum :unparse
) (type)
619 `(enum ,(alien-enum-type-name type
)
621 (mapcar (lambda (mapping)
622 (let ((sym (car mapping
))
623 (value (cdr mapping
)))
625 (if (= (1+ prev
) value
)
629 (alien-enum-type-from type
)))))
631 (define-alien-type-method (enum :type
=) (type1 type2
)
632 (and (eq (alien-enum-type-name type1
)
633 (alien-enum-type-name type2
))
634 (equal (alien-enum-type-from type1
)
635 (alien-enum-type-from type2
))))
637 (define-alien-type-method (enum :lisp-rep
) (type)
638 `(member ,@(mapcar #'car
(alien-enum-type-from type
))))
640 (define-alien-type-method (enum :naturalize-gen
) (type alien
)
641 (ecase (alien-enum-type-kind type
)
643 `(svref ',(alien-enum-type-to type
)
644 (+ ,alien
,(alien-enum-type-offset type
))))
647 ,@(mapcar (lambda (mapping)
648 `(,(car mapping
) ',(cdr mapping
)))
649 (alien-enum-type-to type
))))))
651 (define-alien-type-method (enum :deport-gen
) (type value
)
653 ,@(mapcar (lambda (mapping)
654 `(,(car mapping
) ,(cdr mapping
)))
655 (alien-enum-type-from type
))))
659 (define-alien-type-class (float)
660 (type (missing-arg) :type symbol
))
662 (define-alien-type-method (float :unparse
) (type)
663 (alien-float-type-type type
))
665 (define-alien-type-method (float :lisp-rep
) (type)
666 (alien-float-type-type type
))
668 (define-alien-type-method (float :alien-rep
) (type context
)
669 (declare (ignore context
))
670 (alien-float-type-type type
))
672 (define-alien-type-method (float :naturalize-gen
) (type alien
)
673 (declare (ignore type
))
676 (define-alien-type-method (float :deport-gen
) (type value
)
677 (declare (ignore type
))
680 (define-alien-type-class (single-float :include
(float (bits 32))
681 :include-args
(type)))
683 (define-alien-type-translator single-float
()
684 (make-alien-single-float-type :type
'single-float
))
686 (define-alien-type-method (single-float :extract-gen
) (type sap offset
)
687 (declare (ignore type
))
688 `(sap-ref-single ,sap
(/ ,offset sb
!vm
:n-byte-bits
)))
690 (define-alien-type-class (double-float :include
(float (bits 64))
691 :include-args
(type)))
693 (define-alien-type-translator double-float
()
694 (make-alien-double-float-type :type
'double-float
))
696 (define-alien-type-method (double-float :extract-gen
) (type sap offset
)
697 (declare (ignore type
))
698 `(sap-ref-double ,sap
(/ ,offset sb
!vm
:n-byte-bits
)))
701 ;;;; the POINTER type
703 (define-alien-type-class (pointer :include
(alien-value (bits
704 sb
!vm
:n-machine-word-bits
)))
705 (to nil
:type
(or alien-type null
)))
707 (define-alien-type-translator * (to &environment env
)
708 (make-alien-pointer-type :to
(if (eq to t
) nil
(parse-alien-type to env
))))
710 (define-alien-type-method (pointer :unparse
) (type)
711 (let ((to (alien-pointer-type-to type
)))
713 (%unparse-alien-type to
)
716 (define-alien-type-method (pointer :type
=) (type1 type2
)
717 (let ((to1 (alien-pointer-type-to type1
))
718 (to2 (alien-pointer-type-to type2
)))
721 (alien-type-= to1 to2
)
725 (define-alien-type-method (pointer :subtypep
) (type1 type2
)
726 (and (alien-pointer-type-p type2
)
727 (let ((to1 (alien-pointer-type-to type1
))
728 (to2 (alien-pointer-type-to type2
)))
731 (alien-subtype-p to1 to2
)
735 (define-alien-type-method (pointer :deport-gen
) (type value
)
736 (/noshow
"doing alien type method POINTER :DEPORT-GEN" type value
)
738 ;; FIXME: old version, highlighted a bug in xc optimization
746 ;; new version, works around bug in xc optimization
755 `(or null system-area-pointer
(alien ,type
))))
757 ;;;; the MEM-BLOCK type
759 (define-alien-type-class (mem-block :include alien-value
))
761 (define-alien-type-method (mem-block :extract-gen
) (type sap offset
)
762 (declare (ignore type
))
763 `(sap+ ,sap
(truncate ,offset sb
!vm
:n-byte-bits
)))
765 (define-alien-type-method (mem-block :deposit-gen
) (type sap offset value
)
766 (let ((bits (alien-mem-block-type-bits type
)))
768 (error "can't deposit aliens of type ~S (unknown size)" type
))
769 `(sb!kernel
:system-area-ub8-copy
,value
0 ,sap
770 (truncate ,offset sb
!vm
:n-byte-bits
)
771 ',(truncate bits sb
!vm
:n-byte-bits
))))
775 (define-alien-type-class (array :include mem-block
)
776 (element-type (missing-arg) :type alien-type
)
777 (dimensions (missing-arg) :type list
))
779 (define-alien-type-translator array
(ele-type &rest dims
&environment env
)
782 (unless (typep (first dims
) '(or index null
))
783 (error "The first dimension is not a non-negative fixnum or NIL: ~S"
785 (let ((loser (find-if-not (lambda (x) (typep x
'index
))
788 (error "A dimension is not a non-negative fixnum: ~S" loser
))))
790 (let ((parsed-ele-type (parse-alien-type ele-type env
)))
791 (make-alien-array-type
792 :element-type parsed-ele-type
794 :alignment
(alien-type-alignment parsed-ele-type
)
795 :bits
(if (and (alien-type-bits parsed-ele-type
)
796 (every #'integerp dims
))
797 (* (align-offset (alien-type-bits parsed-ele-type
)
798 (alien-type-alignment parsed-ele-type
))
799 (reduce #'* dims
))))))
801 (define-alien-type-method (array :unparse
) (type)
802 `(array ,(%unparse-alien-type
(alien-array-type-element-type type
))
803 ,@(alien-array-type-dimensions type
)))
805 (define-alien-type-method (array :type
=) (type1 type2
)
806 (and (equal (alien-array-type-dimensions type1
)
807 (alien-array-type-dimensions type2
))
808 (alien-type-= (alien-array-type-element-type type1
)
809 (alien-array-type-element-type type2
))))
811 (define-alien-type-method (array :subtypep
) (type1 type2
)
812 (and (alien-array-type-p type2
)
813 (let ((dim1 (alien-array-type-dimensions type1
))
814 (dim2 (alien-array-type-dimensions type2
)))
815 (and (= (length dim1
) (length dim2
))
818 (equal (cdr dim1
) (cdr dim2
)))
820 (alien-subtype-p (alien-array-type-element-type type1
)
821 (alien-array-type-element-type type2
))))))
825 (def!struct
(alien-record-field
826 (:make-load-form-fun sb
!kernel
:just-dump-it-normally
))
827 (name (missing-arg) :type symbol
)
828 (type (missing-arg) :type alien-type
)
829 (bits nil
:type
(or unsigned-byte null
))
830 (offset 0 :type unsigned-byte
))
831 (def!method print-object
((field alien-record-field
) stream
)
832 (print-unreadable-object (field stream
:type t
)
835 (alien-record-field-type field
)
836 (alien-record-field-name field
)
837 (alien-record-field-bits field
))))
839 (define-alien-type-class (record :include mem-block
)
840 (kind :struct
:type
(member :struct
:union
))
841 (name nil
:type
(or symbol null
))
842 (fields nil
:type list
))
844 (define-alien-type-translator struct
(name &rest fields
&environment env
)
845 (parse-alien-record-type :struct name fields env
))
847 (define-alien-type-translator union
(name &rest fields
&environment env
)
848 (parse-alien-record-type :union name fields env
))
850 ;;; FIXME: This is really pretty horrible: we avoid creating new
851 ;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the
852 ;;; system already. This way forward-references sans fields get
853 ;;; "updated" for free to contain the field info. Maybe rename
854 ;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use
855 ;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729
856 (defun parse-alien-record-type (kind name fields env
)
857 (declare (type sb
!kernel
:lexenv-designator env
))
858 (flet ((frob-type (type new-fields alignment bits
)
859 (setf (alien-record-type-fields type
) new-fields
860 (alien-record-type-alignment type
) alignment
861 (alien-record-type-bits type
) bits
)))
863 (multiple-value-bind (new-fields alignment bits
)
864 (parse-alien-record-fields kind fields env
)
865 (let* ((old (and name
(auxiliary-alien-type kind name env
)))
866 (old-fields (and old
(alien-record-type-fields old
))))
867 (when (and old-fields
868 (notevery #'record-fields-match-p old-fields new-fields
))
869 (cerror "Continue, clobbering the old definition."
870 "Incompatible alien record type definition~%Old: ~S~%New: ~S"
871 (unparse-alien-type old
)
872 `(,(unparse-alien-record-kind kind
)
874 ,@(let ((*record-types-already-unparsed
* '()))
875 (mapcar #'unparse-alien-record-field new-fields
))))
876 (frob-type old new-fields alignment bits
))
879 (let ((type (or old
(make-alien-record-type :name name
:kind kind
))))
880 (when (and name
(not old
))
881 (setf (auxiliary-alien-type kind name env
) type
))
882 (frob-type type new-fields alignment bits
)
885 (or (auxiliary-alien-type kind name env
)
886 (setf (auxiliary-alien-type kind name env
)
887 (make-alien-record-type :name name
:kind kind
))))
889 (make-alien-record-type :kind kind
)))))
891 ;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union
892 ;;; types. KIND is the kind we are paring the fields of, and FIELDS is the
893 ;;; list of field specifications.
895 ;;; Result is a list of field objects, overall alignment, and number of bits
896 (defun parse-alien-record-fields (kind fields env
)
897 (declare (type list fields
))
899 (overall-alignment 1)
901 (dolist (field fields
)
902 (destructuring-bind (var type
&key alignment bits offset
) field
903 (declare (ignore bits
))
904 (let* ((field-type (parse-alien-type type env
))
905 (bits (alien-type-bits field-type
))
907 (make-alien-record-field :type field-type
910 (setf alignment
(alien-type-alignment field-type
)))
911 (push parsed-field parsed-fields
)
913 (error "unknown size: ~S" (unparse-alien-type field-type
)))
914 (when (null alignment
)
915 (error "unknown alignment: ~S" (unparse-alien-type field-type
)))
916 (setf overall-alignment
(max overall-alignment alignment
))
919 (let ((offset (or offset
(align-offset total-bits alignment
))))
920 (setf (alien-record-field-offset parsed-field
) offset
)
921 (setf total-bits
(+ offset bits
))))
923 (setf total-bits
(max total-bits bits
)))))))
924 (values (nreverse parsed-fields
)
926 (align-offset total-bits overall-alignment
))))
928 (define-alien-type-method (record :unparse
) (type)
929 `(,(unparse-alien-record-kind (alien-record-type-kind type
))
930 ,(alien-record-type-name type
)
931 ,@(unless (member type
*record-types-already-unparsed
* :test
#'eq
)
932 (push type
*record-types-already-unparsed
*)
933 (mapcar #'unparse-alien-record-field
934 (alien-record-type-fields type
)))))
936 (defun unparse-alien-record-kind (kind)
942 (defun unparse-alien-record-field (field)
943 `(,(alien-record-field-name field
)
944 ,(%unparse-alien-type
(alien-record-field-type field
))
945 ,@(when (alien-record-field-bits field
)
946 (list :bits
(alien-record-field-bits field
)))
947 ,@(when (alien-record-field-offset field
)
948 (list :offset
(alien-record-field-offset field
)))))
950 ;;; Test the record fields. Keep a hashtable table of already compared
951 ;;; types to detect cycles.
952 (defun record-fields-match-p (field1 field2
)
953 (and (eq (alien-record-field-name field1
)
954 (alien-record-field-name field2
))
955 (eql (alien-record-field-bits field1
)
956 (alien-record-field-bits field2
))
957 (eql (alien-record-field-offset field1
)
958 (alien-record-field-offset field2
))
959 (alien-type-= (alien-record-field-type field1
)
960 (alien-record-field-type field2
))))
962 (defvar *alien-type-matches
* nil
964 "A hashtable used to detect cycles while comparing record types.")
966 (define-alien-type-method (record :type
=) (type1 type2
)
967 (and (eq (alien-record-type-name type1
)
968 (alien-record-type-name type2
))
969 (eq (alien-record-type-kind type1
)
970 (alien-record-type-kind type2
))
971 (eql (alien-type-bits type1
)
972 (alien-type-bits type2
))
973 (eql (alien-type-alignment type1
)
974 (alien-type-alignment type2
))
975 (flet ((match-fields (&optional old
)
976 (setf (gethash type1
*alien-type-matches
*) (cons type2 old
))
977 (every #'record-fields-match-p
978 (alien-record-type-fields type1
)
979 (alien-record-type-fields type2
))))
980 (if *alien-type-matches
*
981 (let ((types (gethash type1
*alien-type-matches
*)))
982 (or (memq type2 types
) (match-fields types
)))
983 (let ((*alien-type-matches
* (make-hash-table :test
#'eq
)))
986 ;;;; the FUNCTION and VALUES alien types
988 ;;; Calling-convention spec, typically one of predefined keywords.
989 ;;; Add or remove as needed for target platform. It makes sense to
990 ;;; support :cdecl everywhere.
992 ;;; Null convention is supposed to be platform-specific most-universal
993 ;;; callout convention. For x86, SBCL calls foreign functions in a way
994 ;;; allowing them to be either stdcall or cdecl; null convention is
995 ;;; appropriate here, as it is for specifying callbacks that could be
996 ;;; accepted by foreign code both in cdecl and stdcall form.
997 (def!type calling-convention
() `(or null
(member :stdcall
:cdecl
)))
999 ;;; Convention could be a values type class, stored at result-type.
1000 ;;; However, it seems appropriate only for epilogue-related
1001 ;;; conventions, those not influencing incoming arg passing.
1003 ;;; As of x86's :stdcall and :cdecl, supported by now, both are
1004 ;;; epilogue-related, but future extensions (like :fastcall and
1005 ;;; miscellaneous non-x86 stuff) might affect incoming argument
1006 ;;; translation as well.
1008 (define-alien-type-class (fun :include mem-block
)
1009 (result-type (missing-arg) :type alien-type
)
1010 (arg-types (missing-arg) :type list
)
1011 (stub nil
:type
(or null function
))
1012 (convention nil
:type calling-convention
))
1014 ;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
1015 ;;; convention specification for function types is unobvious.
1017 ;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
1018 ;;; starting with a convention keyword; its second item is a real
1019 ;;; result-type in this case. If convention is ever to become a part
1020 ;;; of result-type, such a syntax can be retained.
1022 (define-alien-type-translator function
(result-type &rest arg-types
1024 (multiple-value-bind (bare-result-type calling-convention
)
1025 (typecase result-type
1026 ((cons calling-convention
*)
1027 (values (second result-type
) (first result-type
)))
1029 (make-alien-fun-type
1030 :convention calling-convention
1031 :result-type
(let ((*values-type-okay
* t
))
1032 (parse-alien-type bare-result-type env
))
1033 :arg-types
(mapcar (lambda (arg-type) (parse-alien-type arg-type env
))
1036 (define-alien-type-method (fun :unparse
) (type)
1037 `(function ,(let ((result-type
1038 (%unparse-alien-type
(alien-fun-type-result-type type
)))
1039 (convention (alien-fun-type-convention type
)))
1040 (if convention
(list convention result-type
)
1042 ,@(mapcar #'%unparse-alien-type
1043 (alien-fun-type-arg-types type
))))
1045 (define-alien-type-method (fun :type
=) (type1 type2
)
1046 (and (alien-type-= (alien-fun-type-result-type type1
)
1047 (alien-fun-type-result-type type2
))
1048 (eq (alien-fun-type-convention type1
)
1049 (alien-fun-type-convention type2
))
1050 (= (length (alien-fun-type-arg-types type1
))
1051 (length (alien-fun-type-arg-types type2
)))
1052 (every #'alien-type-
=
1053 (alien-fun-type-arg-types type1
)
1054 (alien-fun-type-arg-types type2
))))
1056 (define-alien-type-class (values)
1057 (values (missing-arg) :type list
))
1059 (define-alien-type-translator values
(&rest values
&environment env
)
1060 (unless *values-type-okay
*
1061 (error "cannot use values types here"))
1062 (let ((*values-type-okay
* nil
))
1063 (make-alien-values-type
1064 :values
(mapcar (lambda (alien-type) (parse-alien-type alien-type env
))
1067 (define-alien-type-method (values :unparse
) (type)
1068 `(values ,@(mapcar #'%unparse-alien-type
1069 (alien-values-type-values type
))))
1071 (define-alien-type-method (values :type
=) (type1 type2
)
1072 (and (= (length (alien-values-type-values type1
))
1073 (length (alien-values-type-values type2
)))
1074 (every #'alien-type-
=
1075 (alien-values-type-values type1
)
1076 (alien-values-type-values type2
))))
1078 ;;;; a structure definition needed both in the target and in the
1079 ;;;; cross-compilation host
1081 ;;; information about local aliens. The WITH-ALIEN macro builds one of
1082 ;;; these structures and LOCAL-ALIEN and friends communicate
1083 ;;; information about how that local alien is represented.
1084 (def!struct
(local-alien-info
1085 (:make-load-form-fun sb
!kernel
:just-dump-it-normally
)
1086 (:constructor make-local-alien-info
1087 (&key type force-to-memory-p
1088 &aux
(force-to-memory-p (or force-to-memory-p
1089 (alien-array-type-p type
)
1090 (alien-record-type-p type
))))))
1091 ;; the type of the local alien
1092 (type (missing-arg) :type alien-type
)
1093 ;; Must this local alien be forced into memory? Using the ADDR macro
1094 ;; on a local alien will set this.
1095 (force-to-memory-p nil
:type
(member t nil
)))
1096 (def!method print-object
((info local-alien-info
) stream
)
1097 (print-unreadable-object (info stream
:type t
)
1099 "~:[~;(forced to stack) ~]~S"
1100 (local-alien-info-force-to-memory-p info
)
1101 (unparse-alien-type (local-alien-info-type info
)))))
1105 (sb!xc
:defmacro addr
(expr &environment env
)
1107 "Return an Alien pointer to the data addressed by Expr, which must be a call
1108 to SLOT or DEREF, or a reference to an Alien variable."
1109 (let ((form (%macroexpand expr env
)))
1114 (cons '%slot-addr
(cdr form
)))
1116 (cons '%deref-addr
(cdr form
)))
1118 (cons '%heap-alien-addr
(cdr form
)))
1120 (let ((info (let ((info-arg (second form
)))
1121 (and (consp info-arg
)
1122 (eq (car info-arg
) 'quote
)
1123 (second info-arg
)))))
1124 (unless (local-alien-info-p info
)
1125 (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
1127 (setf (local-alien-info-force-to-memory-p info
) t
))
1128 (cons '%local-alien-addr
(cdr form
)))))
1130 (let ((kind (info :variable
:kind form
)))
1131 (when (eq kind
:alien
)
1132 `(%heap-alien-addr
',(info :variable
:alien-info form
))))))
1133 (error "~S is not a valid L-value." form
))))
1135 (/show0
"host-alieneval.lisp end of file")