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 (setf (info :source-location
:alien-type
',name
)
58 (sb!c
:source-location
))
59 (def!struct
(,defstruct-name
60 (:include
,include-defstruct
65 ,(symbolicate "MAKE-" defstruct-name
)
66 (&key class bits alignment
68 (if (atom x
) x
(car x
)))
72 &aux
(alignment (or alignment
(guess-alignment bits
))))))
75 (defmacro define-alien-type-method
((class method
) lambda-list
&rest body
)
76 (let ((defun-name (symbolicate class
"-" method
"-METHOD")))
78 (defun ,defun-name
,lambda-list
80 (setf (,(method-slot method
) (alien-type-class-or-lose ',class
))
83 ;;;; type parsing and unparsing
85 ;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and
86 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
87 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
89 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
90 (defun auxiliary-type-definitions (env)
91 (multiple-value-bind (result expanded-p
)
92 (%macroexpand
'&auxiliary-type-definitions
& env
)
95 ;; This is like having the global symbol-macro definition be
96 ;; NIL, but global symbol-macros make me vaguely queasy, so
97 ;; I do it this way instead.
100 ;;; Parse TYPE as an alien type specifier and return the resultant
101 ;;; ALIEN-TYPE structure.
102 (defun parse-alien-type (type env
)
103 (declare (type sb
!kernel
:lexenv-designator env
))
105 (let ((translator (info :alien-type
:translator
(car type
))))
107 (error "unknown alien type: ~/sb!impl:print-type-specifier/"
109 (funcall translator type env
))
110 (ecase (info :alien-type
:kind type
)
112 (let ((translator (info :alien-type
:translator type
)))
114 (error "no translator for primitive alien type ~
115 ~/sb!impl:print-type-specifier/"
117 (funcall translator
(list type
) env
)))
119 (or (info :alien-type
:definition type
)
120 (error "no definition for alien type ~/sb!impl:print-type-specifier/"
123 (error "unknown alien type: ~/sb!impl:print-type-specifier/"
126 (defun auxiliary-alien-type (kind name env
)
127 (declare (type sb
!kernel
:lexenv-designator env
))
128 (flet ((aux-defn-matches (x)
129 (and (eq (first x
) kind
) (eq (second x
) name
))))
130 (let ((in-auxiliaries
131 (or (find-if #'aux-defn-matches
*new-auxiliary-types
*)
132 (find-if #'aux-defn-matches
(auxiliary-type-definitions env
)))))
134 (values (third in-auxiliaries
) t
)
135 (info :alien-type kind name
)))))
137 (defun (setf auxiliary-alien-type
) (new-value kind name env
)
138 (declare (type sb
!kernel
:lexenv-designator env
))
139 (flet ((aux-defn-matches (x)
140 (and (eq (first x
) kind
) (eq (second x
) name
))))
141 (when (find-if #'aux-defn-matches
*new-auxiliary-types
*)
142 (error "attempt to multiply define ~A ~S" kind name
))
143 (when (find-if #'aux-defn-matches
(auxiliary-type-definitions env
))
144 (error "attempt to shadow definition of ~A ~S" kind name
)))
145 (push (list kind name new-value
) *new-auxiliary-types
*)
148 (defun verify-local-auxiliaries-okay ()
149 (dolist (info *new-auxiliary-types
*)
150 (destructuring-bind (kind name defn
) info
151 (declare (ignore defn
))
152 (when (info :alien-type kind name
)
153 (error "attempt to shadow definition of ~A ~S" kind name
)))))
155 (defun unparse-alien-type (type)
156 "Convert the alien-type structure TYPE back into a list specification of
158 (declare (type alien-type type
))
159 (let ((*record-types-already-unparsed
* nil
))
160 (%unparse-alien-type type
)))
162 ;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we
163 ;;; need to recurse inside the binding of
164 ;;; *RECORD-TYPES-ALREADY-UNPARSED*.
165 (defun %unparse-alien-type
(type)
166 (invoke-alien-type-method :unparse type
))
168 ;;;; alien type defining stuff
170 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
171 (defun %define-alien-type-translator
(name translator
)
172 (setf (info :alien-type
:kind name
) :primitive
)
173 (setf (info :alien-type
:translator name
) translator
)
174 (clear-info :alien-type
:definition name
)
177 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
178 (defun %def-auxiliary-alien-types
(types source-location
)
180 ;; Clear up the type we're about to define from the toplevel
181 ;; *new-auxiliary-types* (local scopes take care of themselves).
182 ;; Unless this is done we never actually get back the full type
183 ;; from INFO, since the *new-auxiliary-types* have precendence.
184 (setf *new-auxiliary-types
*
185 (remove info
*new-auxiliary-types
*
187 (and (eq (first a
) (first b
))
188 (eq (second a
) (second b
))))))
189 (destructuring-bind (kind name defn
) info
190 (let ((old (info :alien-type kind name
)))
191 (unless (or (null old
) (alien-type-= old defn
))
192 (warn "redefining ~A ~S to be:~% ~S,~%was:~% ~S"
193 kind name defn old
)))
194 (setf (info :alien-type kind name
) defn
195 (info :source-location
:alien-type name
) source-location
))))
197 (defun %define-alien-type
(name new source-location
)
198 (ecase (info :alien-type
:kind name
)
200 (error "~/sb!impl:print-type-specifier/ is a built-in alien type."
203 (let ((old (info :alien-type
:definition name
)))
204 (unless (or (null old
) (alien-type-= new old
))
205 (warn "redefining ~S to be:~% ~
206 ~/sb!impl:print-type-specifier/,~%was~% ~
207 ~/sb!impl:print-type-specifier/"
209 (unparse-alien-type new
)
210 (unparse-alien-type old
)))))
212 (setf (info :alien-type
:definition name
) new
)
213 (setf (info :alien-type
:kind name
) :defined
)
214 (setf (info :source-location
:alien-type name
) source-location
)
217 ;;;; the root alien type
219 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
220 (create-alien-type-class-if-necessary 'root
'alien-type nil
))
222 (defmethod print-object ((type alien-type
) stream
)
223 (print-unreadable-object (type stream
:type t
)
224 (sb!ext
:print-type-specifier stream
(unparse-alien-type type
))))
228 (define-alien-type-class (system-area-pointer))
230 (define-alien-type-translator system-area-pointer
()
231 (make-alien-system-area-pointer-type
232 :bits sb
!vm
:n-machine-word-bits
))
234 (define-alien-type-method (system-area-pointer :unparse
) (type)
235 (declare (ignore type
))
236 'system-area-pointer
)
238 (define-alien-type-method (system-area-pointer :lisp-rep
) (type)
239 (declare (ignore type
))
240 'system-area-pointer
)
242 (define-alien-type-method (system-area-pointer :alien-rep
) (type context
)
243 (declare (ignore type context
))
244 'system-area-pointer
)
246 (define-alien-type-method (system-area-pointer :naturalize-gen
) (type alien
)
247 (declare (ignore type
))
250 (define-alien-type-method (system-area-pointer :deport-gen
) (type object
)
251 (declare (ignore type
))
252 (/noshow
"doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object
)
255 (define-alien-type-method (system-area-pointer :extract-gen
) (type sap offset
)
256 (declare (ignore type
))
257 `(sap-ref-sap ,sap
(/ ,offset sb
!vm
:n-byte-bits
)))
259 ;;;; the ALIEN-VALUE type
261 (define-alien-type-class (alien-value :include system-area-pointer
))
263 (define-alien-type-method (alien-value :lisp-rep
) (type)
264 (declare (ignore type
))
267 (define-alien-type-method (alien-value :naturalize-gen
) (type alien
)
268 `(%sap-alien
,alien
',type
))
270 (define-alien-type-method (alien-value :deport-gen
) (type value
)
271 (declare (ignore type
))
272 (/noshow
"doing alien type method ALIEN-VALUE :DEPORT-GEN" value
)
275 ;;; HEAP-ALIEN-INFO -- defstruct.
277 (defmethod print-object ((info heap-alien-info
) stream
)
278 (print-unreadable-object (info stream
:type t
)
279 (format stream
"~S ~S~@[ (data)~]"
280 (heap-alien-info-alien-name info
)
281 (unparse-alien-type (heap-alien-info-type info
))
282 (heap-alien-info-datap info
))))
284 ;;; The form to evaluate to produce the SAP pointing to where in the heap
286 (defun heap-alien-info-sap-form (info)
287 `(foreign-symbol-sap ,(heap-alien-info-alien-name info
)
288 ,(heap-alien-info-datap info
)))
290 #-sb-xc-host
; No FOREIGN-SYMBOL-SAP
291 (defun heap-alien-info-sap (info)
292 (foreign-symbol-sap (heap-alien-info-alien-name info
)
293 (heap-alien-info-datap info
)))
295 ;;;; Interfaces to the different methods
297 (defun alien-type-= (type1 type2
)
298 "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
300 (and (eq (alien-type-class type1
)
301 (alien-type-class type2
))
302 (invoke-alien-type-method :type
= type1 type2
))))
304 (defun alien-subtype-p (type1 type2
)
305 "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the
306 only supported subtype relationships are is that any pointer type is a
307 subtype of (* t), and any array type first dimension will match
308 (array <eltype> nil ...). Otherwise, the two types have to be
311 (invoke-alien-type-method :subtypep type1 type2
)))
313 (defun compute-naturalize-lambda (type)
314 `(lambda (alien ignore
)
315 (declare (ignore ignore
))
316 ,(invoke-alien-type-method :naturalize-gen type
'alien
)))
318 (defun compute-deport-lambda (type)
319 (declare (type alien-type type
))
320 (/noshow
"entering COMPUTE-DEPORT-LAMBDA" type
)
321 (multiple-value-bind (form value-type
)
322 (invoke-alien-type-method :deport-gen type
'value
)
323 `(lambda (value ignore
)
324 (declare (type ,(or value-type
325 (compute-lisp-rep-type type
)
331 (defun compute-deport-alloc-lambda (type)
332 `(lambda (value ignore
)
333 (declare (ignore ignore
))
334 ,(invoke-alien-type-method :deport-alloc-gen type
'value
)))
336 (defun compute-extract-lambda (type)
337 (let ((extract (invoke-alien-type-method :extract-gen type
'sap
'offset
)))
338 `(lambda (sap offset ignore
)
339 (declare (type system-area-pointer sap
)
340 (type unsigned-byte offset
)
342 ,(if (eq (alien-type-class type
) 'integer
)
344 `(naturalize ,extract
',type
)))))
346 (defun compute-deposit-lambda (type)
347 (declare (type alien-type type
))
348 `(lambda (value sap offset ignore
)
349 (declare (type system-area-pointer sap
)
350 (type unsigned-byte offset
)
352 (let ((alloc-tmp (deport-alloc value
',type
)))
353 (maybe-with-pinned-objects (alloc-tmp) (,type
)
354 (let ((value (deport alloc-tmp
',type
)))
355 ,(invoke-alien-type-method :deposit-gen type
'sap
'offset
'value
)
356 ;; Note: the reason we don't just return the pre-deported value
357 ;; is because that would inhibit any (deport (naturalize ...))
358 ;; optimizations that might have otherwise happen. Re-naturalizing
359 ;; the value might cause extra consing, but is flushable, so probably
360 ;; results in better code.
361 (naturalize value
',type
))))))
363 (defun compute-lisp-rep-type (type)
364 (invoke-alien-type-method :lisp-rep type
))
366 ;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function
367 ;;; return values). See the :ALIEN-REP method for INTEGER for
369 (defun compute-alien-rep-type (type &optional
(context :normal
))
370 (invoke-alien-type-method :alien-rep type context
))
374 (defun missing-alien-operation-error (type operation
)
375 (error "Cannot ~A aliens of type ~/sb!impl:print-type-specifier/."
378 (define-alien-type-method (root :unparse
) (type)
379 `(<unknown-alien-type
> ,(type-of type
)))
381 (define-alien-type-method (root :type
=) (type1 type2
)
382 (declare (ignore type1 type2
))
385 (define-alien-type-method (root :subtypep
) (type1 type2
)
386 (alien-type-= type1 type2
))
388 (define-alien-type-method (root :lisp-rep
) (type)
389 (declare (ignore type
))
392 (define-alien-type-method (root :alien-rep
) (type context
)
393 (declare (ignore type context
))
396 (define-alien-type-method (root :naturalize-gen
) (type alien
)
397 (declare (ignore alien
))
398 (missing-alien-operation-error "represent" type
))
400 (define-alien-type-method (root :deport-gen
) (type object
)
401 (declare (ignore object
))
402 (missing-alien-operation-error "represent" type
))
404 (define-alien-type-method (root :deport-alloc-gen
) (type object
)
405 (declare (ignore type
))
408 (define-alien-type-method (root :deport-pin-p
) (type)
409 (declare (ignore type
))
410 ;; Override this method to return T for classes which take a SAP to a
411 ;; GCable lisp object when deporting.
414 (define-alien-type-method (root :extract-gen
) (type sap offset
)
415 (declare (ignore sap offset
))
416 (missing-alien-operation-error "represent" type
))
418 (define-alien-type-method (root :deposit-gen
) (type sap offset value
)
419 `(setf ,(invoke-alien-type-method :extract-gen type sap offset
) ,value
))
421 (define-alien-type-method (root :arg-tn
) (type state
)
422 (declare (ignore state
))
423 (missing-alien-operation-error "pass as argument to CALL-OUT"
424 (unparse-alien-type type
)))
426 (define-alien-type-method (root :result-tn
) (type state
)
427 (declare (ignore state
))
428 (missing-alien-operation-error "return from CALL-OUT"
429 (unparse-alien-type type
)))
431 ;;;; the INTEGER type
433 (define-alien-type-class (integer)
434 (signed t
:type
(member t nil
)))
436 (define-alien-type-translator signed
(&optional
(bits sb
!vm
:n-word-bits
))
437 (make-alien-integer-type :bits bits
))
439 (define-alien-type-translator integer
(&optional
(bits sb
!vm
:n-word-bits
))
440 (make-alien-integer-type :bits bits
))
442 (define-alien-type-translator unsigned
(&optional
(bits sb
!vm
:n-word-bits
))
443 (make-alien-integer-type :bits bits
:signed nil
))
445 (define-alien-type-method (integer :unparse
) (type)
446 (list (if (alien-integer-type-signed type
) 'signed
'unsigned
)
447 (alien-integer-type-bits type
)))
449 (define-alien-type-method (integer :type
=) (type1 type2
)
450 (and (eq (alien-integer-type-signed type1
)
451 (alien-integer-type-signed type2
))
452 (= (alien-integer-type-bits type1
)
453 (alien-integer-type-bits type2
))))
455 (define-alien-type-method (integer :lisp-rep
) (type)
456 (list (if (alien-integer-type-signed type
) 'signed-byte
'unsigned-byte
)
457 (alien-integer-type-bits type
)))
459 (define-alien-type-method (integer :alien-rep
) (type context
)
460 ;; When returning integer values that are narrower than a machine
461 ;; register from a function, some platforms leave the higher bits of
462 ;; the register uninitialized. On those platforms, we use an
463 ;; alien-rep of the full register width when checking for purposes
464 ;; of return values and override the naturalize method to perform
465 ;; the sign extension (in compiler/target/c-call.lisp).
467 ((:normal
#!-
(or alpha x86 x86-64
) :result
)
468 (list (if (alien-integer-type-signed type
) 'signed-byte
'unsigned-byte
)
469 (alien-integer-type-bits type
)))
470 #!+(or alpha x86 x86-64
)
472 (list (if (alien-integer-type-signed type
) 'signed-byte
'unsigned-byte
)
473 (max (alien-integer-type-bits type
)
474 sb
!vm
:n-machine-word-bits
)))))
476 ;;; As per the comment in the :ALIEN-REP method above, this is defined
477 ;;; elsewhere for alpha and x86oids.
478 #!-
(or alpha x86 x86-64
)
479 (define-alien-type-method (integer :naturalize-gen
) (type alien
)
480 (declare (ignore type
))
483 (define-alien-type-method (integer :deport-gen
) (type value
)
484 (declare (ignore type
))
487 (define-alien-type-method (integer :extract-gen
) (type sap offset
)
488 (declare (type alien-integer-type type
))
490 (if (alien-integer-type-signed type
)
491 (case (alien-integer-type-bits type
)
492 (8 'signed-sap-ref-8
)
493 (16 'signed-sap-ref-16
)
494 (32 'signed-sap-ref-32
)
495 (64 'signed-sap-ref-64
))
496 (case (alien-integer-type-bits type
)
502 `(,ref-fun
,sap
(/ ,offset sb
!vm
:n-byte-bits
))
503 (error "cannot extract ~W-bit integers"
504 (alien-integer-type-bits type
)))))
506 ;;;; the BOOLEAN type
508 (define-alien-type-class (boolean :include integer
:include-args
(signed)))
510 ;;; FIXME: Check to make sure that we aren't attaching user-readable
511 ;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
512 (define-alien-type-translator boolean
(&optional
(bits sb
!vm
:n-word-bits
))
513 (make-alien-boolean-type :bits bits
:signed nil
))
515 (define-alien-type-method (boolean :unparse
) (type)
516 `(boolean ,(alien-boolean-type-bits type
)))
518 (define-alien-type-method (boolean :lisp-rep
) (type)
519 (declare (ignore type
))
522 (define-alien-type-method (boolean :naturalize-gen
) (type alien
)
523 (let ((bits (alien-boolean-type-bits type
)))
524 (if (= bits sb
!vm
:n-word-bits
)
525 `(not (zerop ,alien
))
526 `(logtest ,alien
,(ldb (byte bits
0) -
1)))))
528 (define-alien-type-method (boolean :deport-gen
) (type value
)
529 (declare (ignore type
))
534 (define-alien-type-class (enum :include
(integer (bits 32))
535 :include-args
(signed))
536 name
; name of this enum (if any)
537 from
; alist from symbols to integers
538 to
; alist or vector from integers to symbols
539 kind
; kind of from mapping, :VECTOR or :ALIST
540 offset
) ; offset to add to value for :VECTOR from mapping
542 (define-alien-type-translator enum
(&whole
547 (let ((result (parse-enum name mappings
)))
549 (multiple-value-bind (old old-p
)
550 (auxiliary-alien-type :enum name env
)
552 (unless (alien-type-= result old
)
553 (cerror "Continue, clobbering the old definition"
554 "Incompatible alien enum type definition: ~S" name
)
555 (setf (alien-enum-type-from old
) (alien-enum-type-from result
)
556 (alien-enum-type-to old
) (alien-enum-type-to result
)
557 (alien-enum-type-kind old
) (alien-enum-type-kind result
)
558 (alien-enum-type-offset old
) (alien-enum-type-offset result
)
559 (alien-enum-type-signed old
) (alien-enum-type-signed result
)))
562 (setf (auxiliary-alien-type :enum name env
) result
))))
565 (multiple-value-bind (result found
)
566 (auxiliary-alien-type :enum name env
)
568 (error "unknown enum type: ~S" name
))
571 (error "empty enum type: ~S" type
))))
573 (defun parse-enum (name elements
)
574 (when (null elements
)
575 (error "An enumeration must contain at least one element."))
580 (declare (list from-alist
))
581 (dolist (el elements
)
582 (multiple-value-bind (sym val
)
584 (values (first el
) (second el
))
585 (values el
(1+ prev
)))
587 (unless (symbolp sym
)
588 (error "The enumeration element ~S is not a symbol." sym
))
589 (unless (integerp val
)
590 (error "The element value ~S is not an integer." val
))
591 (unless (and max
(> max val
)) (setq max val
))
592 (unless (and min
(< min val
)) (setq min val
))
593 (when (rassoc val from-alist
)
594 (style-warn "The element value ~S is used more than once." val
))
595 (when (assoc sym from-alist
:test
#'eq
)
596 (error "The enumeration element ~S is used more than once." sym
))
597 (push (cons sym val
) from-alist
)))
598 (let* ((signed (minusp min
))
600 (1+ (max (integer-length min
)
601 (integer-length max
)))
602 (integer-length max
))))
603 (when (> min-bits
32)
604 (error "can't represent enums needing more than 32 bits"))
605 (setf from-alist
(sort from-alist
#'< :key
#'cdr
))
607 ;; If range is at least 20% dense, use vector mapping. Crossover
608 ;; point solely on basis of space would be 25%. Vector mapping
609 ;; is always faster, so give the benefit of the doubt.
610 ((< 0.2 (/ (float (length from-alist
)) (float (1+ (- max min
)))))
611 ;; If offset is small and ignorable, ignore it to save time.
612 (when (< 0 min
10) (setq min
0))
613 (let ((to (make-array (1+ (- max min
)))))
614 (dolist (el from-alist
)
615 (setf (svref to
(- (cdr el
) min
)) (car el
)))
616 (make-alien-enum-type :name name
:signed signed
617 :from from-alist
:to to
:kind
618 :vector
:offset
(- min
))))
620 (make-alien-enum-type :name name
:signed signed
622 :to
(mapcar (lambda (x) (cons (cdr x
) (car x
)))
626 (define-alien-type-method (enum :unparse
) (type)
627 `(enum ,(alien-enum-type-name type
)
629 (mapcar (lambda (mapping)
630 (let ((sym (car mapping
))
631 (value (cdr mapping
)))
633 (if (= (1+ prev
) value
)
637 (alien-enum-type-from type
)))))
639 (define-alien-type-method (enum :type
=) (type1 type2
)
640 (and (eq (alien-enum-type-name type1
)
641 (alien-enum-type-name type2
))
642 (equal (alien-enum-type-from type1
)
643 (alien-enum-type-from type2
))))
645 (define-alien-type-method (enum :lisp-rep
) (type)
646 `(member ,@(mapcar #'car
(alien-enum-type-from type
))))
648 (define-alien-type-method (enum :naturalize-gen
) (type alien
)
649 (ecase (alien-enum-type-kind type
)
651 `(svref ',(alien-enum-type-to type
)
652 (+ ,alien
,(alien-enum-type-offset type
))))
655 ,@(mapcar (lambda (mapping)
656 `(,(car mapping
) ',(cdr mapping
)))
657 (alien-enum-type-to type
))))))
659 (define-alien-type-method (enum :deport-gen
) (type value
)
661 ,@(mapcar (lambda (mapping)
662 `(,(car mapping
) ,(cdr mapping
)))
663 (alien-enum-type-from type
))))
667 (define-alien-type-class (float)
668 (type (missing-arg) :type symbol
))
670 (define-alien-type-method (float :unparse
) (type)
671 (alien-float-type-type type
))
673 (define-alien-type-method (float :lisp-rep
) (type)
674 (alien-float-type-type type
))
676 (define-alien-type-method (float :alien-rep
) (type context
)
677 (declare (ignore context
))
678 (alien-float-type-type type
))
680 (define-alien-type-method (float :naturalize-gen
) (type alien
)
681 (declare (ignore type
))
684 (define-alien-type-method (float :deport-gen
) (type value
)
685 (declare (ignore type
))
688 (define-alien-type-class (single-float :include
(float (bits 32))
689 :include-args
(type)))
691 (define-alien-type-translator single-float
()
692 (make-alien-single-float-type :type
'single-float
))
694 (define-alien-type-method (single-float :extract-gen
) (type sap offset
)
695 (declare (ignore type
))
696 `(sap-ref-single ,sap
(/ ,offset sb
!vm
:n-byte-bits
)))
698 (define-alien-type-class (double-float :include
(float (bits 64))
699 :include-args
(type)))
701 (define-alien-type-translator double-float
()
702 (make-alien-double-float-type :type
'double-float
))
704 (define-alien-type-method (double-float :extract-gen
) (type sap offset
)
705 (declare (ignore type
))
706 `(sap-ref-double ,sap
(/ ,offset sb
!vm
:n-byte-bits
)))
709 ;;;; the POINTER type
711 (define-alien-type-class (pointer :include
(alien-value (bits
712 sb
!vm
:n-machine-word-bits
)))
713 (to nil
:type
(or alien-type null
)))
715 (define-alien-type-translator * (to &environment env
)
716 (make-alien-pointer-type :to
(if (eq to t
) nil
(parse-alien-type to env
))))
718 (define-alien-type-method (pointer :unparse
) (type)
719 (let ((to (alien-pointer-type-to type
)))
721 (%unparse-alien-type to
)
724 (define-alien-type-method (pointer :type
=) (type1 type2
)
725 (let ((to1 (alien-pointer-type-to type1
))
726 (to2 (alien-pointer-type-to type2
)))
729 (alien-type-= to1 to2
)
733 (define-alien-type-method (pointer :subtypep
) (type1 type2
)
734 (and (alien-pointer-type-p type2
)
735 (let ((to1 (alien-pointer-type-to type1
))
736 (to2 (alien-pointer-type-to type2
)))
739 (alien-subtype-p to1 to2
)
743 (define-alien-type-method (pointer :deport-gen
) (type value
)
744 (/noshow
"doing alien type method POINTER :DEPORT-GEN" type value
)
746 ;; FIXME: old version, highlighted a bug in xc optimization
754 ;; new version, works around bug in xc optimization
763 `(or null system-area-pointer
(alien ,type
))))
765 ;;;; the MEM-BLOCK type
767 (define-alien-type-class (mem-block :include alien-value
))
769 (define-alien-type-method (mem-block :extract-gen
) (type sap offset
)
770 (declare (ignore type
))
771 `(sap+ ,sap
(truncate ,offset sb
!vm
:n-byte-bits
)))
773 (define-alien-type-method (mem-block :deposit-gen
) (type sap offset value
)
774 (let ((bits (alien-mem-block-type-bits type
)))
776 (error "can't deposit aliens of type ~S (unknown size)" type
))
777 `(sb!kernel
:system-area-ub8-copy
,value
0 ,sap
778 (truncate ,offset sb
!vm
:n-byte-bits
)
779 ',(truncate bits sb
!vm
:n-byte-bits
))))
783 (define-alien-type-class (array :include mem-block
)
784 (element-type (missing-arg) :type alien-type
)
785 (dimensions (missing-arg) :type list
))
787 (define-alien-type-translator array
(ele-type &rest dims
&environment env
)
790 (unless (typep (first dims
) '(or index null
))
791 (error "The first dimension is not a non-negative fixnum or NIL: ~S"
793 (let ((loser (find-if-not (lambda (x) (typep x
'index
))
796 (error "A dimension is not a non-negative fixnum: ~S" loser
))))
798 (let ((parsed-ele-type (parse-alien-type ele-type env
)))
799 (make-alien-array-type
800 :element-type parsed-ele-type
802 :alignment
(alien-type-alignment parsed-ele-type
)
803 :bits
(if (and (alien-type-bits parsed-ele-type
)
804 (every #'integerp dims
))
805 (* (align-offset (alien-type-bits parsed-ele-type
)
806 (alien-type-alignment parsed-ele-type
))
807 (reduce #'* dims
))))))
809 (define-alien-type-method (array :unparse
) (type)
810 `(array ,(%unparse-alien-type
(alien-array-type-element-type type
))
811 ,@(alien-array-type-dimensions type
)))
813 (define-alien-type-method (array :type
=) (type1 type2
)
814 (and (equal (alien-array-type-dimensions type1
)
815 (alien-array-type-dimensions type2
))
816 (alien-type-= (alien-array-type-element-type type1
)
817 (alien-array-type-element-type type2
))))
819 (define-alien-type-method (array :subtypep
) (type1 type2
)
820 (and (alien-array-type-p type2
)
821 (let ((dim1 (alien-array-type-dimensions type1
))
822 (dim2 (alien-array-type-dimensions type2
)))
823 (and (= (length dim1
) (length dim2
))
826 (equal (cdr dim1
) (cdr dim2
)))
828 (alien-subtype-p (alien-array-type-element-type type1
)
829 (alien-array-type-element-type type2
))))))
833 (def!struct
(alien-record-field (:copier nil
))
834 (name (missing-arg) :type symbol
)
835 (type (missing-arg) :type alien-type
)
836 (bits nil
:type
(or unsigned-byte null
))
837 (offset 0 :type unsigned-byte
))
838 (defmethod print-object ((field alien-record-field
) stream
)
839 (print-unreadable-object (field stream
:type t
)
842 (alien-record-field-type field
)
843 (alien-record-field-name field
)
844 (alien-record-field-bits field
))))
845 (!set-load-form-method alien-record-field
(:xc
:target
))
847 (define-alien-type-class (record :include mem-block
)
848 (kind :struct
:type
(member :struct
:union
))
849 (name nil
:type
(or symbol null
))
850 (fields nil
:type list
))
852 (define-alien-type-translator struct
(name &rest fields
&environment env
)
853 (parse-alien-record-type :struct name fields env
))
855 (define-alien-type-translator union
(name &rest fields
&environment env
)
856 (parse-alien-record-type :union name fields env
))
858 ;;; FIXME: This is really pretty horrible: we avoid creating new
859 ;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the
860 ;;; system already. This way forward-references sans fields get
861 ;;; "updated" for free to contain the field info. Maybe rename
862 ;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use
863 ;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729
864 (defun parse-alien-record-type (kind name fields env
)
865 (declare (type sb
!kernel
:lexenv-designator env
))
866 (flet ((frob-type (type new-fields alignment bits
)
867 (setf (alien-record-type-fields type
) new-fields
868 (alien-record-type-alignment type
) alignment
869 (alien-record-type-bits type
) bits
)))
871 (multiple-value-bind (new-fields alignment bits
)
872 (parse-alien-record-fields kind fields env
)
873 (let* ((old (and name
(auxiliary-alien-type kind name env
)))
874 (old-fields (and old
(alien-record-type-fields old
))))
875 (when (and old-fields
876 (notevery #'record-fields-match-p old-fields new-fields
))
877 (cerror "Continue, clobbering the old definition."
878 "Incompatible alien record type definition~%Old: ~S~%New: ~S"
879 (unparse-alien-type old
)
880 `(,(unparse-alien-record-kind kind
)
882 ,@(let ((*record-types-already-unparsed
* '()))
883 (mapcar #'unparse-alien-record-field new-fields
))))
884 (frob-type old new-fields alignment bits
))
887 (let ((type (or old
(make-alien-record-type :name name
:kind kind
))))
888 (when (and name
(not old
))
889 (setf (auxiliary-alien-type kind name env
) type
))
890 (frob-type type new-fields alignment bits
)
893 (or (auxiliary-alien-type kind name env
)
894 (setf (auxiliary-alien-type kind name env
)
895 (make-alien-record-type :name name
:kind kind
))))
897 (make-alien-record-type :kind kind
)))))
899 ;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union
900 ;;; types. KIND is the kind we are paring the fields of, and FIELDS is the
901 ;;; list of field specifications.
903 ;;; Result is a list of field objects, overall alignment, and number of bits
904 (defun parse-alien-record-fields (kind fields env
)
905 (declare (type list fields
))
907 (overall-alignment 1)
909 (dolist (field fields
)
910 (destructuring-bind (var type
&key alignment bits offset
) field
911 (declare (ignore bits
))
912 (let* ((field-type (parse-alien-type type env
))
913 (bits (alien-type-bits field-type
))
915 (make-alien-record-field :type field-type
918 (setf alignment
(alien-type-alignment field-type
)))
919 (push parsed-field parsed-fields
)
921 (error "unknown size: ~S" (unparse-alien-type field-type
)))
922 (when (null alignment
)
923 (error "unknown alignment: ~S" (unparse-alien-type field-type
)))
924 (setf overall-alignment
(max overall-alignment alignment
))
927 (let ((offset (or offset
(align-offset total-bits alignment
))))
928 (setf (alien-record-field-offset parsed-field
) offset
)
929 (setf total-bits
(+ offset bits
))))
931 (setf total-bits
(max total-bits bits
)))))))
932 (values (nreverse parsed-fields
)
934 (align-offset total-bits overall-alignment
))))
936 (define-alien-type-method (record :unparse
) (type)
937 `(,(unparse-alien-record-kind (alien-record-type-kind type
))
938 ,(alien-record-type-name type
)
939 ,@(unless (member type
*record-types-already-unparsed
* :test
#'eq
)
940 (push type
*record-types-already-unparsed
*)
941 (mapcar #'unparse-alien-record-field
942 (alien-record-type-fields type
)))))
944 (defun unparse-alien-record-kind (kind)
950 (defun unparse-alien-record-field (field)
951 `(,(alien-record-field-name field
)
952 ,(%unparse-alien-type
(alien-record-field-type field
))
953 ,@(when (alien-record-field-bits field
)
954 (list :bits
(alien-record-field-bits field
)))
955 ,@(when (alien-record-field-offset field
)
956 (list :offset
(alien-record-field-offset field
)))))
958 ;;; Test the record fields. Keep a hashtable table of already compared
959 ;;; types to detect cycles.
960 (defun record-fields-match-p (field1 field2
)
961 (and (eq (alien-record-field-name field1
)
962 (alien-record-field-name field2
))
963 (eql (alien-record-field-bits field1
)
964 (alien-record-field-bits field2
))
965 (eql (alien-record-field-offset field1
)
966 (alien-record-field-offset field2
))
967 (alien-type-= (alien-record-field-type field1
)
968 (alien-record-field-type field2
))))
970 (defvar *alien-type-matches
* nil
971 "A hashtable used to detect cycles while comparing record types.")
973 (define-alien-type-method (record :type
=) (type1 type2
)
974 (and (eq (alien-record-type-name type1
)
975 (alien-record-type-name type2
))
976 (eq (alien-record-type-kind type1
)
977 (alien-record-type-kind type2
))
978 (eql (alien-type-bits type1
)
979 (alien-type-bits type2
))
980 (eql (alien-type-alignment type1
)
981 (alien-type-alignment type2
))
982 (flet ((match-fields (&optional old
)
983 (setf (gethash type1
*alien-type-matches
*) (cons type2 old
))
984 (every #'record-fields-match-p
985 (alien-record-type-fields type1
)
986 (alien-record-type-fields type2
))))
987 (if *alien-type-matches
*
988 (let ((types (gethash type1
*alien-type-matches
*)))
989 (or (memq type2 types
) (match-fields types
)))
990 (let ((*alien-type-matches
* (make-hash-table :test
#'eq
)))
993 ;;;; the FUNCTION and VALUES alien types
995 ;;; Calling-convention spec, typically one of predefined keywords.
996 ;;; Add or remove as needed for target platform. It makes sense to
997 ;;; support :cdecl everywhere.
999 ;;; Null convention is supposed to be platform-specific most-universal
1000 ;;; callout convention. For x86, SBCL calls foreign functions in a way
1001 ;;; allowing them to be either stdcall or cdecl; null convention is
1002 ;;; appropriate here, as it is for specifying callbacks that could be
1003 ;;; accepted by foreign code both in cdecl and stdcall form.
1004 (def!type calling-convention
() `(or null
(member :stdcall
:cdecl
)))
1006 ;;; Convention could be a values type class, stored at result-type.
1007 ;;; However, it seems appropriate only for epilogue-related
1008 ;;; conventions, those not influencing incoming arg passing.
1010 ;;; As of x86's :stdcall and :cdecl, supported by now, both are
1011 ;;; epilogue-related, but future extensions (like :fastcall and
1012 ;;; miscellaneous non-x86 stuff) might affect incoming argument
1013 ;;; translation as well.
1015 (define-alien-type-class (fun :include mem-block
)
1016 (result-type (missing-arg) :type alien-type
)
1017 (arg-types (missing-arg) :type list
)
1018 (stub nil
:type
(or null function
))
1019 (convention nil
:type calling-convention
))
1021 ;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
1022 ;;; convention specification for function types is unobvious.
1024 ;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
1025 ;;; starting with a convention keyword; its second item is a real
1026 ;;; result-type in this case. If convention is ever to become a part
1027 ;;; of result-type, such a syntax can be retained.
1029 (define-alien-type-translator function
(result-type &rest arg-types
1031 (multiple-value-bind (bare-result-type calling-convention
)
1032 (typecase result-type
1033 ((cons calling-convention
*)
1034 (values (second result-type
) (first result-type
)))
1036 (make-alien-fun-type
1037 :convention calling-convention
1038 :result-type
(let ((*values-type-okay
* t
))
1039 (parse-alien-type bare-result-type env
))
1040 :arg-types
(mapcar (lambda (arg-type) (parse-alien-type arg-type env
))
1043 (define-alien-type-method (fun :unparse
) (type)
1044 `(function ,(let ((result-type
1045 (%unparse-alien-type
(alien-fun-type-result-type type
)))
1046 (convention (alien-fun-type-convention type
)))
1047 (if convention
(list convention result-type
)
1049 ,@(mapcar #'%unparse-alien-type
1050 (alien-fun-type-arg-types type
))))
1052 (define-alien-type-method (fun :type
=) (type1 type2
)
1053 (and (alien-type-= (alien-fun-type-result-type type1
)
1054 (alien-fun-type-result-type type2
))
1055 (eq (alien-fun-type-convention type1
)
1056 (alien-fun-type-convention type2
))
1057 (= (length (alien-fun-type-arg-types type1
))
1058 (length (alien-fun-type-arg-types type2
)))
1059 (every #'alien-type-
=
1060 (alien-fun-type-arg-types type1
)
1061 (alien-fun-type-arg-types type2
))))
1063 (define-alien-type-class (values)
1064 (values (missing-arg) :type list
))
1066 (define-alien-type-translator values
(&rest values
&environment env
)
1067 (unless *values-type-okay
*
1068 (error "cannot use values types here"))
1069 (let ((*values-type-okay
* nil
))
1070 (make-alien-values-type
1071 :values
(mapcar (lambda (alien-type) (parse-alien-type alien-type env
))
1074 (define-alien-type-method (values :unparse
) (type)
1075 `(values ,@(mapcar #'%unparse-alien-type
1076 (alien-values-type-values type
))))
1078 (define-alien-type-method (values :type
=) (type1 type2
)
1079 (and (= (length (alien-values-type-values type1
))
1080 (length (alien-values-type-values type2
)))
1081 (every #'alien-type-
=
1082 (alien-values-type-values type1
)
1083 (alien-values-type-values type2
))))
1085 ;;;; a structure definition needed both in the target and in the
1086 ;;;; cross-compilation host
1088 ;;; information about local aliens. The WITH-ALIEN macro builds one of
1089 ;;; these structures and LOCAL-ALIEN and friends communicate
1090 ;;; information about how that local alien is represented.
1091 (def!struct
(local-alien-info
1093 (:constructor make-local-alien-info
1094 (&key type force-to-memory-p
1095 &aux
(force-to-memory-p (or force-to-memory-p
1096 (alien-array-type-p type
)
1097 (alien-record-type-p type
))))))
1098 ;; the type of the local alien
1099 (type (missing-arg) :type alien-type
)
1100 ;; Must this local alien be forced into memory? Using the ADDR macro
1101 ;; on a local alien will set this.
1102 (force-to-memory-p nil
:type
(member t nil
)))
1103 (!set-load-form-method local-alien-info
(:xc
:target
))
1104 (defmethod print-object ((info local-alien-info
) stream
)
1105 (print-unreadable-object (info stream
:type t
)
1107 "~:[~;(forced to stack) ~]~S"
1108 (local-alien-info-force-to-memory-p info
)
1109 (unparse-alien-type (local-alien-info-type info
)))))
1113 (sb!xc
:defmacro addr
(expr &environment env
)
1114 "Return an Alien pointer to the data addressed by Expr, which must be a call
1115 to SLOT or DEREF, or a reference to an Alien variable."
1116 (let ((form (%macroexpand expr env
)))
1121 (cons '%slot-addr
(cdr form
)))
1123 (cons '%deref-addr
(cdr form
)))
1125 (cons '%heap-alien-addr
(cdr form
)))
1127 (let ((info (let ((info-arg (second form
)))
1128 (and (consp info-arg
)
1129 (eq (car info-arg
) 'quote
)
1130 (second info-arg
)))))
1131 (unless (local-alien-info-p info
)
1132 (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
1134 (setf (local-alien-info-force-to-memory-p info
) t
))
1135 (cons '%local-alien-addr
(cdr form
)))))
1137 (let ((kind (info :variable
:kind form
)))
1138 (when (eq kind
:alien
)
1139 `(%heap-alien-addr
',(info :variable
:alien-info form
))))))
1140 (error "~S is not a valid L-value." form
))))
1142 (/show0
"host-alieneval.lisp end of file")