(defstruct (alien-type-class (:copier nil))
(name nil :type symbol)
+ (defstruct-name nil :type symbol)
(include nil :type (or null alien-type-class))
(unparse nil :type (or null function))
(type= nil :type (or null function))
(or (gethash name *alien-type-classes*)
(error "no alien type class ~S" name)))
-(defun create-alien-type-class-if-necessary (name include)
+(defun create-alien-type-class-if-necessary (name defstruct-name include)
(let ((old (gethash name *alien-type-classes*))
(include (and include (alien-type-class-or-lose include))))
(if old
(setf (alien-type-class-include old) include)
(setf (gethash name *alien-type-classes*)
- (make-alien-type-class :name name :include include)))))
+ (make-alien-type-class :name name
+ :defstruct-name defstruct-name
+ :include include)))))
(defparameter *method-slot-alist*
'((:unparse . alien-type-class-unparse)
(symbol
(values
include
- (symbolicate "ALIEN-" include "-TYPE")
+ (alien-type-class-defstruct-name
+ (alien-type-class-or-lose include))
nil))
(list
(values
(car include)
- (symbolicate "ALIEN-" (car include) "-TYPE")
+ (alien-type-class-defstruct-name
+ (alien-type-class-or-lose (car include)))
(cdr include))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
- (create-alien-type-class-if-necessary ',name ',(or include 'root)))
+ (create-alien-type-class-if-necessary ',name ',defstruct-name
+ ',(or include 'root)))
(def!struct (,defstruct-name
(:include ,include-defstruct
(class ',name)
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun auxiliary-type-definitions (env)
(multiple-value-bind (result expanded-p)
- (sb!xc:macroexpand '&auxiliary-type-definitions& env)
+ (%macroexpand '&auxiliary-type-definitions& env)
(if expanded-p
result
;; This is like having the global symbol-macro definition be
;;;; the root alien type
(eval-when (:compile-toplevel :load-toplevel :execute)
- (create-alien-type-class-if-necessary 'root nil))
+ (create-alien-type-class-if-necessary 'root 'alien-type nil))
(def!struct (alien-type
(:make-load-form-fun sb!kernel:just-dump-it-normally)
(declare (ignore type))
'system-area-pointer)
-(define-alien-type-method (system-area-pointer :alien-rep) (type)
- (declare (ignore type))
+(define-alien-type-method (system-area-pointer :alien-rep) (type context)
+ (declare (ignore type context))
'system-area-pointer)
(define-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
(:make-load-form-fun sb!kernel:just-dump-it-normally))
;; The type of this alien.
(type (missing-arg) :type alien-type)
- ;; The form to evaluate to produce the SAP pointing to where in the heap
- ;; it is.
- (sap-form (missing-arg)))
+ ;; Its name.
+ (alien-name (missing-arg) :type simple-string)
+ ;; Data or code?
+ (datap (missing-arg) :type boolean))
(def!method print-object ((info heap-alien-info) stream)
(print-unreadable-object (info stream :type t)
- (funcall (formatter "~S ~S")
+ (funcall (formatter "~S ~S~@[ (data)~]")
stream
- (heap-alien-info-sap-form info)
- (unparse-alien-type (heap-alien-info-type info)))))
+ (heap-alien-info-alien-name info)
+ (unparse-alien-type (heap-alien-info-type info))
+ (heap-alien-info-datap info))))
+
+;;; The form to evaluate to produce the SAP pointing to where in the heap
+;;; it is.
+(defun heap-alien-info-sap-form (info)
+ `(foreign-symbol-sap ,(heap-alien-info-alien-name info)
+ ,(heap-alien-info-datap info)))
+
+(defun heap-alien-info-sap (info)
+ (foreign-symbol-sap (heap-alien-info-alien-name info)
+ (heap-alien-info-datap info)))
\f
;;;; Interfaces to the different methods
(def!macro maybe-with-pinned-objects (variables types &body body)
(declare (ignorable variables types))
(let ((pin-variables
- ;; Only pin things on x86/x86-64, since on non-conservative
- ;; gcs it'd imply disabling the GC. Which is something we
- ;; don't want to do every time we're calling to C.
- #!+(or x86 x86-64)
+ ;; Only pin things on GENCGC, since on CHENEYGC it'd imply
+ ;; disabling the GC. Which is something we don't want to do
+ ;; every time we're calling to C.
+ #!+gencgc
(loop for variable in variables
for type in types
when (invoke-alien-type-method :deport-pin-p type)
(defun compute-deposit-lambda (type)
(declare (type alien-type type))
- `(lambda (sap offset ignore value)
+ `(lambda (value sap offset ignore)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(ignore ignore))
(defun compute-lisp-rep-type (type)
(invoke-alien-type-method :lisp-rep type))
-(defun compute-alien-rep-type (type)
- (invoke-alien-type-method :alien-rep type))
+;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function
+;;; return values). See the :ALIEN-REP method for INTEGER for
+;;; details.
+(defun compute-alien-rep-type (type &optional (context :normal))
+ (invoke-alien-type-method :alien-rep type context))
\f
;;;; default methods
(declare (ignore type))
nil)
-(define-alien-type-method (root :alien-rep) (type)
- (declare (ignore type))
+(define-alien-type-method (root :alien-rep) (type context)
+ (declare (ignore type context))
'*)
(define-alien-type-method (root :naturalize-gen) (type alien)
(list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
(alien-integer-type-bits type)))
-(define-alien-type-method (integer :alien-rep) (type)
- (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
- (alien-integer-type-bits type)))
-
+(define-alien-type-method (integer :alien-rep) (type context)
+ ;; When returning integer values that are narrower than a machine
+ ;; register from a function, some platforms leave the higher bits of
+ ;; the register uninitialized. On those platforms, we use an
+ ;; alien-rep of the full register width when checking for purposes
+ ;; of return values and override the naturalize method to perform
+ ;; the sign extension (in compiler/target/c-call.lisp).
+ (ecase context
+ ((:normal #!-(or x86 x86-64) :result)
+ (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+ (alien-integer-type-bits type)))
+ #!+(or x86 x86-64)
+ (:result
+ (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+ sb!vm:n-word-bits))))
+
+;;; As per the comment in the :ALIEN-REP method above, this is defined
+;;; elsewhere for x86oids.
+#!-(or x86 x86-64)
(define-alien-type-method (integer :naturalize-gen) (type alien)
(declare (ignore type))
alien)
`(member t nil))
(define-alien-type-method (boolean :naturalize-gen) (type alien)
- (declare (ignore type))
- `(not (zerop ,alien)))
+ (let ((bits (alien-boolean-type-bits type)))
+ (if (= bits sb!vm:n-word-bits)
+ `(not (zerop ,alien))
+ `(logtest ,alien ,(ldb (byte bits 0) -1)))))
(define-alien-type-method (boolean :deport-gen) (type value)
(declare (ignore type))
(auxiliary-alien-type :enum name env)
(when old-p
(unless (alien-type-= result old)
- (warn "redefining alien enum ~S" name))))
- (setf (auxiliary-alien-type :enum name env) result))
+ (cerror "Continue, clobbering the old definition"
+ "Incompatible alien enum type definition: ~S" name)
+ (setf (alien-type-from old) (alien-type-from result)
+ (alien-type-to old) (alien-type-to result)
+ (alien-type-kind old) (alien-type-kind result)
+ (alien-type-offset old) (alien-type-offset result)
+ (alien-type-signed old) (alien-type-signed result)))
+ (setf result old))
+ (unless old-p
+ (setf (auxiliary-alien-type :enum name env) result))))
result))
(name
(multiple-value-bind (result found)
(define-alien-type-method (float :lisp-rep) (type)
(alien-float-type-type type))
-(define-alien-type-method (float :alien-rep) (type)
+(define-alien-type-method (float :alien-rep) (type context)
+ (declare (ignore context))
(alien-float-type-type type))
(define-alien-type-method (float :naturalize-gen) (type alien)
;;; FIXME: This is really pretty horrible: we avoid creating new
;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the
-;;; system already. This way forwrd-references sans fields get get
+;;; system already. This way forward-references sans fields get
;;; "updated" for free to contain the field info. Maybe rename
;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use
;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729
(overall-alignment 1)
(parsed-fields nil))
(dolist (field fields)
- (destructuring-bind (var type &key alignment) field
+ (destructuring-bind (var type &key alignment bits offset) field
+ (declare (ignore bits))
(let* ((field-type (parse-alien-type type env))
(bits (alien-type-bits field-type))
(parsed-field
(setf overall-alignment (max overall-alignment alignment))
(ecase kind
(:struct
- (let ((offset (align-offset total-bits alignment)))
+ (let ((offset (or offset (align-offset total-bits alignment))))
(setf (alien-record-field-offset parsed-field) offset)
(setf total-bits (+ offset bits))))
(:union
`(,(alien-record-field-name field)
,(%unparse-alien-type (alien-record-field-type field))
,@(when (alien-record-field-bits field)
- (list (alien-record-field-bits field)))))
+ (list :bits (alien-record-field-bits field)))
+ ,@(when (alien-record-field-offset field)
+ (list :offset (alien-record-field-offset field)))))
;;; Test the record fields. Keep a hashtable table of already compared
;;; types to detect cycles.
\f
;;;; the FUNCTION and VALUES alien types
+;;; Calling-convention spec, typically one of predefined keywords.
+;;; Add or remove as needed for target platform. It makes sense to
+;;; support :cdecl everywhere.
+;;;
+;;; Null convention is supposed to be platform-specific most-universal
+;;; callout convention. For x86, SBCL calls foreign functions in a way
+;;; allowing them to be either stdcall or cdecl; null convention is
+;;; appropriate here, as it is for specifying callbacks that could be
+;;; accepted by foreign code both in cdecl and stdcall form.
+(def!type calling-convention () `(or null (member :stdcall :cdecl)))
+
+;;; Convention could be a values type class, stored at result-type.
+;;; However, it seems appropriate only for epilogue-related
+;;; conventions, those not influencing incoming arg passing.
+;;;
+;;; As of x86's :stdcall and :cdecl, supported by now, both are
+;;; epilogue-related, but future extensions (like :fastcall and
+;;; miscellaneous non-x86 stuff) might affect incoming argument
+;;; translation as well.
+
(define-alien-type-class (fun :include mem-block)
(result-type (missing-arg) :type alien-type)
(arg-types (missing-arg) :type list)
- (stub nil :type (or null function)))
+ (stub nil :type (or null function))
+ (convention nil :type calling-convention))
+
+;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
+;;; convention specification for function types is unobvious.
+;;;
+;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
+;;; starting with a convention keyword; its second item is a real
+;;; result-type in this case. If convention is ever to become a part
+;;; of result-type, such a syntax can be retained.
(define-alien-type-translator function (result-type &rest arg-types
&environment env)
- (make-alien-fun-type
- :result-type (let ((*values-type-okay* t))
- (parse-alien-type result-type env))
- :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
- arg-types)))
+ (multiple-value-bind (bare-result-type calling-convention)
+ (typecase result-type
+ ((cons calling-convention *)
+ (values (second result-type) (first result-type)))
+ (t result-type))
+ (make-alien-fun-type
+ :convention calling-convention
+ :result-type (let ((*values-type-okay* t))
+ (parse-alien-type bare-result-type env))
+ :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
+ arg-types))))
(define-alien-type-method (fun :unparse) (type)
- `(function ,(%unparse-alien-type (alien-fun-type-result-type type))
+ `(function ,(let ((result-type
+ (%unparse-alien-type (alien-fun-type-result-type type)))
+ (convention (alien-fun-type-convention type)))
+ (if convention (list convention result-type)
+ result-type))
,@(mapcar #'%unparse-alien-type
(alien-fun-type-arg-types type))))
(define-alien-type-method (fun :type=) (type1 type2)
(and (alien-type-= (alien-fun-type-result-type type1)
(alien-fun-type-result-type type2))
+ (eq (alien-fun-type-convention type1)
+ (alien-fun-type-convention type2))
(= (length (alien-fun-type-arg-types type1))
(length (alien-fun-type-arg-types type2)))
(every #'alien-type-=
#!+sb-doc
"Return an Alien pointer to the data addressed by Expr, which must be a call
to SLOT or DEREF, or a reference to an Alien variable."
- (let ((form (sb!xc:macroexpand expr env)))
+ (let ((form (%macroexpand expr env)))
(or (typecase form
(cons
(case (car form)
projects / sbcl.git / blobdiff